From 6f80c64d9c633d41a81e56c91fdfc580cd3dbd00 Mon Sep 17 00:00:00 2001 From: Raymond Date: Sat, 12 Sep 2009 06:24:59 +0000 Subject: [PATCH] PS Added git-svn-id: http://www.villavu.com/repositories/merlijn/mufasa@38 3f818213-9676-44b0-a9b4-5e4c4e03d09d --- Projects/SAMufasaGUI/project1.lpi | 309 +- Projects/SAMufasaGUI/project1.lpr | 3 +- Projects/SAMufasaGUI/testunit.lfm | 1398 +- Projects/SAMufasaGUI/testunit.lrs | 296 +- Projects/SAMufasaGUI/testunit.pas | 24 +- Units/MMLAddon/mmlpsthread.pas | 245 + Units/MMLCore/mufasatypes.pas | 2 +- Units/PascalScript/PascalScript.inc | 62 + Units/PascalScript/PascalScriptFPC.inc | 15 + .../PascalScript_Core_Ext_Reg.pas | 30 + Units/PascalScript/PascalScript_Core_Reg.pas | 65 + .../PascalScript_Core_Reg_noDB.pas | 48 + Units/PascalScript/PascalScript_RO_Reg.pas | 34 + Units/PascalScript/arm.inc | 312 + Units/PascalScript/eDefines.inc | 493 + Units/PascalScript/pascalscript.pas | 29 + Units/PascalScript/powerpc.inc | 343 + Units/PascalScript/uPSC_DB.pas | 892 + Units/PascalScript/uPSC_buttons.pas | 87 + Units/PascalScript/uPSC_classes.pas | 320 + Units/PascalScript/uPSC_comobj.pas | 28 + Units/PascalScript/uPSC_controls.pas | 236 + Units/PascalScript/uPSC_dateutils.pas | 34 + Units/PascalScript/uPSC_dll.pas | 158 + Units/PascalScript/uPSC_extctrls.pas | 327 + Units/PascalScript/uPSC_forms.pas | 271 + Units/PascalScript/uPSC_graphics.pas | 275 + Units/PascalScript/uPSC_menus.pas | 214 + Units/PascalScript/uPSC_std.pas | 87 + Units/PascalScript/uPSC_stdctrls.pas | 633 + Units/PascalScript/uPSCompiler.pas | 15397 ++++++++++++++++ Units/PascalScript/uPSComponent.pas | 1511 ++ Units/PascalScript/uPSComponentExt.pas | 1010 + Units/PascalScript/uPSComponent_COM.pas | 38 + Units/PascalScript/uPSComponent_Controls.pas | 65 + Units/PascalScript/uPSComponent_DB.pas | 36 + Units/PascalScript/uPSComponent_Default.pas | 81 + Units/PascalScript/uPSComponent_Forms.pas | 65 + Units/PascalScript/uPSComponent_StdCtrls.pas | 65 + Units/PascalScript/uPSDebugger.pas | 654 + Units/PascalScript/uPSDisassembly.pas | 499 + Units/PascalScript/uPSI_Dialogs.pas | 741 + Units/PascalScript/uPSI_IBX.pas | 2153 +++ Units/PascalScript/uPSI_JvMail.pas | 373 + Units/PascalScript/uPSI_Mask.pas | 187 + Units/PascalScript/uPSI_Registry.pas | 478 + Units/PascalScript/uPSPreProcessor.pas | 800 + Units/PascalScript/uPSR_DB.pas | 2094 +++ Units/PascalScript/uPSR_buttons.pas | 38 + Units/PascalScript/uPSR_classes.pas | 383 + Units/PascalScript/uPSR_comobj.pas | 96 + Units/PascalScript/uPSR_controls.pas | 249 + Units/PascalScript/uPSR_dateutils.pas | 63 + Units/PascalScript/uPSR_dll.pas | 312 + Units/PascalScript/uPSR_extctrls.pas | 150 + Units/PascalScript/uPSR_forms.pas | 264 + Units/PascalScript/uPSR_graphics.pas | 218 + Units/PascalScript/uPSR_menus.pas | 460 + Units/PascalScript/uPSR_std.pas | 85 + Units/PascalScript/uPSR_stdctrls.pas | 287 + Units/PascalScript/uPSRuntime.pas | 12454 +++++++++++++ Units/PascalScript/uPSUtils.pas | 1592 ++ Units/PascalScript/uPS_ExtReg.pas | 17 + Units/PascalScript/uROPSImports.pas | 366 + Units/PascalScript/uROPSServerLink.pas | 1231 ++ Units/PascalScript/x64.inc | 513 + Units/PascalScript/x86.inc | 739 + 67 files changed, 52891 insertions(+), 143 deletions(-) create mode 100644 Units/MMLAddon/mmlpsthread.pas create mode 100644 Units/PascalScript/PascalScript.inc create mode 100644 Units/PascalScript/PascalScriptFPC.inc create mode 100644 Units/PascalScript/PascalScript_Core_Ext_Reg.pas create mode 100644 Units/PascalScript/PascalScript_Core_Reg.pas create mode 100644 Units/PascalScript/PascalScript_Core_Reg_noDB.pas create mode 100644 Units/PascalScript/PascalScript_RO_Reg.pas create mode 100644 Units/PascalScript/arm.inc create mode 100644 Units/PascalScript/eDefines.inc create mode 100644 Units/PascalScript/pascalscript.pas create mode 100644 Units/PascalScript/powerpc.inc create mode 100644 Units/PascalScript/uPSC_DB.pas create mode 100644 Units/PascalScript/uPSC_buttons.pas create mode 100644 Units/PascalScript/uPSC_classes.pas create mode 100644 Units/PascalScript/uPSC_comobj.pas create mode 100644 Units/PascalScript/uPSC_controls.pas create mode 100644 Units/PascalScript/uPSC_dateutils.pas create mode 100644 Units/PascalScript/uPSC_dll.pas create mode 100644 Units/PascalScript/uPSC_extctrls.pas create mode 100644 Units/PascalScript/uPSC_forms.pas create mode 100644 Units/PascalScript/uPSC_graphics.pas create mode 100644 Units/PascalScript/uPSC_menus.pas create mode 100644 Units/PascalScript/uPSC_std.pas create mode 100644 Units/PascalScript/uPSC_stdctrls.pas create mode 100644 Units/PascalScript/uPSCompiler.pas create mode 100644 Units/PascalScript/uPSComponent.pas create mode 100644 Units/PascalScript/uPSComponentExt.pas create mode 100644 Units/PascalScript/uPSComponent_COM.pas create mode 100644 Units/PascalScript/uPSComponent_Controls.pas create mode 100644 Units/PascalScript/uPSComponent_DB.pas create mode 100644 Units/PascalScript/uPSComponent_Default.pas create mode 100644 Units/PascalScript/uPSComponent_Forms.pas create mode 100644 Units/PascalScript/uPSComponent_StdCtrls.pas create mode 100644 Units/PascalScript/uPSDebugger.pas create mode 100644 Units/PascalScript/uPSDisassembly.pas create mode 100644 Units/PascalScript/uPSI_Dialogs.pas create mode 100644 Units/PascalScript/uPSI_IBX.pas create mode 100644 Units/PascalScript/uPSI_JvMail.pas create mode 100644 Units/PascalScript/uPSI_Mask.pas create mode 100644 Units/PascalScript/uPSI_Registry.pas create mode 100644 Units/PascalScript/uPSPreProcessor.pas create mode 100644 Units/PascalScript/uPSR_DB.pas create mode 100644 Units/PascalScript/uPSR_buttons.pas create mode 100644 Units/PascalScript/uPSR_classes.pas create mode 100644 Units/PascalScript/uPSR_comobj.pas create mode 100644 Units/PascalScript/uPSR_controls.pas create mode 100644 Units/PascalScript/uPSR_dateutils.pas create mode 100644 Units/PascalScript/uPSR_dll.pas create mode 100644 Units/PascalScript/uPSR_extctrls.pas create mode 100644 Units/PascalScript/uPSR_forms.pas create mode 100644 Units/PascalScript/uPSR_graphics.pas create mode 100644 Units/PascalScript/uPSR_menus.pas create mode 100644 Units/PascalScript/uPSR_std.pas create mode 100644 Units/PascalScript/uPSR_stdctrls.pas create mode 100644 Units/PascalScript/uPSRuntime.pas create mode 100644 Units/PascalScript/uPSUtils.pas create mode 100644 Units/PascalScript/uPS_ExtReg.pas create mode 100644 Units/PascalScript/uROPSImports.pas create mode 100644 Units/PascalScript/uROPSServerLink.pas create mode 100644 Units/PascalScript/x64.inc create mode 100644 Units/PascalScript/x86.inc diff --git a/Projects/SAMufasaGUI/project1.lpi b/Projects/SAMufasaGUI/project1.lpi index dfa41b1..d06eef3 100644 --- a/Projects/SAMufasaGUI/project1.lpi +++ b/Projects/SAMufasaGUI/project1.lpi @@ -7,7 +7,7 @@ <UseXPManifest Value="True"/> - <ActiveEditorIndexAtStart Value="9"/> + <ActiveEditorIndexAtStart Value="8"/> </General> <VersionInfo> <ProjectVersion Value=""/> @@ -24,20 +24,24 @@ <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/> </local> </RunParams> - <RequiredPackages Count="1"> + <RequiredPackages Count="2"> <Item1> - <PackageName Value="LCL"/> + <PackageName Value="SynEdit"/> + <MinVersion Major="1" Valid="True"/> </Item1> + <Item2> + <PackageName Value="LCL"/> + </Item2> </RequiredPackages> - <Units Count="50"> + <Units Count="64"> <Unit0> <Filename Value="project1.lpr"/> <IsPartOfProject Value="True"/> <UnitName Value="project1"/> - <CursorPos X="12" Y="11"/> - <TopLine Value="1"/> + <CursorPos X="13" Y="17"/> + <TopLine Value="7"/> <EditorIndex Value="0"/> - <UsageCount Value="65"/> + <UsageCount Value="70"/> <Loaded Value="True"/> </Unit0> <Unit1> @@ -166,10 +170,10 @@ <HasResources Value="True"/> <ResourceBaseClass Value="Form"/> <UnitName Value="TestUnit"/> - <CursorPos X="26" Y="266"/> - <TopLine Value="241"/> - <EditorIndex Value="5"/> - <UsageCount Value="31"/> + <CursorPos X="19" Y="271"/> + <TopLine Value="259"/> + <EditorIndex Value="7"/> + <UsageCount Value="36"/> <Loaded Value="True"/> </Unit18> <Unit19> @@ -298,20 +302,20 @@ <Filename Value="../../Units/MMLCore/client.pas"/> <IsPartOfProject Value="True"/> <UnitName Value="Client"/> - <CursorPos X="46" Y="39"/> - <TopLine Value="1"/> - <EditorIndex Value="3"/> - <UsageCount Value="30"/> + <CursorPos X="25" Y="4"/> + <TopLine Value="4"/> + <EditorIndex Value="5"/> + <UsageCount Value="35"/> <Loaded Value="True"/> </Unit37> <Unit38> <Filename Value="../../Units/MMLCore/mufasatypes.pas"/> <IsPartOfProject Value="True"/> <UnitName Value="MufasaTypes"/> - <CursorPos X="3" Y="16"/> - <TopLine Value="1"/> - <EditorIndex Value="2"/> - <UsageCount Value="30"/> + <CursorPos X="4" Y="26"/> + <TopLine Value="12"/> + <EditorIndex Value="4"/> + <UsageCount Value="35"/> <Loaded Value="True"/> </Unit38> <Unit39> @@ -327,22 +331,20 @@ <UnitName Value="files"/> <CursorPos X="62" Y="61"/> <TopLine Value="46"/> - <EditorIndex Value="7"/> - <UsageCount Value="31"/> - <Loaded Value="True"/> + <UsageCount Value="36"/> </Unit40> <Unit41> <Filename Value="../../Units/MMLCore/window.pas"/> <IsPartOfProject Value="True"/> <UnitName Value="Window"/> - <CursorPos X="35" Y="187"/> - <TopLine Value="174"/> - <EditorIndex Value="4"/> - <UsageCount Value="30"/> + <CursorPos X="8" Y="262"/> + <TopLine Value="255"/> + <EditorIndex Value="6"/> + <UsageCount Value="35"/> <Loaded Value="True"/> </Unit41> <Unit42> - <Filename Value="../../../../Documents/lazarus/lcl/forms.pp"/> + <Filename Value="../../../Documents/lazarus/lcl/forms.pp"/> <UnitName Value="Forms"/> <CursorPos X="15" Y="1236"/> <TopLine Value="981"/> @@ -360,27 +362,23 @@ <UnitName Value="windowutil"/> <CursorPos X="39" Y="19"/> <TopLine Value="9"/> - <EditorIndex Value="6"/> - <UsageCount Value="14"/> - <Loaded Value="True"/> + <UsageCount Value="15"/> </Unit44> <Unit45> <Filename Value="../../Units/MMLCore/input.pas"/> <UnitName Value="Input"/> <CursorPos X="39" Y="203"/> <TopLine Value="187"/> - <EditorIndex Value="8"/> - <UsageCount Value="13"/> - <Loaded Value="True"/> + <UsageCount Value="14"/> </Unit45> <Unit46> <Filename Value="../../Units/MMLCore/finder.pas"/> <IsPartOfProject Value="True"/> <UnitName Value="finder"/> <CursorPos X="24" Y="130"/> - <TopLine Value="99"/> - <EditorIndex Value="1"/> - <UsageCount Value="23"/> + <TopLine Value="111"/> + <EditorIndex Value="3"/> + <UsageCount Value="28"/> <Loaded Value="True"/> </Unit46> <Unit47> @@ -394,136 +392,195 @@ <Filename Value="../../Units/MMLAddon/mmlthread.pas"/> <IsPartOfProject Value="True"/> <UnitName Value="MMLThread"/> - <CursorPos X="49" Y="20"/> + <CursorPos X="132" Y="5"/> <TopLine Value="1"/> - <EditorIndex Value="9"/> - <UsageCount Value="21"/> - <Loaded Value="True"/> + <UsageCount Value="26"/> </Unit48> <Unit49> - <Filename Value="../../../../Documents/fpc/rtl/objpas/classes/classesh.inc"/> + <Filename Value="../../../Documents/fpc/rtl/objpas/classes/classesh.inc"/> <CursorPos X="27" Y="1430"/> <TopLine Value="1422"/> <UsageCount Value="10"/> </Unit49> + <Unit50> + <Filename Value="../../Units/MMLAddon/mmlpsthread.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="mmlpsthread"/> + <CursorPos X="20" Y="156"/> + <TopLine Value="150"/> + <EditorIndex Value="8"/> + <UsageCount Value="24"/> + <Loaded Value="True"/> + </Unit50> + <Unit51> + <Filename Value="../../Units/PascalScript/uPSComponent.pas"/> + <UnitName Value="uPSComponent"/> + <CursorPos X="21" Y="193"/> + <TopLine Value="183"/> + <EditorIndex Value="13"/> + <UsageCount Value="13"/> + <Loaded Value="True"/> + </Unit51> + <Unit52> + <Filename Value="../../../FPC/FPCCheckout/rtl/objpas/classes/classesh.inc"/> + <CursorPos X="94" Y="494"/> + <TopLine Value="489"/> + <EditorIndex Value="12"/> + <UsageCount Value="13"/> + <Loaded Value="True"/> + </Unit52> + <Unit53> + <Filename Value="../../../FPC/FPCCheckout/rtl/objpas/types.pp"/> + <UnitName Value="types"/> + <CursorPos X="1" Y="1"/> + <TopLine Value="1"/> + <EditorIndex Value="11"/> + <UsageCount Value="12"/> + <Loaded Value="True"/> + </Unit53> + <Unit54> + <Filename Value="../../../FPC/FPCCheckout/rtl/objpas/typinfo.pp"/> + <UnitName Value="typinfo"/> + <CursorPos X="1" Y="1"/> + <TopLine Value="1"/> + <EditorIndex Value="10"/> + <UsageCount Value="12"/> + <Loaded Value="True"/> + </Unit54> + <Unit55> + <Filename Value="../../Units/PascalScript/uPSC_forms.pas"/> + <UnitName Value="uPSC_forms"/> + <CursorPos X="1" Y="1"/> + <TopLine Value="1"/> + <EditorIndex Value="9"/> + <UsageCount Value="12"/> + <Loaded Value="True"/> + </Unit55> + <Unit56> + <Filename Value="project1.lrs"/> + <CursorPos X="20" Y="1"/> + <TopLine Value="1"/> + <EditorIndex Value="1"/> + <UsageCount Value="12"/> + <Loaded Value="True"/> + </Unit56> + <Unit57> + <Filename Value="../../../lazarus/lcl/lresources.pp"/> + <UnitName Value="LResources"/> + <CursorPos X="3" Y="1396"/> + <TopLine Value="1396"/> + <EditorIndex Value="2"/> + <UsageCount Value="12"/> + <Loaded Value="True"/> + </Unit57> + <Unit58> + <Filename Value="../../../lazarus/components/synedit/synmemo.pas"/> + <UnitName Value="SynMemo"/> + <CursorPos X="16" Y="150"/> + <TopLine Value="31"/> + <UsageCount Value="10"/> + </Unit58> + <Unit59> + <Filename Value="../../../lazarus/components/synedit/syneditmiscclasses.pp"/> + <UnitName Value="SynEditMiscClasses"/> + <CursorPos X="29" Y="100"/> + <TopLine Value="92"/> + <UsageCount Value="10"/> + </Unit59> + <Unit60> + <Filename Value="../../../lazarus/components/synedit/synedit.pp"/> + <UnitName Value="SynEdit"/> + <CursorPos X="22" Y="1531"/> + <TopLine Value="1523"/> + <UsageCount Value="10"/> + </Unit60> + <Unit61> + <Filename Value="../../../lazarus/components/synedit/syngutterchanges.pas"/> + <UnitName Value="SynGutterChanges"/> + <CursorPos X="34" Y="126"/> + <TopLine Value="118"/> + <UsageCount Value="10"/> + </Unit61> + <Unit62> + <Filename Value="../../../lazarus/components/synedit/syneditlines.pas"/> + <UnitName Value="SynEditLines"/> + <CursorPos X="21" Y="48"/> + <TopLine Value="40"/> + <UsageCount Value="10"/> + </Unit62> + <Unit63> + <Filename Value="../../../lazarus/components/synedit/synedittextbase.pas"/> + <UnitName Value="SynEditTextBase"/> + <CursorPos X="3" Y="75"/> + <TopLine Value="124"/> + <UsageCount Value="10"/> + </Unit63> </Units> - <JumpHistory Count="29" HistoryIndex="28"> + <JumpHistory Count="16" HistoryIndex="15"> <Position1> - <Filename Value="../../Units/MMLCore/windowutil.pas"/> - <Caret Line="34" Column="34" TopLine="24"/> + <Filename Value="testunit.pas"/> + <Caret Line="274" Column="26" TopLine="258"/> </Position1> <Position2> - <Filename Value="../../Units/MMLCore/files.pas"/> - <Caret Line="1" Column="1" TopLine="1"/> + <Filename Value="testunit.pas"/> + <Caret Line="271" Column="35" TopLine="258"/> </Position2> <Position3> - <Filename Value="../../Units/MMLCore/files.pas"/> - <Caret Line="213" Column="5" TopLine="203"/> + <Filename Value="testunit.pas"/> + <Caret Line="271" Column="14" TopLine="258"/> </Position3> <Position4> - <Filename Value="../../Units/MMLCore/input.pas"/> - <Caret Line="1" Column="1" TopLine="1"/> + <Filename Value="testunit.pas"/> + <Caret Line="271" Column="19" TopLine="258"/> </Position4> <Position5> - <Filename Value="../../Units/MMLCore/client.pas"/> - <Caret Line="8" Column="53" TopLine="1"/> + <Filename Value="testunit.pas"/> + <Caret Line="22" Column="47" TopLine="22"/> </Position5> <Position6> - <Filename Value="../../Units/MMLCore/finder.pas"/> - <Caret Line="35" Column="5" TopLine="31"/> + <Filename Value="../../Units/MMLAddon/mmlpsthread.pas"/> + <Caret Line="30" Column="45" TopLine="22"/> </Position6> <Position7> - <Filename Value="../../Units/MMLCore/finder.pas"/> - <Caret Line="92" Column="48" TopLine="75"/> + <Filename Value="../../Units/MMLAddon/mmlpsthread.pas"/> + <Caret Line="8" Column="73" TopLine="22"/> </Position7> <Position8> - <Filename Value="../../Units/MMLCore/finder.pas"/> - <Caret Line="84" Column="12" TopLine="64"/> + <Filename Value="../../Units/MMLAddon/mmlpsthread.pas"/> + <Caret Line="30" Column="45" TopLine="22"/> </Position8> <Position9> - <Filename Value="testunit.pas"/> - <Caret Line="84" Column="18" TopLine="69"/> + <Filename Value="../../Units/MMLAddon/mmlpsthread.pas"/> + <Caret Line="225" Column="50" TopLine="217"/> </Position9> <Position10> - <Filename Value="testunit.pas"/> - <Caret Line="88" Column="30" TopLine="65"/> + <Filename Value="../../Units/MMLAddon/mmlpsthread.pas"/> + <Caret Line="227" Column="5" TopLine="219"/> </Position10> <Position11> - <Filename Value="testunit.pas"/> - <Caret Line="87" Column="16" TopLine="69"/> + <Filename Value="../../Units/MMLAddon/mmlpsthread.pas"/> + <Caret Line="53" Column="19" TopLine="40"/> </Position11> <Position12> <Filename Value="testunit.pas"/> - <Caret Line="90" Column="41" TopLine="75"/> + <Caret Line="279" Column="3" TopLine="270"/> </Position12> <Position13> - <Filename Value="../../Units/MMLCore/input.pas"/> - <Caret Line="201" Column="18" TopLine="1"/> + <Filename Value="testunit.pas"/> + <Caret Line="271" Column="19" TopLine="259"/> </Position13> <Position14> - <Filename Value="../../Units/MMLCore/input.pas"/> - <Caret Line="209" Column="34" TopLine="195"/> + <Filename Value="../../Units/MMLAddon/mmlpsthread.pas"/> + <Caret Line="65" Column="26" TopLine="22"/> </Position14> <Position15> - <Filename Value="../../Units/MMLCore/input.pas"/> - <Caret Line="215" Column="65" TopLine="193"/> + <Filename Value="../../Units/MMLAddon/mmlpsthread.pas"/> + <Caret Line="49" Column="15" TopLine="21"/> </Position15> <Position16> - <Filename Value="../../Units/MMLCore/input.pas"/> - <Caret Line="202" Column="41" TopLine="182"/> + <Filename Value="../../Units/MMLAddon/mmlpsthread.pas"/> + <Caret Line="55" Column="16" TopLine="26"/> </Position16> - <Position17> - <Filename Value="../../Units/MMLCore/input.pas"/> - <Caret Line="203" Column="39" TopLine="183"/> - </Position17> - <Position18> - <Filename Value="../../Units/MMLCore/input.pas"/> - <Caret Line="202" Column="39" TopLine="183"/> - </Position18> - <Position19> - <Filename Value="../../Units/MMLCore/input.pas"/> - <Caret Line="188" Column="63" TopLine="172"/> - </Position19> - <Position20> - <Filename Value="../../Units/MMLAddon/mmlthread.pas"/> - <Caret Line="31" Column="21" TopLine="7"/> - </Position20> - <Position21> - <Filename Value="../../Units/MMLAddon/mmlthread.pas"/> - <Caret Line="34" Column="6" TopLine="12"/> - </Position21> - <Position22> - <Filename Value="../../Units/MMLAddon/mmlthread.pas"/> - <Caret Line="40" Column="12" TopLine="13"/> - </Position22> - <Position23> - <Filename Value="../../Units/MMLAddon/mmlthread.pas"/> - <Caret Line="36" Column="38" TopLine="14"/> - </Position23> - <Position24> - <Filename Value="../../Units/MMLAddon/mmlthread.pas"/> - <Caret Line="42" Column="5" TopLine="14"/> - </Position24> - <Position25> - <Filename Value="../../Units/MMLAddon/mmlthread.pas"/> - <Caret Line="41" Column="38" TopLine="18"/> - </Position25> - <Position26> - <Filename Value="../../Units/MMLAddon/mmlthread.pas"/> - <Caret Line="42" Column="47" TopLine="20"/> - </Position26> - <Position27> - <Filename Value="../../Units/MMLAddon/mmlthread.pas"/> - <Caret Line="29" Column="12" TopLine="12"/> - </Position27> - <Position28> - <Filename Value="testunit.pas"/> - <Caret Line="250" Column="18" TopLine="57"/> - </Position28> - <Position29> - <Filename Value="testunit.pas"/> - <Caret Line="263" Column="20" TopLine="239"/> - </Position29> </JumpHistory> </ProjectOptions> <CompilerOptions> @@ -533,7 +590,7 @@ </Target> <SearchPaths> <IncludeFiles Value="$(ProjOutDir)/"/> - <OtherUnitFiles Value="$(ProjPath)../../Units/MMLCore/;/home/merlijn/Programs/mufasa/Units/MMLAddon/"/> + <OtherUnitFiles Value="$(ProjPath)../../Units/MMLCore/;$(ProjPath)../../Units/MMLAddon/;$(ProjPath)../../Units/PascalScript/"/> </SearchPaths> <CodeGeneration> <Optimizations> diff --git a/Projects/SAMufasaGUI/project1.lpr b/Projects/SAMufasaGUI/project1.lpr index 217e502..3d596a9 100644 --- a/Projects/SAMufasaGUI/project1.lpr +++ b/Projects/SAMufasaGUI/project1.lpr @@ -8,7 +8,7 @@ uses {$ENDIF}{$ENDIF} Interfaces, // this includes the LCL widgetset Forms, LResources, Window, files, MufasaTypes, Client, TestUnit, finder, - MMLThread; + MMLThread, mmlpsthread; {$IFDEF WINDOWS}{$R project1.rc}{$ENDIF} @@ -16,6 +16,7 @@ begin Application.Title:='Mufasa Stand Alone'; {$I project1.lrs} Application.Initialize; + Application.CreateForm(TForm1, Form1); Application.Run; end. diff --git a/Projects/SAMufasaGUI/testunit.lfm b/Projects/SAMufasaGUI/testunit.lfm index c7d2ccd..ac1f496 100644 --- a/Projects/SAMufasaGUI/testunit.lfm +++ b/Projects/SAMufasaGUI/testunit.lfm @@ -14,8 +14,1404 @@ object Form1: TForm1 Height = 25 Top = 16 Width = 75 - Caption = 'Button1' + Caption = 'Run' OnClick = Button1Click TabOrder = 0 end + object SynEdit1: TSynEdit + Left = 8 + Height = 296 + Top = 64 + Width = 728 + Align = alCustom + Font.Height = -13 + Font.Name = 'Courier New' + Font.Pitch = fpFixed + Font.Quality = fqNonAntialiased + ParentColor = False + ParentFont = False + TabOrder = 1 + Gutter.Width = 57 + Gutter.MouseActions = < + item + Shift = [] + ShiftMask = [] + Button = mbLeft + ClickCount = ccAny + ClickDir = cdDown + Command = 13 + MoveCaret = False + Option = 0 + Priority = 0 + end + item + Shift = [] + ShiftMask = [] + Button = mbRight + ClickCount = ccSingle + ClickDir = cdUp + Command = 12 + MoveCaret = False + Option = 0 + Priority = 0 + end> + Highlighter = SynFreePascalSyn1 + Keystrokes = < + item + Command = ecUp + ShortCut = 38 + end + item + Command = ecSelUp + ShortCut = 8230 + end + item + Command = ecScrollUp + ShortCut = 16422 + end + item + Command = ecDown + ShortCut = 40 + end + item + Command = ecSelDown + ShortCut = 8232 + end + item + Command = ecScrollDown + ShortCut = 16424 + end + item + Command = ecLeft + ShortCut = 37 + end + item + Command = ecSelLeft + ShortCut = 8229 + end + item + Command = ecWordLeft + ShortCut = 16421 + end + item + Command = ecSelWordLeft + ShortCut = 24613 + end + item + Command = ecRight + ShortCut = 39 + end + item + Command = ecSelRight + ShortCut = 8231 + end + item + Command = ecWordRight + ShortCut = 16423 + end + item + Command = ecSelWordRight + ShortCut = 24615 + end + item + Command = ecPageDown + ShortCut = 34 + end + item + Command = ecSelPageDown + ShortCut = 8226 + end + item + Command = ecPageBottom + ShortCut = 16418 + end + item + Command = ecSelPageBottom + ShortCut = 24610 + end + item + Command = ecPageUp + ShortCut = 33 + end + item + Command = ecSelPageUp + ShortCut = 8225 + end + item + Command = ecPageTop + ShortCut = 16417 + end + item + Command = ecSelPageTop + ShortCut = 24609 + end + item + Command = ecLineStart + ShortCut = 36 + end + item + Command = ecSelLineStart + ShortCut = 8228 + end + item + Command = ecEditorTop + ShortCut = 16420 + end + item + Command = ecSelEditorTop + ShortCut = 24612 + end + item + Command = ecLineEnd + ShortCut = 35 + end + item + Command = ecSelLineEnd + ShortCut = 8227 + end + item + Command = ecEditorBottom + ShortCut = 16419 + end + item + Command = ecSelEditorBottom + ShortCut = 24611 + end + item + Command = ecToggleMode + ShortCut = 45 + end + item + Command = ecCopy + ShortCut = 16429 + end + item + Command = ecPaste + ShortCut = 8237 + end + item + Command = ecDeleteChar + ShortCut = 46 + end + item + Command = ecCut + ShortCut = 8238 + end + item + Command = ecDeleteLastChar + ShortCut = 8 + end + item + Command = ecDeleteLastChar + ShortCut = 8200 + end + item + Command = ecDeleteLastWord + ShortCut = 16392 + end + item + Command = ecUndo + ShortCut = 32776 + end + item + Command = ecRedo + ShortCut = 40968 + end + item + Command = ecLineBreak + ShortCut = 13 + end + item + Command = ecSelectAll + ShortCut = 16449 + end + item + Command = ecCopy + ShortCut = 16451 + end + item + Command = ecBlockIndent + ShortCut = 24649 + end + item + Command = ecLineBreak + ShortCut = 16461 + end + item + Command = ecInsertLine + ShortCut = 16462 + end + item + Command = ecDeleteWord + ShortCut = 16468 + end + item + Command = ecBlockUnindent + ShortCut = 24661 + end + item + Command = ecPaste + ShortCut = 16470 + end + item + Command = ecCut + ShortCut = 16472 + end + item + Command = ecDeleteLine + ShortCut = 16473 + end + item + Command = ecDeleteEOL + ShortCut = 24665 + end + item + Command = ecUndo + ShortCut = 16474 + end + item + Command = ecRedo + ShortCut = 24666 + end + item + Command = ecGotoMarker0 + ShortCut = 16432 + end + item + Command = ecGotoMarker1 + ShortCut = 16433 + end + item + Command = ecGotoMarker2 + ShortCut = 16434 + end + item + Command = ecGotoMarker3 + ShortCut = 16435 + end + item + Command = ecGotoMarker4 + ShortCut = 16436 + end + item + Command = ecGotoMarker5 + ShortCut = 16437 + end + item + Command = ecGotoMarker6 + ShortCut = 16438 + end + item + Command = ecGotoMarker7 + ShortCut = 16439 + end + item + Command = ecGotoMarker8 + ShortCut = 16440 + end + item + Command = ecGotoMarker9 + ShortCut = 16441 + end + item + Command = ecSetMarker0 + ShortCut = 24624 + end + item + Command = ecSetMarker1 + ShortCut = 24625 + end + item + Command = ecSetMarker2 + ShortCut = 24626 + end + item + Command = ecSetMarker3 + ShortCut = 24627 + end + item + Command = ecSetMarker4 + ShortCut = 24628 + end + item + Command = ecSetMarker5 + ShortCut = 24629 + end + item + Command = ecSetMarker6 + ShortCut = 24630 + end + item + Command = ecSetMarker7 + ShortCut = 24631 + end + item + Command = ecSetMarker8 + ShortCut = 24632 + end + item + Command = ecSetMarker9 + ShortCut = 24633 + end + item + Command = EcFoldLevel1 + ShortCut = 41009 + end + item + Command = EcFoldLevel2 + ShortCut = 41010 + end + item + Command = EcFoldLevel1 + ShortCut = 41011 + end + item + Command = EcFoldLevel1 + ShortCut = 41012 + end + item + Command = EcFoldLevel1 + ShortCut = 41013 + end + item + Command = EcFoldLevel6 + ShortCut = 41014 + end + item + Command = EcFoldLevel7 + ShortCut = 41015 + end + item + Command = EcFoldLevel8 + ShortCut = 41016 + end + item + Command = EcFoldLevel9 + ShortCut = 41017 + end + item + Command = EcFoldLevel0 + ShortCut = 41008 + end + item + Command = EcFoldCurrent + ShortCut = 41005 + end + item + Command = EcUnFoldCurrent + ShortCut = 41003 + end + item + Command = EcToggleMarkupWord + ShortCut = 32845 + end + item + Command = ecNormalSelect + ShortCut = 24654 + end + item + Command = ecColumnSelect + ShortCut = 24643 + end + item + Command = ecLineSelect + ShortCut = 24652 + end + item + Command = ecTab + ShortCut = 9 + end + item + Command = ecShiftTab + ShortCut = 8201 + end + item + Command = ecMatchBracket + ShortCut = 24642 + end + item + Command = ecColSelUp + ShortCut = 40998 + end + item + Command = ecColSelDown + ShortCut = 41000 + end + item + Command = ecColSelLeft + ShortCut = 40997 + end + item + Command = ecColSelRight + ShortCut = 40999 + end + item + Command = ecColSelPageDown + ShortCut = 40994 + end + item + Command = ecColSelPageBottom + ShortCut = 57378 + end + item + Command = ecColSelPageUp + ShortCut = 40993 + end + item + Command = ecColSelPageTop + ShortCut = 57377 + end + item + Command = ecColSelLineStart + ShortCut = 40996 + end + item + Command = ecColSelLineEnd + ShortCut = 40995 + end + item + Command = ecColSelEditorTop + ShortCut = 57380 + end + item + Command = ecColSelEditorBottom + ShortCut = 57379 + end> + MouseActions = < + item + Shift = [] + ShiftMask = [ssShift, ssAlt] + Button = mbLeft + ClickCount = ccSingle + ClickDir = cdDown + Command = 1 + MoveCaret = True + Option = 0 + Priority = 0 + end + item + Shift = [ssShift] + ShiftMask = [ssShift, ssAlt] + Button = mbLeft + ClickCount = ccSingle + ClickDir = cdDown + Command = 1 + MoveCaret = True + Option = 1 + Priority = 0 + end + item + Shift = [ssAlt] + ShiftMask = [ssShift, ssAlt] + Button = mbLeft + ClickCount = ccSingle + ClickDir = cdDown + Command = 3 + MoveCaret = True + Option = 0 + Priority = 0 + end + item + Shift = [ssShift, ssAlt] + ShiftMask = [ssShift, ssAlt] + Button = mbLeft + ClickCount = ccSingle + ClickDir = cdDown + Command = 3 + MoveCaret = True + Option = 1 + Priority = 0 + end + item + Shift = [] + ShiftMask = [] + Button = mbRight + ClickCount = ccSingle + ClickDir = cdUp + Command = 12 + MoveCaret = False + Option = 0 + Priority = 0 + end + item + Shift = [] + ShiftMask = [] + Button = mbLeft + ClickCount = ccDouble + ClickDir = cdDown + Command = 6 + MoveCaret = True + Option = 0 + Priority = 0 + end + item + Shift = [] + ShiftMask = [] + Button = mbLeft + ClickCount = ccTriple + ClickDir = cdDown + Command = 7 + MoveCaret = True + Option = 0 + Priority = 0 + end + item + Shift = [] + ShiftMask = [] + Button = mbLeft + ClickCount = ccQuad + ClickDir = cdDown + Command = 8 + MoveCaret = True + Option = 0 + Priority = 0 + end + item + Shift = [] + ShiftMask = [] + Button = mbMiddle + ClickCount = ccSingle + ClickDir = cdDown + Command = 10 + MoveCaret = True + Option = 0 + Priority = 0 + end + item + Shift = [ssCtrl] + ShiftMask = [ssShift, ssAlt, ssCtrl] + Button = mbLeft + ClickCount = ccSingle + ClickDir = cdUp + Command = 11 + MoveCaret = False + Option = 0 + Priority = 0 + end> + MouseSelActions = < + item + Shift = [] + ShiftMask = [] + Button = mbLeft + ClickCount = ccSingle + ClickDir = cdDown + Command = 9 + MoveCaret = False + Option = 0 + Priority = 0 + end> + Lines.Strings = ( + 'program new;' + 'begin' + 'end.' + ) + BracketHighlightStyle = sbhsBoth + object TSynGutterPartList + object TSynGutterMarks + Width = 23 + end + object TSynGutterLineNumber + Width = 17 + MouseActions = <> + MarkupInfo.Background = clBtnFace + MarkupInfo.Foreground = clNone + DigitCount = 2 + ShowOnlyLineNumbersMultiplesOf = 1 + ZeroStart = False + LeadingZeros = False + end + object TSynGutterChanges + Width = 4 + ModifiedColor = 59900 + SavedColor = clGreen + end + object TSynGutterSeparator + Width = 2 + end + object TSynGutterCodeFolding + MouseActions = < + item + Shift = [] + ShiftMask = [] + Button = mbRight + ClickCount = ccSingle + ClickDir = cdUp + Command = 16 + MoveCaret = False + Option = 0 + Priority = 0 + end + item + Shift = [] + ShiftMask = [ssShift] + Button = mbMiddle + ClickCount = ccAny + ClickDir = cdDown + Command = 14 + MoveCaret = False + Option = 0 + Priority = 0 + end + item + Shift = [ssShift] + ShiftMask = [ssShift] + Button = mbMiddle + ClickCount = ccAny + ClickDir = cdDown + Command = 14 + MoveCaret = False + Option = 1 + Priority = 0 + end + item + Shift = [] + ShiftMask = [] + Button = mbLeft + ClickCount = ccAny + ClickDir = cdDown + Command = 0 + MoveCaret = False + Option = 0 + Priority = 0 + end> + MarkupInfo.Background = clNone + MarkupInfo.Foreground = clGray + MouseActionsExpanded = < + item + Shift = [] + ShiftMask = [] + Button = mbLeft + ClickCount = ccAny + ClickDir = cdDown + Command = 14 + MoveCaret = False + Option = 0 + Priority = 0 + end> + MouseActionsCollapsed = < + item + Shift = [ssCtrl] + ShiftMask = [ssCtrl] + Button = mbLeft + ClickCount = ccAny + ClickDir = cdDown + Command = 15 + MoveCaret = False + Option = 0 + Priority = 0 + end + item + Shift = [] + ShiftMask = [ssCtrl] + Button = mbLeft + ClickCount = ccAny + ClickDir = cdDown + Command = 15 + MoveCaret = False + Option = 1 + Priority = 0 + end> + end + end + end + object SynMemo1: TSynMemo + Cursor = crIBeam + Left = 20 + Height = 125 + Top = 387 + Width = 654 + Font.Height = -13 + Font.Name = 'Courier New' + Font.Pitch = fpFixed + Font.Quality = fqNonAntialiased + ParentColor = False + ParentFont = False + TabOrder = 2 + Gutter.Width = 57 + Gutter.MouseActions = < + item + Shift = [] + ShiftMask = [] + Button = mbLeft + ClickCount = ccAny + ClickDir = cdDown + Command = 13 + MoveCaret = False + Option = 0 + Priority = 0 + end + item + Shift = [] + ShiftMask = [] + Button = mbRight + ClickCount = ccSingle + ClickDir = cdUp + Command = 12 + MoveCaret = False + Option = 0 + Priority = 0 + end> + Keystrokes = < + item + Command = ecUp + ShortCut = 38 + end + item + Command = ecSelUp + ShortCut = 8230 + end + item + Command = ecScrollUp + ShortCut = 16422 + end + item + Command = ecDown + ShortCut = 40 + end + item + Command = ecSelDown + ShortCut = 8232 + end + item + Command = ecScrollDown + ShortCut = 16424 + end + item + Command = ecLeft + ShortCut = 37 + end + item + Command = ecSelLeft + ShortCut = 8229 + end + item + Command = ecWordLeft + ShortCut = 16421 + end + item + Command = ecSelWordLeft + ShortCut = 24613 + end + item + Command = ecRight + ShortCut = 39 + end + item + Command = ecSelRight + ShortCut = 8231 + end + item + Command = ecWordRight + ShortCut = 16423 + end + item + Command = ecSelWordRight + ShortCut = 24615 + end + item + Command = ecPageDown + ShortCut = 34 + end + item + Command = ecSelPageDown + ShortCut = 8226 + end + item + Command = ecPageBottom + ShortCut = 16418 + end + item + Command = ecSelPageBottom + ShortCut = 24610 + end + item + Command = ecPageUp + ShortCut = 33 + end + item + Command = ecSelPageUp + ShortCut = 8225 + end + item + Command = ecPageTop + ShortCut = 16417 + end + item + Command = ecSelPageTop + ShortCut = 24609 + end + item + Command = ecLineStart + ShortCut = 36 + end + item + Command = ecSelLineStart + ShortCut = 8228 + end + item + Command = ecEditorTop + ShortCut = 16420 + end + item + Command = ecSelEditorTop + ShortCut = 24612 + end + item + Command = ecLineEnd + ShortCut = 35 + end + item + Command = ecSelLineEnd + ShortCut = 8227 + end + item + Command = ecEditorBottom + ShortCut = 16419 + end + item + Command = ecSelEditorBottom + ShortCut = 24611 + end + item + Command = ecToggleMode + ShortCut = 45 + end + item + Command = ecCopy + ShortCut = 16429 + end + item + Command = ecPaste + ShortCut = 8237 + end + item + Command = ecDeleteChar + ShortCut = 46 + end + item + Command = ecCut + ShortCut = 8238 + end + item + Command = ecDeleteLastChar + ShortCut = 8 + end + item + Command = ecDeleteLastChar + ShortCut = 8200 + end + item + Command = ecDeleteLastWord + ShortCut = 16392 + end + item + Command = ecUndo + ShortCut = 32776 + end + item + Command = ecRedo + ShortCut = 40968 + end + item + Command = ecLineBreak + ShortCut = 13 + end + item + Command = ecSelectAll + ShortCut = 16449 + end + item + Command = ecCopy + ShortCut = 16451 + end + item + Command = ecBlockIndent + ShortCut = 24649 + end + item + Command = ecLineBreak + ShortCut = 16461 + end + item + Command = ecInsertLine + ShortCut = 16462 + end + item + Command = ecDeleteWord + ShortCut = 16468 + end + item + Command = ecBlockUnindent + ShortCut = 24661 + end + item + Command = ecPaste + ShortCut = 16470 + end + item + Command = ecCut + ShortCut = 16472 + end + item + Command = ecDeleteLine + ShortCut = 16473 + end + item + Command = ecDeleteEOL + ShortCut = 24665 + end + item + Command = ecUndo + ShortCut = 16474 + end + item + Command = ecRedo + ShortCut = 24666 + end + item + Command = ecGotoMarker0 + ShortCut = 16432 + end + item + Command = ecGotoMarker1 + ShortCut = 16433 + end + item + Command = ecGotoMarker2 + ShortCut = 16434 + end + item + Command = ecGotoMarker3 + ShortCut = 16435 + end + item + Command = ecGotoMarker4 + ShortCut = 16436 + end + item + Command = ecGotoMarker5 + ShortCut = 16437 + end + item + Command = ecGotoMarker6 + ShortCut = 16438 + end + item + Command = ecGotoMarker7 + ShortCut = 16439 + end + item + Command = ecGotoMarker8 + ShortCut = 16440 + end + item + Command = ecGotoMarker9 + ShortCut = 16441 + end + item + Command = ecSetMarker0 + ShortCut = 24624 + end + item + Command = ecSetMarker1 + ShortCut = 24625 + end + item + Command = ecSetMarker2 + ShortCut = 24626 + end + item + Command = ecSetMarker3 + ShortCut = 24627 + end + item + Command = ecSetMarker4 + ShortCut = 24628 + end + item + Command = ecSetMarker5 + ShortCut = 24629 + end + item + Command = ecSetMarker6 + ShortCut = 24630 + end + item + Command = ecSetMarker7 + ShortCut = 24631 + end + item + Command = ecSetMarker8 + ShortCut = 24632 + end + item + Command = ecSetMarker9 + ShortCut = 24633 + end + item + Command = EcFoldLevel1 + ShortCut = 41009 + end + item + Command = EcFoldLevel2 + ShortCut = 41010 + end + item + Command = EcFoldLevel1 + ShortCut = 41011 + end + item + Command = EcFoldLevel1 + ShortCut = 41012 + end + item + Command = EcFoldLevel1 + ShortCut = 41013 + end + item + Command = EcFoldLevel6 + ShortCut = 41014 + end + item + Command = EcFoldLevel7 + ShortCut = 41015 + end + item + Command = EcFoldLevel8 + ShortCut = 41016 + end + item + Command = EcFoldLevel9 + ShortCut = 41017 + end + item + Command = EcFoldLevel0 + ShortCut = 41008 + end + item + Command = EcFoldCurrent + ShortCut = 41005 + end + item + Command = EcUnFoldCurrent + ShortCut = 41003 + end + item + Command = EcToggleMarkupWord + ShortCut = 32845 + end + item + Command = ecNormalSelect + ShortCut = 24654 + end + item + Command = ecColumnSelect + ShortCut = 24643 + end + item + Command = ecLineSelect + ShortCut = 24652 + end + item + Command = ecTab + ShortCut = 9 + end + item + Command = ecShiftTab + ShortCut = 8201 + end + item + Command = ecMatchBracket + ShortCut = 24642 + end + item + Command = ecColSelUp + ShortCut = 40998 + end + item + Command = ecColSelDown + ShortCut = 41000 + end + item + Command = ecColSelLeft + ShortCut = 40997 + end + item + Command = ecColSelRight + ShortCut = 40999 + end + item + Command = ecColSelPageDown + ShortCut = 40994 + end + item + Command = ecColSelPageBottom + ShortCut = 57378 + end + item + Command = ecColSelPageUp + ShortCut = 40993 + end + item + Command = ecColSelPageTop + ShortCut = 57377 + end + item + Command = ecColSelLineStart + ShortCut = 40996 + end + item + Command = ecColSelLineEnd + ShortCut = 40995 + end + item + Command = ecColSelEditorTop + ShortCut = 57380 + end + item + Command = ecColSelEditorBottom + ShortCut = 57379 + end> + MouseActions = < + item + Shift = [] + ShiftMask = [ssShift, ssAlt] + Button = mbLeft + ClickCount = ccSingle + ClickDir = cdDown + Command = 1 + MoveCaret = True + Option = 0 + Priority = 0 + end + item + Shift = [ssShift] + ShiftMask = [ssShift, ssAlt] + Button = mbLeft + ClickCount = ccSingle + ClickDir = cdDown + Command = 1 + MoveCaret = True + Option = 1 + Priority = 0 + end + item + Shift = [ssAlt] + ShiftMask = [ssShift, ssAlt] + Button = mbLeft + ClickCount = ccSingle + ClickDir = cdDown + Command = 3 + MoveCaret = True + Option = 0 + Priority = 0 + end + item + Shift = [ssShift, ssAlt] + ShiftMask = [ssShift, ssAlt] + Button = mbLeft + ClickCount = ccSingle + ClickDir = cdDown + Command = 3 + MoveCaret = True + Option = 1 + Priority = 0 + end + item + Shift = [] + ShiftMask = [] + Button = mbRight + ClickCount = ccSingle + ClickDir = cdUp + Command = 12 + MoveCaret = False + Option = 0 + Priority = 0 + end + item + Shift = [] + ShiftMask = [] + Button = mbLeft + ClickCount = ccDouble + ClickDir = cdDown + Command = 6 + MoveCaret = True + Option = 0 + Priority = 0 + end + item + Shift = [] + ShiftMask = [] + Button = mbLeft + ClickCount = ccTriple + ClickDir = cdDown + Command = 7 + MoveCaret = True + Option = 0 + Priority = 0 + end + item + Shift = [] + ShiftMask = [] + Button = mbLeft + ClickCount = ccQuad + ClickDir = cdDown + Command = 8 + MoveCaret = True + Option = 0 + Priority = 0 + end + item + Shift = [] + ShiftMask = [] + Button = mbMiddle + ClickCount = ccSingle + ClickDir = cdDown + Command = 10 + MoveCaret = True + Option = 0 + Priority = 0 + end + item + Shift = [ssCtrl] + ShiftMask = [ssShift, ssAlt, ssCtrl] + Button = mbLeft + ClickCount = ccSingle + ClickDir = cdUp + Command = 11 + MoveCaret = False + Option = 0 + Priority = 0 + end> + MouseSelActions = < + item + Shift = [] + ShiftMask = [] + Button = mbLeft + ClickCount = ccSingle + ClickDir = cdDown + Command = 9 + MoveCaret = False + Option = 0 + Priority = 0 + end> + Lines.Strings = ( + 'SynMemo1' + ) + OnChange = SynMemo1Change + object TSynGutterPartList + object TSynGutterMarks + Width = 23 + end + object TSynGutterLineNumber + Width = 17 + MouseActions = <> + MarkupInfo.Background = clBtnFace + MarkupInfo.Foreground = clNone + DigitCount = 2 + ShowOnlyLineNumbersMultiplesOf = 1 + ZeroStart = False + LeadingZeros = False + end + object TSynGutterChanges + Width = 4 + ModifiedColor = 59900 + SavedColor = clGreen + end + object TSynGutterSeparator + Width = 2 + end + object TSynGutterCodeFolding + MouseActions = < + item + Shift = [] + ShiftMask = [] + Button = mbRight + ClickCount = ccSingle + ClickDir = cdUp + Command = 16 + MoveCaret = False + Option = 0 + Priority = 0 + end + item + Shift = [] + ShiftMask = [ssShift] + Button = mbMiddle + ClickCount = ccAny + ClickDir = cdDown + Command = 14 + MoveCaret = False + Option = 0 + Priority = 0 + end + item + Shift = [ssShift] + ShiftMask = [ssShift] + Button = mbMiddle + ClickCount = ccAny + ClickDir = cdDown + Command = 14 + MoveCaret = False + Option = 1 + Priority = 0 + end + item + Shift = [] + ShiftMask = [] + Button = mbLeft + ClickCount = ccAny + ClickDir = cdDown + Command = 0 + MoveCaret = False + Option = 0 + Priority = 0 + end> + MarkupInfo.Background = clNone + MarkupInfo.Foreground = clGray + MouseActionsExpanded = < + item + Shift = [] + ShiftMask = [] + Button = mbLeft + ClickCount = ccAny + ClickDir = cdDown + Command = 14 + MoveCaret = False + Option = 0 + Priority = 0 + end> + MouseActionsCollapsed = < + item + Shift = [ssCtrl] + ShiftMask = [ssCtrl] + Button = mbLeft + ClickCount = ccAny + ClickDir = cdDown + Command = 15 + MoveCaret = False + Option = 0 + Priority = 0 + end + item + Shift = [] + ShiftMask = [ssCtrl] + Button = mbLeft + ClickCount = ccAny + ClickDir = cdDown + Command = 15 + MoveCaret = False + Option = 1 + Priority = 0 + end> + end + end + end + object SynFreePascalSyn1: TSynFreePascalSyn + Enabled = False + CompilerMode = pcmObjFPC + NestedComments = True + left = 498 + top = 89 + end end diff --git a/Projects/SAMufasaGUI/testunit.lrs b/Projects/SAMufasaGUI/testunit.lrs index 0223a6d..b39f748 100644 --- a/Projects/SAMufasaGUI/testunit.lrs +++ b/Projects/SAMufasaGUI/testunit.lrs @@ -1,10 +1,286 @@ -{ This is an automatically generated lazarus resource file } - -LazarusResources.Add('TForm1','FORMDATA',[ - 'TPF0'#6'TForm1'#5'Form1'#4'Left'#3'q'#1#6'Height'#3#15#2#3'Top'#3#223#0#5'Wi' - +'dth'#3#11#3#13'ActiveControl'#7#7'Button1'#7'Caption'#6#5'Form1'#12'ClientH' - +'eight'#3#15#2#11'ClientWidth'#3#11#3#8'Position'#7#14'poScreenCenter'#10'LC' - +'LVersion'#6#6'0.9.29'#0#7'TButton'#7'Button1'#4'Left'#2#8#6'Height'#2#25#3 - +'Top'#2#16#5'Width'#2'K'#7'Caption'#6#7'Button1'#7'OnClick'#7#12'Button1Clic' - +'k'#8'TabOrder'#2#0#0#0#0 -]); +{ This is an automatically generated lazarus resource file } + +LazarusResources.Add('TForm1','FORMDATA',[ + 'TPF0'#6'TForm1'#5'Form1'#4'Left'#3'q'#1#6'Height'#3#15#2#3'Top'#3#223#0#5'Wi' + +'dth'#3#11#3#13'ActiveControl'#7#7'Button1'#7'Caption'#6#5'Form1'#12'ClientH' + +'eight'#3#15#2#11'ClientWidth'#3#11#3#8'Position'#7#14'poScreenCenter'#10'LC' + +'LVersion'#6#6'0.9.29'#0#7'TButton'#7'Button1'#4'Left'#2#8#6'Height'#2#25#3 + +'Top'#2#16#5'Width'#2'K'#7'Caption'#6#3'Run'#7'OnClick'#7#12'Button1Click'#8 + +'TabOrder'#2#0#0#0#8'TSynEdit'#8'SynEdit1'#4'Left'#2#8#6'Height'#3'('#1#3'To' + +'p'#2'@'#5'Width'#3#216#2#5'Align'#7#8'alCustom'#11'Font.Height'#2#243#9'Fon' + +'t.Name'#6#11'Courier New'#10'Font.Pitch'#7#7'fpFixed'#12'Font.Quality'#7#16 + +'fqNonAntialiased'#11'ParentColor'#8#10'ParentFont'#8#8'TabOrder'#2#1#12'Gut' + +'ter.Width'#2'9'#19'Gutter.MouseActions'#14#1#5'Shift'#11#0#9'ShiftMask'#11#0 + +#6'Button'#7#6'mbLeft'#10'ClickCount'#7#5'ccAny'#8'ClickDir'#7#6'cdDown'#7'C' + +'ommand'#2#13#9'MoveCaret'#8#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#0 + +#9'ShiftMask'#11#0#6'Button'#7#7'mbRight'#10'ClickCount'#7#8'ccSingle'#8'Cli' + +'ckDir'#7#4'cdUp'#7'Command'#2#12#9'MoveCaret'#8#6'Option'#2#0#8'Priority'#2 + +#0#0#0#11'Highlighter'#7#17'SynFreePascalSyn1'#10'Keystrokes'#14#1#7'Command' + +#7#4'ecUp'#8'ShortCut'#2'&'#0#1#7'Command'#7#7'ecSelUp'#8'ShortCut'#3'& '#0#1 + +#7'Command'#7#10'ecScrollUp'#8'ShortCut'#3'&@'#0#1#7'Command'#7#6'ecDown'#8 + +'ShortCut'#2'('#0#1#7'Command'#7#9'ecSelDown'#8'ShortCut'#3'( '#0#1#7'Comman' + +'d'#7#12'ecScrollDown'#8'ShortCut'#3'(@'#0#1#7'Command'#7#6'ecLeft'#8'ShortC' + +'ut'#2'%'#0#1#7'Command'#7#9'ecSelLeft'#8'ShortCut'#3'% '#0#1#7'Command'#7#10 + +'ecWordLeft'#8'ShortCut'#3'%@'#0#1#7'Command'#7#13'ecSelWordLeft'#8'ShortCut' + +#3'%`'#0#1#7'Command'#7#7'ecRight'#8'ShortCut'#2''''#0#1#7'Command'#7#10'ecS' + +'elRight'#8'ShortCut'#3''' '#0#1#7'Command'#7#11'ecWordRight'#8'ShortCut'#3 + +'''@'#0#1#7'Command'#7#14'ecSelWordRight'#8'ShortCut'#3'''`'#0#1#7'Command'#7 + +#10'ecPageDown'#8'ShortCut'#2'"'#0#1#7'Command'#7#13'ecSelPageDown'#8'ShortC' + +'ut'#3'" '#0#1#7'Command'#7#12'ecPageBottom'#8'ShortCut'#3'"@'#0#1#7'Command' + +#7#15'ecSelPageBottom'#8'ShortCut'#3'"`'#0#1#7'Command'#7#8'ecPageUp'#8'Shor' + +'tCut'#2'!'#0#1#7'Command'#7#11'ecSelPageUp'#8'ShortCut'#3'! '#0#1#7'Command' + +#7#9'ecPageTop'#8'ShortCut'#3'!@'#0#1#7'Command'#7#12'ecSelPageTop'#8'ShortC' + +'ut'#3'!`'#0#1#7'Command'#7#11'ecLineStart'#8'ShortCut'#2'$'#0#1#7'Command'#7 + +#14'ecSelLineStart'#8'ShortCut'#3'$ '#0#1#7'Command'#7#11'ecEditorTop'#8'Sho' + +'rtCut'#3'$@'#0#1#7'Command'#7#14'ecSelEditorTop'#8'ShortCut'#3'$`'#0#1#7'Co' + +'mmand'#7#9'ecLineEnd'#8'ShortCut'#2'#'#0#1#7'Command'#7#12'ecSelLineEnd'#8 + +'ShortCut'#3'# '#0#1#7'Command'#7#14'ecEditorBottom'#8'ShortCut'#3'#@'#0#1#7 + +'Command'#7#17'ecSelEditorBottom'#8'ShortCut'#3'#`'#0#1#7'Command'#7#12'ecTo' + +'ggleMode'#8'ShortCut'#2'-'#0#1#7'Command'#7#6'ecCopy'#8'ShortCut'#3'-@'#0#1 + +#7'Command'#7#7'ecPaste'#8'ShortCut'#3'- '#0#1#7'Command'#7#12'ecDeleteChar' + +#8'ShortCut'#2'.'#0#1#7'Command'#7#5'ecCut'#8'ShortCut'#3'. '#0#1#7'Command' + +#7#16'ecDeleteLastChar'#8'ShortCut'#2#8#0#1#7'Command'#7#16'ecDeleteLastChar' + +#8'ShortCut'#3#8' '#0#1#7'Command'#7#16'ecDeleteLastWord'#8'ShortCut'#3#8'@' + +#0#1#7'Command'#7#6'ecUndo'#8'ShortCut'#4#8#128#0#0#0#1#7'Command'#7#6'ecRed' + +'o'#8'ShortCut'#4#8#160#0#0#0#1#7'Command'#7#11'ecLineBreak'#8'ShortCut'#2#13 + +#0#1#7'Command'#7#11'ecSelectAll'#8'ShortCut'#3'A@'#0#1#7'Command'#7#6'ecCop' + +'y'#8'ShortCut'#3'C@'#0#1#7'Command'#7#13'ecBlockIndent'#8'ShortCut'#3'I`'#0 + +#1#7'Command'#7#11'ecLineBreak'#8'ShortCut'#3'M@'#0#1#7'Command'#7#12'ecInse' + +'rtLine'#8'ShortCut'#3'N@'#0#1#7'Command'#7#12'ecDeleteWord'#8'ShortCut'#3'T' + +'@'#0#1#7'Command'#7#15'ecBlockUnindent'#8'ShortCut'#3'U`'#0#1#7'Command'#7#7 + +'ecPaste'#8'ShortCut'#3'V@'#0#1#7'Command'#7#5'ecCut'#8'ShortCut'#3'X@'#0#1#7 + +'Command'#7#12'ecDeleteLine'#8'ShortCut'#3'Y@'#0#1#7'Command'#7#11'ecDeleteE' + +'OL'#8'ShortCut'#3'Y`'#0#1#7'Command'#7#6'ecUndo'#8'ShortCut'#3'Z@'#0#1#7'Co' + +'mmand'#7#6'ecRedo'#8'ShortCut'#3'Z`'#0#1#7'Command'#7#13'ecGotoMarker0'#8'S' + +'hortCut'#3'0@'#0#1#7'Command'#7#13'ecGotoMarker1'#8'ShortCut'#3'1@'#0#1#7'C' + +'ommand'#7#13'ecGotoMarker2'#8'ShortCut'#3'2@'#0#1#7'Command'#7#13'ecGotoMar' + +'ker3'#8'ShortCut'#3'3@'#0#1#7'Command'#7#13'ecGotoMarker4'#8'ShortCut'#3'4@' + +#0#1#7'Command'#7#13'ecGotoMarker5'#8'ShortCut'#3'5@'#0#1#7'Command'#7#13'ec' + +'GotoMarker6'#8'ShortCut'#3'6@'#0#1#7'Command'#7#13'ecGotoMarker7'#8'ShortCu' + +'t'#3'7@'#0#1#7'Command'#7#13'ecGotoMarker8'#8'ShortCut'#3'8@'#0#1#7'Command' + +#7#13'ecGotoMarker9'#8'ShortCut'#3'9@'#0#1#7'Command'#7#12'ecSetMarker0'#8'S' + +'hortCut'#3'0`'#0#1#7'Command'#7#12'ecSetMarker1'#8'ShortCut'#3'1`'#0#1#7'Co' + +'mmand'#7#12'ecSetMarker2'#8'ShortCut'#3'2`'#0#1#7'Command'#7#12'ecSetMarker' + +'3'#8'ShortCut'#3'3`'#0#1#7'Command'#7#12'ecSetMarker4'#8'ShortCut'#3'4`'#0#1 + +#7'Command'#7#12'ecSetMarker5'#8'ShortCut'#3'5`'#0#1#7'Command'#7#12'ecSetMa' + +'rker6'#8'ShortCut'#3'6`'#0#1#7'Command'#7#12'ecSetMarker7'#8'ShortCut'#3'7`' + +#0#1#7'Command'#7#12'ecSetMarker8'#8'ShortCut'#3'8`'#0#1#7'Command'#7#12'ecS' + ,'etMarker9'#8'ShortCut'#3'9`'#0#1#7'Command'#7#12'EcFoldLevel1'#8'ShortCut'#4 + +'1'#160#0#0#0#1#7'Command'#7#12'EcFoldLevel2'#8'ShortCut'#4'2'#160#0#0#0#1#7 + +'Command'#7#12'EcFoldLevel1'#8'ShortCut'#4'3'#160#0#0#0#1#7'Command'#7#12'Ec' + +'FoldLevel1'#8'ShortCut'#4'4'#160#0#0#0#1#7'Command'#7#12'EcFoldLevel1'#8'Sh' + +'ortCut'#4'5'#160#0#0#0#1#7'Command'#7#12'EcFoldLevel6'#8'ShortCut'#4'6'#160 + +#0#0#0#1#7'Command'#7#12'EcFoldLevel7'#8'ShortCut'#4'7'#160#0#0#0#1#7'Comman' + +'d'#7#12'EcFoldLevel8'#8'ShortCut'#4'8'#160#0#0#0#1#7'Command'#7#12'EcFoldLe' + +'vel9'#8'ShortCut'#4'9'#160#0#0#0#1#7'Command'#7#12'EcFoldLevel0'#8'ShortCut' + +#4'0'#160#0#0#0#1#7'Command'#7#13'EcFoldCurrent'#8'ShortCut'#4'-'#160#0#0#0#1 + +#7'Command'#7#15'EcUnFoldCurrent'#8'ShortCut'#4'+'#160#0#0#0#1#7'Command'#7 + +#18'EcToggleMarkupWord'#8'ShortCut'#4'M'#128#0#0#0#1#7'Command'#7#14'ecNorma' + +'lSelect'#8'ShortCut'#3'N`'#0#1#7'Command'#7#14'ecColumnSelect'#8'ShortCut'#3 + +'C`'#0#1#7'Command'#7#12'ecLineSelect'#8'ShortCut'#3'L`'#0#1#7'Command'#7#5 + +'ecTab'#8'ShortCut'#2#9#0#1#7'Command'#7#10'ecShiftTab'#8'ShortCut'#3#9' '#0 + +#1#7'Command'#7#14'ecMatchBracket'#8'ShortCut'#3'B`'#0#1#7'Command'#7#10'ecC' + +'olSelUp'#8'ShortCut'#4'&'#160#0#0#0#1#7'Command'#7#12'ecColSelDown'#8'Short' + +'Cut'#4'('#160#0#0#0#1#7'Command'#7#12'ecColSelLeft'#8'ShortCut'#4'%'#160#0#0 + +#0#1#7'Command'#7#13'ecColSelRight'#8'ShortCut'#4''''#160#0#0#0#1#7'Command' + +#7#16'ecColSelPageDown'#8'ShortCut'#4'"'#160#0#0#0#1#7'Command'#7#18'ecColSe' + +'lPageBottom'#8'ShortCut'#4'"'#224#0#0#0#1#7'Command'#7#14'ecColSelPageUp'#8 + +'ShortCut'#4'!'#160#0#0#0#1#7'Command'#7#15'ecColSelPageTop'#8'ShortCut'#4'!' + +#224#0#0#0#1#7'Command'#7#17'ecColSelLineStart'#8'ShortCut'#4'$'#160#0#0#0#1 + +#7'Command'#7#15'ecColSelLineEnd'#8'ShortCut'#4'#'#160#0#0#0#1#7'Command'#7 + +#17'ecColSelEditorTop'#8'ShortCut'#4'$'#224#0#0#0#1#7'Command'#7#20'ecColSel' + +'EditorBottom'#8'ShortCut'#4'#'#224#0#0#0#0#12'MouseActions'#14#1#5'Shift'#11 + +#0#9'ShiftMask'#11#7'ssShift'#5'ssAlt'#0#6'Button'#7#6'mbLeft'#10'ClickCount' + +#7#8'ccSingle'#8'ClickDir'#7#6'cdDown'#7'Command'#2#1#9'MoveCaret'#9#6'Optio' + +'n'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#7'ssShift'#0#9'ShiftMask'#11#7'ssShi' + +'ft'#5'ssAlt'#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#8'ccSingle'#8'ClickDi' + +'r'#7#6'cdDown'#7'Command'#2#1#9'MoveCaret'#9#6'Option'#2#1#8'Priority'#2#0#0 + +#1#5'Shift'#11#5'ssAlt'#0#9'ShiftMask'#11#7'ssShift'#5'ssAlt'#0#6'Button'#7#6 + +'mbLeft'#10'ClickCount'#7#8'ccSingle'#8'ClickDir'#7#6'cdDown'#7'Command'#2#3 + +#9'MoveCaret'#9#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#7'ssShift'#5's' + +'sAlt'#0#9'ShiftMask'#11#7'ssShift'#5'ssAlt'#0#6'Button'#7#6'mbLeft'#10'Clic' + +'kCount'#7#8'ccSingle'#8'ClickDir'#7#6'cdDown'#7'Command'#2#3#9'MoveCaret'#9 + +#6'Option'#2#1#8'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMask'#11#0#6'Button' + +#7#7'mbRight'#10'ClickCount'#7#8'ccSingle'#8'ClickDir'#7#4'cdUp'#7'Command'#2 + +#12#9'MoveCaret'#8#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMa' + +'sk'#11#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#8'ccDouble'#8'ClickDir'#7#6 + +'cdDown'#7'Command'#2#6#9'MoveCaret'#9#6'Option'#2#0#8'Priority'#2#0#0#1#5'S' + +'hift'#11#0#9'ShiftMask'#11#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#8'ccTri' + +'ple'#8'ClickDir'#7#6'cdDown'#7'Command'#2#7#9'MoveCaret'#9#6'Option'#2#0#8 + +'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMask'#11#0#6'Button'#7#6'mbLeft'#10 + +'ClickCount'#7#6'ccQuad'#8'ClickDir'#7#6'cdDown'#7'Command'#2#8#9'MoveCaret' + +#9#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMask'#11#0#6'Butto' + +'n'#7#8'mbMiddle'#10'ClickCount'#7#8'ccSingle'#8'ClickDir'#7#6'cdDown'#7'Com' + +'mand'#2#10#9'MoveCaret'#9#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#6's' + +'sCtrl'#0#9'ShiftMask'#11#7'ssShift'#5'ssAlt'#6'ssCtrl'#0#6'Button'#7#6'mbLe' + +'ft'#10'ClickCount'#7#8'ccSingle'#8'ClickDir'#7#4'cdUp'#7'Command'#2#11#9'Mo' + +'veCaret'#8#6'Option'#2#0#8'Priority'#2#0#0#0#15'MouseSelActions'#14#1#5'Shi' + +'ft'#11#0#9'ShiftMask'#11#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#8'ccSingl' + +'e'#8'ClickDir'#7#6'cdDown'#7'Command'#2#9#9'MoveCaret'#8#6'Option'#2#0#8'Pr' + +'iority'#2#0#0#0#13'Lines.Strings'#1#6#12'program new;'#6#5'begin'#6#4'end.' + +#0#21'BracketHighlightStyle'#7#8'sbhsBoth'#0#18'TSynGutterPartList'#0#0#15'T' + +'SynGutterMarks'#0#5'Width'#2#23#0#0#20'TSynGutterLineNumber'#0#5'Width'#2#17 + +#12'MouseActions'#14#0#21'MarkupInfo.Background'#7#9'clBtnFace'#21'MarkupInf' + +'o.Foreground'#7#6'clNone'#10'DigitCount'#2#2#30'ShowOnlyLineNumbersMultiple' + +'sOf'#2#1#9'ZeroStart'#8#12'LeadingZeros'#8#0#0#17'TSynGutterChanges'#0#5'Wi' + +'dth'#2#4#13'ModifiedColor'#4#252#233#0#0#10'SavedColor'#7#7'clGreen'#0#0#19 + +'TSynGutterSeparator'#0#5'Width'#2#2#0#0#21'TSynGutterCodeFolding'#0#12'Mous' + +'eActions'#14#1#5'Shift'#11#0#9'ShiftMask'#11#0#6'Button'#7#7'mbRight'#10'Cl' + +'ickCount'#7#8'ccSingle'#8'ClickDir'#7#4'cdUp'#7'Command'#2#16#9'MoveCaret'#8 + +#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMask'#11#7'ssShift'#0 + +#6'Button'#7#8'mbMiddle'#10'ClickCount'#7#5'ccAny'#8'ClickDir'#7#6'cdDown'#7 + ,'Command'#2#14#9'MoveCaret'#8#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#7 + +'ssShift'#0#9'ShiftMask'#11#7'ssShift'#0#6'Button'#7#8'mbMiddle'#10'ClickCou' + +'nt'#7#5'ccAny'#8'ClickDir'#7#6'cdDown'#7'Command'#2#14#9'MoveCaret'#8#6'Opt' + +'ion'#2#1#8'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMask'#11#0#6'Button'#7#6 + +'mbLeft'#10'ClickCount'#7#5'ccAny'#8'ClickDir'#7#6'cdDown'#7'Command'#2#0#9 + +'MoveCaret'#8#6'Option'#2#0#8'Priority'#2#0#0#0#21'MarkupInfo.Background'#7#6 + +'clNone'#21'MarkupInfo.Foreground'#7#6'clGray'#20'MouseActionsExpanded'#14#1 + +#5'Shift'#11#0#9'ShiftMask'#11#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#5'cc' + +'Any'#8'ClickDir'#7#6'cdDown'#7'Command'#2#14#9'MoveCaret'#8#6'Option'#2#0#8 + +'Priority'#2#0#0#0#21'MouseActionsCollapsed'#14#1#5'Shift'#11#6'ssCtrl'#0#9 + +'ShiftMask'#11#6'ssCtrl'#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#5'ccAny'#8 + +'ClickDir'#7#6'cdDown'#7'Command'#2#15#9'MoveCaret'#8#6'Option'#2#0#8'Priori' + +'ty'#2#0#0#1#5'Shift'#11#0#9'ShiftMask'#11#6'ssCtrl'#0#6'Button'#7#6'mbLeft' + +#10'ClickCount'#7#5'ccAny'#8'ClickDir'#7#6'cdDown'#7'Command'#2#15#9'MoveCar' + +'et'#8#6'Option'#2#1#8'Priority'#2#0#0#0#0#0#0#0#8'TSynMemo'#8'SynMemo1'#6'C' + +'ursor'#7#7'crIBeam'#4'Left'#2#20#6'Height'#2'}'#3'Top'#3#131#1#5'Width'#3 + +#142#2#11'Font.Height'#2#243#9'Font.Name'#6#11'Courier New'#10'Font.Pitch'#7 + +#7'fpFixed'#12'Font.Quality'#7#16'fqNonAntialiased'#11'ParentColor'#8#10'Par' + +'entFont'#8#8'TabOrder'#2#2#12'Gutter.Width'#2'9'#19'Gutter.MouseActions'#14 + +#1#5'Shift'#11#0#9'ShiftMask'#11#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#5 + +'ccAny'#8'ClickDir'#7#6'cdDown'#7'Command'#2#13#9'MoveCaret'#8#6'Option'#2#0 + +#8'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMask'#11#0#6'Button'#7#7'mbRight' + +#10'ClickCount'#7#8'ccSingle'#8'ClickDir'#7#4'cdUp'#7'Command'#2#12#9'MoveCa' + +'ret'#8#6'Option'#2#0#8'Priority'#2#0#0#0#10'Keystrokes'#14#1#7'Command'#7#4 + +'ecUp'#8'ShortCut'#2'&'#0#1#7'Command'#7#7'ecSelUp'#8'ShortCut'#3'& '#0#1#7 + +'Command'#7#10'ecScrollUp'#8'ShortCut'#3'&@'#0#1#7'Command'#7#6'ecDown'#8'Sh' + +'ortCut'#2'('#0#1#7'Command'#7#9'ecSelDown'#8'ShortCut'#3'( '#0#1#7'Command' + +#7#12'ecScrollDown'#8'ShortCut'#3'(@'#0#1#7'Command'#7#6'ecLeft'#8'ShortCut' + +#2'%'#0#1#7'Command'#7#9'ecSelLeft'#8'ShortCut'#3'% '#0#1#7'Command'#7#10'ec' + +'WordLeft'#8'ShortCut'#3'%@'#0#1#7'Command'#7#13'ecSelWordLeft'#8'ShortCut'#3 + +'%`'#0#1#7'Command'#7#7'ecRight'#8'ShortCut'#2''''#0#1#7'Command'#7#10'ecSel' + +'Right'#8'ShortCut'#3''' '#0#1#7'Command'#7#11'ecWordRight'#8'ShortCut'#3'''' + +'@'#0#1#7'Command'#7#14'ecSelWordRight'#8'ShortCut'#3'''`'#0#1#7'Command'#7 + +#10'ecPageDown'#8'ShortCut'#2'"'#0#1#7'Command'#7#13'ecSelPageDown'#8'ShortC' + +'ut'#3'" '#0#1#7'Command'#7#12'ecPageBottom'#8'ShortCut'#3'"@'#0#1#7'Command' + +#7#15'ecSelPageBottom'#8'ShortCut'#3'"`'#0#1#7'Command'#7#8'ecPageUp'#8'Shor' + +'tCut'#2'!'#0#1#7'Command'#7#11'ecSelPageUp'#8'ShortCut'#3'! '#0#1#7'Command' + +#7#9'ecPageTop'#8'ShortCut'#3'!@'#0#1#7'Command'#7#12'ecSelPageTop'#8'ShortC' + +'ut'#3'!`'#0#1#7'Command'#7#11'ecLineStart'#8'ShortCut'#2'$'#0#1#7'Command'#7 + +#14'ecSelLineStart'#8'ShortCut'#3'$ '#0#1#7'Command'#7#11'ecEditorTop'#8'Sho' + +'rtCut'#3'$@'#0#1#7'Command'#7#14'ecSelEditorTop'#8'ShortCut'#3'$`'#0#1#7'Co' + +'mmand'#7#9'ecLineEnd'#8'ShortCut'#2'#'#0#1#7'Command'#7#12'ecSelLineEnd'#8 + +'ShortCut'#3'# '#0#1#7'Command'#7#14'ecEditorBottom'#8'ShortCut'#3'#@'#0#1#7 + +'Command'#7#17'ecSelEditorBottom'#8'ShortCut'#3'#`'#0#1#7'Command'#7#12'ecTo' + +'ggleMode'#8'ShortCut'#2'-'#0#1#7'Command'#7#6'ecCopy'#8'ShortCut'#3'-@'#0#1 + +#7'Command'#7#7'ecPaste'#8'ShortCut'#3'- '#0#1#7'Command'#7#12'ecDeleteChar' + +#8'ShortCut'#2'.'#0#1#7'Command'#7#5'ecCut'#8'ShortCut'#3'. '#0#1#7'Command' + +#7#16'ecDeleteLastChar'#8'ShortCut'#2#8#0#1#7'Command'#7#16'ecDeleteLastChar' + +#8'ShortCut'#3#8' '#0#1#7'Command'#7#16'ecDeleteLastWord'#8'ShortCut'#3#8'@' + +#0#1#7'Command'#7#6'ecUndo'#8'ShortCut'#4#8#128#0#0#0#1#7'Command'#7#6'ecRed' + +'o'#8'ShortCut'#4#8#160#0#0#0#1#7'Command'#7#11'ecLineBreak'#8'ShortCut'#2#13 + +#0#1#7'Command'#7#11'ecSelectAll'#8'ShortCut'#3'A@'#0#1#7'Command'#7#6'ecCop' + +'y'#8'ShortCut'#3'C@'#0#1#7'Command'#7#13'ecBlockIndent'#8'ShortCut'#3'I`'#0 + +#1#7'Command'#7#11'ecLineBreak'#8'ShortCut'#3'M@'#0#1#7'Command'#7#12'ecInse' + +'rtLine'#8'ShortCut'#3'N@'#0#1#7'Command'#7#12'ecDeleteWord'#8'ShortCut'#3'T' + +'@'#0#1#7'Command'#7#15'ecBlockUnindent'#8'ShortCut'#3'U`'#0#1#7'Command'#7#7 + +'ecPaste'#8'ShortCut'#3'V@'#0#1#7'Command'#7#5'ecCut'#8'ShortCut'#3'X@'#0#1#7 + +'Command'#7#12'ecDeleteLine'#8'ShortCut'#3'Y@'#0#1#7'Command'#7#11'ecDeleteE' + +'OL'#8'ShortCut'#3'Y`'#0#1#7'Command'#7#6'ecUndo'#8'ShortCut'#3'Z@'#0#1#7'Co' + +'mmand'#7#6'ecRedo'#8'ShortCut'#3'Z`'#0#1#7'Command'#7#13'ecGotoMarker0'#8'S' + +'hortCut'#3'0@'#0#1#7'Command'#7#13'ecGotoMarker1'#8'ShortCut'#3'1@'#0#1#7'C' + +'ommand'#7#13'ecGotoMarker2'#8'ShortCut'#3'2@'#0#1#7'Command'#7#13'ecGotoMar' + +'ker3'#8'ShortCut'#3'3@'#0#1#7'Command'#7#13'ecGotoMarker4'#8'ShortCut'#3'4@' + +#0#1#7'Command'#7#13'ecGotoMarker5'#8'ShortCut'#3'5@'#0#1#7'Command'#7#13'ec' + ,'GotoMarker6'#8'ShortCut'#3'6@'#0#1#7'Command'#7#13'ecGotoMarker7'#8'ShortCu' + +'t'#3'7@'#0#1#7'Command'#7#13'ecGotoMarker8'#8'ShortCut'#3'8@'#0#1#7'Command' + +#7#13'ecGotoMarker9'#8'ShortCut'#3'9@'#0#1#7'Command'#7#12'ecSetMarker0'#8'S' + +'hortCut'#3'0`'#0#1#7'Command'#7#12'ecSetMarker1'#8'ShortCut'#3'1`'#0#1#7'Co' + +'mmand'#7#12'ecSetMarker2'#8'ShortCut'#3'2`'#0#1#7'Command'#7#12'ecSetMarker' + +'3'#8'ShortCut'#3'3`'#0#1#7'Command'#7#12'ecSetMarker4'#8'ShortCut'#3'4`'#0#1 + +#7'Command'#7#12'ecSetMarker5'#8'ShortCut'#3'5`'#0#1#7'Command'#7#12'ecSetMa' + +'rker6'#8'ShortCut'#3'6`'#0#1#7'Command'#7#12'ecSetMarker7'#8'ShortCut'#3'7`' + +#0#1#7'Command'#7#12'ecSetMarker8'#8'ShortCut'#3'8`'#0#1#7'Command'#7#12'ecS' + +'etMarker9'#8'ShortCut'#3'9`'#0#1#7'Command'#7#12'EcFoldLevel1'#8'ShortCut'#4 + +'1'#160#0#0#0#1#7'Command'#7#12'EcFoldLevel2'#8'ShortCut'#4'2'#160#0#0#0#1#7 + +'Command'#7#12'EcFoldLevel1'#8'ShortCut'#4'3'#160#0#0#0#1#7'Command'#7#12'Ec' + +'FoldLevel1'#8'ShortCut'#4'4'#160#0#0#0#1#7'Command'#7#12'EcFoldLevel1'#8'Sh' + +'ortCut'#4'5'#160#0#0#0#1#7'Command'#7#12'EcFoldLevel6'#8'ShortCut'#4'6'#160 + +#0#0#0#1#7'Command'#7#12'EcFoldLevel7'#8'ShortCut'#4'7'#160#0#0#0#1#7'Comman' + +'d'#7#12'EcFoldLevel8'#8'ShortCut'#4'8'#160#0#0#0#1#7'Command'#7#12'EcFoldLe' + +'vel9'#8'ShortCut'#4'9'#160#0#0#0#1#7'Command'#7#12'EcFoldLevel0'#8'ShortCut' + +#4'0'#160#0#0#0#1#7'Command'#7#13'EcFoldCurrent'#8'ShortCut'#4'-'#160#0#0#0#1 + +#7'Command'#7#15'EcUnFoldCurrent'#8'ShortCut'#4'+'#160#0#0#0#1#7'Command'#7 + +#18'EcToggleMarkupWord'#8'ShortCut'#4'M'#128#0#0#0#1#7'Command'#7#14'ecNorma' + +'lSelect'#8'ShortCut'#3'N`'#0#1#7'Command'#7#14'ecColumnSelect'#8'ShortCut'#3 + +'C`'#0#1#7'Command'#7#12'ecLineSelect'#8'ShortCut'#3'L`'#0#1#7'Command'#7#5 + +'ecTab'#8'ShortCut'#2#9#0#1#7'Command'#7#10'ecShiftTab'#8'ShortCut'#3#9' '#0 + +#1#7'Command'#7#14'ecMatchBracket'#8'ShortCut'#3'B`'#0#1#7'Command'#7#10'ecC' + +'olSelUp'#8'ShortCut'#4'&'#160#0#0#0#1#7'Command'#7#12'ecColSelDown'#8'Short' + +'Cut'#4'('#160#0#0#0#1#7'Command'#7#12'ecColSelLeft'#8'ShortCut'#4'%'#160#0#0 + +#0#1#7'Command'#7#13'ecColSelRight'#8'ShortCut'#4''''#160#0#0#0#1#7'Command' + +#7#16'ecColSelPageDown'#8'ShortCut'#4'"'#160#0#0#0#1#7'Command'#7#18'ecColSe' + +'lPageBottom'#8'ShortCut'#4'"'#224#0#0#0#1#7'Command'#7#14'ecColSelPageUp'#8 + +'ShortCut'#4'!'#160#0#0#0#1#7'Command'#7#15'ecColSelPageTop'#8'ShortCut'#4'!' + +#224#0#0#0#1#7'Command'#7#17'ecColSelLineStart'#8'ShortCut'#4'$'#160#0#0#0#1 + +#7'Command'#7#15'ecColSelLineEnd'#8'ShortCut'#4'#'#160#0#0#0#1#7'Command'#7 + +#17'ecColSelEditorTop'#8'ShortCut'#4'$'#224#0#0#0#1#7'Command'#7#20'ecColSel' + +'EditorBottom'#8'ShortCut'#4'#'#224#0#0#0#0#12'MouseActions'#14#1#5'Shift'#11 + +#0#9'ShiftMask'#11#7'ssShift'#5'ssAlt'#0#6'Button'#7#6'mbLeft'#10'ClickCount' + +#7#8'ccSingle'#8'ClickDir'#7#6'cdDown'#7'Command'#2#1#9'MoveCaret'#9#6'Optio' + +'n'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#7'ssShift'#0#9'ShiftMask'#11#7'ssShi' + +'ft'#5'ssAlt'#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#8'ccSingle'#8'ClickDi' + +'r'#7#6'cdDown'#7'Command'#2#1#9'MoveCaret'#9#6'Option'#2#1#8'Priority'#2#0#0 + +#1#5'Shift'#11#5'ssAlt'#0#9'ShiftMask'#11#7'ssShift'#5'ssAlt'#0#6'Button'#7#6 + +'mbLeft'#10'ClickCount'#7#8'ccSingle'#8'ClickDir'#7#6'cdDown'#7'Command'#2#3 + +#9'MoveCaret'#9#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#7'ssShift'#5's' + +'sAlt'#0#9'ShiftMask'#11#7'ssShift'#5'ssAlt'#0#6'Button'#7#6'mbLeft'#10'Clic' + +'kCount'#7#8'ccSingle'#8'ClickDir'#7#6'cdDown'#7'Command'#2#3#9'MoveCaret'#9 + +#6'Option'#2#1#8'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMask'#11#0#6'Button' + +#7#7'mbRight'#10'ClickCount'#7#8'ccSingle'#8'ClickDir'#7#4'cdUp'#7'Command'#2 + +#12#9'MoveCaret'#8#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMa' + +'sk'#11#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#8'ccDouble'#8'ClickDir'#7#6 + +'cdDown'#7'Command'#2#6#9'MoveCaret'#9#6'Option'#2#0#8'Priority'#2#0#0#1#5'S' + +'hift'#11#0#9'ShiftMask'#11#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#8'ccTri' + +'ple'#8'ClickDir'#7#6'cdDown'#7'Command'#2#7#9'MoveCaret'#9#6'Option'#2#0#8 + +'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMask'#11#0#6'Button'#7#6'mbLeft'#10 + +'ClickCount'#7#6'ccQuad'#8'ClickDir'#7#6'cdDown'#7'Command'#2#8#9'MoveCaret' + +#9#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMask'#11#0#6'Butto' + +'n'#7#8'mbMiddle'#10'ClickCount'#7#8'ccSingle'#8'ClickDir'#7#6'cdDown'#7'Com' + +'mand'#2#10#9'MoveCaret'#9#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#6's' + +'sCtrl'#0#9'ShiftMask'#11#7'ssShift'#5'ssAlt'#6'ssCtrl'#0#6'Button'#7#6'mbLe' + +'ft'#10'ClickCount'#7#8'ccSingle'#8'ClickDir'#7#4'cdUp'#7'Command'#2#11#9'Mo' + +'veCaret'#8#6'Option'#2#0#8'Priority'#2#0#0#0#15'MouseSelActions'#14#1#5'Shi' + +'ft'#11#0#9'ShiftMask'#11#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#8'ccSingl' + +'e'#8'ClickDir'#7#6'cdDown'#7'Command'#2#9#9'MoveCaret'#8#6'Option'#2#0#8'Pr' + +'iority'#2#0#0#0#13'Lines.Strings'#1#6#8'SynMemo1'#0#8'OnChange'#7#14'SynMem' + +'o1Change'#0#18'TSynGutterPartList'#0#0#15'TSynGutterMarks'#0#5'Width'#2#23#0 + +#0#20'TSynGutterLineNumber'#0#5'Width'#2#17#12'MouseActions'#14#0#21'MarkupI' + ,'nfo.Background'#7#9'clBtnFace'#21'MarkupInfo.Foreground'#7#6'clNone'#10'Dig' + +'itCount'#2#2#30'ShowOnlyLineNumbersMultiplesOf'#2#1#9'ZeroStart'#8#12'Leadi' + +'ngZeros'#8#0#0#17'TSynGutterChanges'#0#5'Width'#2#4#13'ModifiedColor'#4#252 + +#233#0#0#10'SavedColor'#7#7'clGreen'#0#0#19'TSynGutterSeparator'#0#5'Width'#2 + +#2#0#0#21'TSynGutterCodeFolding'#0#12'MouseActions'#14#1#5'Shift'#11#0#9'Shi' + +'ftMask'#11#0#6'Button'#7#7'mbRight'#10'ClickCount'#7#8'ccSingle'#8'ClickDir' + +#7#4'cdUp'#7'Command'#2#16#9'MoveCaret'#8#6'Option'#2#0#8'Priority'#2#0#0#1#5 + +'Shift'#11#0#9'ShiftMask'#11#7'ssShift'#0#6'Button'#7#8'mbMiddle'#10'ClickCo' + +'unt'#7#5'ccAny'#8'ClickDir'#7#6'cdDown'#7'Command'#2#14#9'MoveCaret'#8#6'Op' + +'tion'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#7'ssShift'#0#9'ShiftMask'#11#7'ss' + +'Shift'#0#6'Button'#7#8'mbMiddle'#10'ClickCount'#7#5'ccAny'#8'ClickDir'#7#6 + +'cdDown'#7'Command'#2#14#9'MoveCaret'#8#6'Option'#2#1#8'Priority'#2#0#0#1#5 + +'Shift'#11#0#9'ShiftMask'#11#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#5'ccAn' + +'y'#8'ClickDir'#7#6'cdDown'#7'Command'#2#0#9'MoveCaret'#8#6'Option'#2#0#8'Pr' + +'iority'#2#0#0#0#21'MarkupInfo.Background'#7#6'clNone'#21'MarkupInfo.Foregro' + +'und'#7#6'clGray'#20'MouseActionsExpanded'#14#1#5'Shift'#11#0#9'ShiftMask'#11 + +#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#5'ccAny'#8'ClickDir'#7#6'cdDown'#7 + +'Command'#2#14#9'MoveCaret'#8#6'Option'#2#0#8'Priority'#2#0#0#0#21'MouseActi' + +'onsCollapsed'#14#1#5'Shift'#11#6'ssCtrl'#0#9'ShiftMask'#11#6'ssCtrl'#0#6'Bu' + +'tton'#7#6'mbLeft'#10'ClickCount'#7#5'ccAny'#8'ClickDir'#7#6'cdDown'#7'Comma' + +'nd'#2#15#9'MoveCaret'#8#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#0#9'S' + +'hiftMask'#11#6'ssCtrl'#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#5'ccAny'#8 + +'ClickDir'#7#6'cdDown'#7'Command'#2#15#9'MoveCaret'#8#6'Option'#2#1#8'Priori' + +'ty'#2#0#0#0#0#0#0#0#17'TSynFreePascalSyn'#17'SynFreePascalSyn1'#7'Enabled'#8 + +#12'CompilerMode'#7#9'pcmObjFPC'#14'NestedComments'#9#4'left'#3#242#1#3'top' + +#2'Y'#0#0#0 +]); diff --git a/Projects/SAMufasaGUI/testunit.pas b/Projects/SAMufasaGUI/testunit.pas index eeb91af..3e851c7 100644 --- a/Projects/SAMufasaGUI/testunit.pas +++ b/Projects/SAMufasaGUI/testunit.pas @@ -6,7 +6,8 @@ interface uses Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs, - StdCtrls, Client, MufasaTypes, mmlthread; + StdCtrls, SynEdit, SynHighlighterPas, SynMemo, Client, MufasaTypes, + mmlpsthread; type @@ -14,7 +15,11 @@ type TForm1 = class(TForm) Button1: TButton; + SynEdit1: TSynEdit; + SynFreePascalSyn1: TSynFreePascalSyn; + SynMemo1: TSynMemo; procedure Button1Click(Sender: TObject); + procedure SynMemo1Change(Sender: TObject); private { private declarations } public @@ -254,13 +259,24 @@ end; procedure TForm1.Button1Click(Sender: TObject); Var //MyThread: TMyThread; - MMLThread: TMMLThread; +// MMLThread: TMMLThread; + MMLPSThread : TMMLPSThread; begin { MyThread := TMyThread.Create(True); MyThread.Resume; } - MMLThread := TMMLThread.Create(True); - MMLThread.Resume; +{ MMLThread := TMMLThread.Create(True); + MMLThread.Resume;} + MMLPSThread := TMMLPSThread.Create(True); + MMLPSThread.SetPSScript(SynEdit1.Lines.Text); + MMLPSThread.SetDebug(SynMemo1); + MMLPSThread.Resume; + +end; + +procedure TForm1.SynMemo1Change(Sender: TObject); +begin + end; initialization diff --git a/Units/MMLAddon/mmlpsthread.pas b/Units/MMLAddon/mmlpsthread.pas new file mode 100644 index 0000000..dee8699 --- /dev/null +++ b/Units/MMLAddon/mmlpsthread.pas @@ -0,0 +1,245 @@ +unit mmlpsthread; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, client, uPSComponent,uPSCompiler,uPSRuntime,SynMemo; + +type + + { TMMLPSThread } + + TMMLPSThread = class(TThread) + protected +// PSScript : TPSScript; +// PSClient : TPSScript; +// Client: TClient; +// DebugTo : TStrings; + Client : TClient; + PSScript : TPSScript; + DebugTo : TSynMemo; + procedure OnCompile(Sender: TPSScript); + procedure AfterExecute(Sender : TPSScript); + function RequireFile(Sender: TObject; const OriginFileName: String; + var FileName, OutPut: string): Boolean; + procedure OnCompImport(Sender: TObject; x: TPSPascalCompiler); + procedure OnExecImport(Sender: TObject; se: TPSExec; x: TPSRuntimeClassImporter); + procedure OutputMessages; + procedure Execute; override; + public + procedure SetPSScript(Script : string); + procedure SetDebug( Strings : TSynMemo ); + function SetClientInfo : boolean; +// function CompilePSScript : boolean; +// function + constructor Create(CreateSuspended: Boolean); + destructor Destroy; + end; + +implementation +uses + MufasaTypes,{$ifdef mswindows}windows,{$endif} + uPSC_std, uPSC_Controls,uPSC_Classes,uPSC_Graphics,uPSC_stdctrls,uPSC_Forms,uPSC_extctrls, //Compile-libs + uPSR_std, uPSR_Controls,uPSR_Classes,uPSR_Graphics,uPSR_stdctrls,uPSR_Forms,uPSR_extctrls; //Runtime-libs + + +threadvar + CurrThread : TMMLPSThread; + +{Some General PS Functions here} +procedure Writeln(str : string); +begin; + if CurrThread.DebugTo <> nil then + CurrThread.DebugTo.Lines.Add(Str); + //Just overwriting itz.. soz. +end; + +function ThreadSafeCall(ProcName: string; var V: TVariantArray): Variant; +var + i : integer; +begin; + Writeln('We have a length of: ' + inttostr(length(v))); + Try + Result := CurrThread.PSScript.Exec.RunProcPVar(v,CurrThread.PSScript.Exec.GetProc(Procname)); + Except + Writeln('We has some errors :-('); + end; +end; + +{ + Note to Raymond: For PascalScript, Create it on the .Create, + Execute it on the .Execute, and don't forget to Destroy it on .Destroy. + + Furthermore, all the wrappers can be in the unit "implementation" section. + Better still to create an .inc for it, otherwise this unit will become huge. + (You can even split up the .inc's in stuff like color, bitmap, etc. ) + + Also, don't add PS to this unit, but make a seperate unit for it. + Unit "MMLPSThread", perhaps? + + See the TestUnit for use of this thread, it's pretty straightforward. + + It may also be wise to turn the "Importing of wrappers" into an include as + well, it will really make the unit more straightforward to use and read. +} + + +constructor TMMLPSThread.Create(CreateSuspended : boolean); +begin + if Client <> nil then + Writeln('ThreadClient seems to be set, so not recreating it.') //reset client to defaults? + //ThreadClient.ResetToDefaults + else + Client := TClient.Create; + if PSScript <> nil then + PSScript.Free; + // Create Stuff here + PSScript := TPSScript.Create(nil); + PSScript.UsePreProcessor:= True; + PSScript.OnNeedFile := @RequireFile; + + + PSScript.OnCompile:= @OnCompile; + PSScript.OnCompImport:= @OnCompImport; + PSScript.OnExecImport:= @OnExecImport; + PSScript.OnAfterExecute:= @AfterExecute; + {$IFDEF CPU386 } + PSScript.Defines.Add ('CPU386'); + {$ENDIF } + PSScript.Defines.Add ('MUFASA'); + PSScript.Defines.Add ('COGAT'); + PSScript.Defines.Add ('RAYMONDPOWNS'); + {$IFDEF MSWINDOWS } + PSScript.Defines.Add ('MSWINDOWS'); + PSScript.Defines.Add ('WIN32'); + PSScript.Defines.Add ('WINDOWS'); + {$ENDIF } + {$IFDEF LINUX } + PSScript.Defines.Add ('LINUX'); + {$ENDIF } + FreeOnTerminate := True; + inherited Create(CreateSuspended); +end; + +destructor TMMLPSThread.Destroy; +begin + Client.Free; + PSScript.Free; + inherited Destroy; +end; + +procedure TMMLPSThread.OnCompile(Sender: TPSScript); +begin + //Here we add all the initalizing, of BMPArray etc + Sender.AddFunction(@ThreadSafeCall,'function ThreadSafeCall(ProcName: string; var V: TVariantArray): Variant;'); + Sender.AddFunction(@Writeln,'procedure writeln(s : string);'); + //Also the functions get added into the engine, right here. +end; + +procedure TMMLPSThread.AfterExecute(Sender: TPSScript); +begin + //Here we add all the Script-freeing-leftovers (like BMParray etc) +end; + +function TMMLPSThread.RequireFile(Sender: TObject; + const OriginFileName: String; var FileName, OutPut: string): Boolean; +begin + +end; + +procedure TMMLPSThread.OnCompImport(Sender: TObject; x: TPSPascalCompiler); +begin + SIRegister_Std(x); + SIRegister_Controls(x); + SIRegister_Classes(x, true); + SIRegister_Graphics(x, true); + SIRegister_stdctrls(x); + SIRegister_Forms(x); + SIRegister_ExtCtrls(x); +end; + +procedure TMMLPSThread.OnExecImport(Sender: TObject; se: TPSExec; + x: TPSRuntimeClassImporter); +begin + RIRegister_Std(x); + RIRegister_Classes(x, True); + RIRegister_Controls(x); + RIRegister_Graphics(x, True); + RIRegister_stdctrls(x); + RIRegister_Forms(x); + RIRegister_ExtCtrls(x); +end; + +procedure TMMLPSThread.OutputMessages; +var + l: Longint; + b: Boolean; +begin + b := False; + for l := 0 to PSScript.CompilerMessageCount - 1 do + begin + Writeln(PSScript.CompilerErrorToStr(l)); + if (not b) and (PSScript.CompilerMessages[l] is TIFPSPascalCompilerError) then + begin + b := True; +// FormMain.CurrSynEdit.SelStart := PSScript.CompilerMessages[l].Pos; + + end; + end; +end; + +procedure TMMLPSThread.Execute; +var + time, i, ii: Integer; +begin; + CurrThread := Self; + time := GetTickCount; + try + if PSScript.Compile then + begin + OutputMessages; + Writeln('Compiled succesfully in ' + IntToStr(GetTickCount - time) + ' ms.'); +// if not (ScriptState = SCompiling) then + if not PSScript.Execute then + begin +// FormMain.CurrSynEdit.SelStart := Script.PSScript.ExecErrorPosition; + Writeln(PSScript.ExecErrorToString +' at '+Inttostr(PSScript.ExecErrorProcNo)+'.' + +Inttostr(PSScript.ExecErrorByteCodePosition)); + end else Writeln('Succesfully executed'); + end else + begin + OutputMessages; + Writeln('Compiling failed'); + end; + except + on E : Exception do + Writeln('Error: ' + E.Message); + end; +end; + +procedure TMMLPSThread.SetPSScript(Script: string); +begin + PSScript.Script.Text:= Script; +end; + +procedure TMMLPSThread.SetDebug(Strings: TSynMemo); +begin + DebugTo := Strings; +end; + +function TMMLPSThread.SetClientInfo: boolean; +begin + //Set the client handle, etc +end; + +{ Include stuff here? } + +//{$I inc/colors.inc} +//{$I inc/bitmaps.inc} + + +end. + + diff --git a/Units/MMLCore/mufasatypes.pas b/Units/MMLCore/mufasatypes.pas index eb2030b..681f136 100644 --- a/Units/MMLCore/mufasatypes.pas +++ b/Units/MMLCore/mufasatypes.pas @@ -23,7 +23,7 @@ type TClickType = (mouse_Left, mouse_Right, mouse_Middle); TMousePress = (mouse_Down, mouse_Up); TPointArray = array of TPoint; - + TVariantArray = Array of Variant; implementation diff --git a/Units/PascalScript/PascalScript.inc b/Units/PascalScript/PascalScript.inc new file mode 100644 index 0000000..7e30390 --- /dev/null +++ b/Units/PascalScript/PascalScript.inc @@ -0,0 +1,62 @@ +{----------------------------------------------------------------------------} +{ RemObjects Pascal Script } +{ } +{ compiler: Delphi 2 and up, Kylix 3 and up } +{ platform: Win32, Linux } +{ } +{ (c)opyright RemObjects Software. all rights reserved. } +{ } +{----------------------------------------------------------------------------} + + +{$INCLUDE eDefines.inc} + +{$IFDEF FPC}{$MODE DELPHI}{$H+}{$ENDIF} + +{$IFDEF VER125}{C4}{$B-}{$X+}{$T-}{$H+}{$ENDIF} +{$IFDEF VER110}{C3}{$B-}{$X+}{$T-}{$H+}{$ENDIF} +{$IFDEF VER93}{C1}{$B-}{$X+}{$T-}{$H+}{$ENDIF} + +{$IFDEF DELPHI4UP} + {$DEFINE PS_HAVEVARIANT} + {$DEFINE PS_DYNARRAY} +{$ENDIF} + +{$IFNDEF FPC} + {$B-}{$X+}{$T-}{$H+} +{$ELSE} + {$R-}{$Q-} +{$ENDIF} + +{$IFNDEF FPC} +{$IFNDEF DELPHI4UP} +{$IFNDEF LINUX} + {$DEFINE PS_NOINT64} +{$ENDIF} +{$ENDIF} + +{$IFDEF DELPHI2} + {$DEFINE PS_NOINT64} + {$DEFINE PS_NOWIDESTRING} + {$B-}{$X+}{$T-}{$H+} +{$ENDIF} + +{$IFDEF LINUX}{KYLIX}{$DEFINE CLX}{$DEFINE DELPHI3UP}{$DEFINE DELPHI6UP}{$ENDIF} +{$ENDIF} +{$R-}{$Q-} + + +{ +Defines: + IFPS3_NOSMARTLIST - Don't use the smart list option +} + +{$UNDEF DEBUG} + +{$IFDEF CLX} +{$DEFINE PS_NOIDISPATCH} // not implemented +{$ENDIF} + +{$IFDEF FPC} + {$I PascalScriptFPC.inc} +{$ENDIF} diff --git a/Units/PascalScript/PascalScriptFPC.inc b/Units/PascalScript/PascalScriptFPC.inc new file mode 100644 index 0000000..96883ce --- /dev/null +++ b/Units/PascalScript/PascalScriptFPC.inc @@ -0,0 +1,15 @@ + + {$DEFINE PS_HAVEVARIANT} + {$DEFINE PS_DYNARRAY} + {$DEFINE PS_NOIDISPATCH} + {$if (fpc_version=2) and (fpc_release>=3) and (fpc_patch>=1)} + {.$if (fpc_version=2) and (fpc_release>=2) and (fpc_patch>=4)} + {$UNDEF FPC_OLD_FIX} + {$UNDEF PS_FPCSTRINGWORKAROUND} + {FreePascal 2.3.1 and above has much Delphi compatibility bugs fixed} + {$else} + {$DEFINE FPC_OLD_FIX} + {$DEFINE PS_FPCSTRINGWORKAROUND} + {$ifend} + {$DEFINE DELPHI3UP} + {$DEFINE DELPHI6UP} diff --git a/Units/PascalScript/PascalScript_Core_Ext_Reg.pas b/Units/PascalScript/PascalScript_Core_Ext_Reg.pas new file mode 100644 index 0000000..1a9de6e --- /dev/null +++ b/Units/PascalScript/PascalScript_Core_Ext_Reg.pas @@ -0,0 +1,30 @@ +unit PascalScript_Core_Ext_Reg; + +{----------------------------------------------------------------------------} +{ RemObjects Pascal Script } +{ } +{ compiler: Delphi 2 and up, Kylix 3 and up } +{ platform: Win32, Linux } +{ } +{ (c)opyright RemObjects Software. all rights reserved. } +{ } +{----------------------------------------------------------------------------} + +{$I PascalScript.inc} + +interface + +procedure Register; + +implementation + +uses + Classes, + uPSComponentExt; + +procedure Register; +begin + RegisterComponents('RemObjects Pascal Script',[TPSScriptExtension]); +end; + +end. diff --git a/Units/PascalScript/PascalScript_Core_Reg.pas b/Units/PascalScript/PascalScript_Core_Reg.pas new file mode 100644 index 0000000..5987b51 --- /dev/null +++ b/Units/PascalScript/PascalScript_Core_Reg.pas @@ -0,0 +1,65 @@ +unit PascalScript_Core_Reg; + +{---------------------------------------------------------------------------- +/ RemObjects Pascal Script +/ +/ compiler: Delphi 2 and up, Kylix 3 and up +/ platform: Win32, Linux +/ +/ (c)opyright RemObjects Software. all rights reserved. +/ +----------------------------------------------------------------------------} + +{$I PascalScript.inc} + +interface + +{$IFNDEF FPC} +{$R PascalScript_Core_Glyphs.res} +{$ENDIF} + +procedure Register; + +implementation + +uses + Classes, + {$IFDEF FPC} + LResources, + {$ENDIF} + uPSComponent, + uPSDebugger, + uPSComponent_Default, + {$IFNDEF FPC} + uPSComponent_COM, + {$ENDIF} + uPSComponent_DB, + uPSComponent_Forms, + uPSComponent_Controls, + uPSComponent_StdCtrls; + +procedure Register; +begin + RegisterComponents('Pascal Script', [TPSScript, + TPSScriptDebugger, + TPSDllPlugin, + TPSImport_Classes, + TPSImport_DateUtils, + {$IFNDEF FPC} + TPSImport_ComObj, + {$ENDIF} + TPSImport_DB, + TPSImport_Forms, + TPSImport_Controls, + TPSImport_StdCtrls, + TPSCustumPlugin]); +end; + + +{$IFDEF FPC} + initialization; + {$i pascalscript.lrs} +{$ENDIF} + + +end. diff --git a/Units/PascalScript/PascalScript_Core_Reg_noDB.pas b/Units/PascalScript/PascalScript_Core_Reg_noDB.pas new file mode 100644 index 0000000..d756512 --- /dev/null +++ b/Units/PascalScript/PascalScript_Core_Reg_noDB.pas @@ -0,0 +1,48 @@ +unit PascalScript_Core_Reg_noDB; + +{----------------------------------------------------------------------------} +{ RemObjects Pascal Script +{ +{ compiler: Delphi 2 and up, Kylix 3 and up +{ platform: Win32, Linux +{ +{ (c)opyright RemObjects Software. all rights reserved. +{ +{----------------------------------------------------------------------------} + +{$I PascalScript.inc} + +interface + +{$R PascalScript_Core_Glyphs.res} + +procedure Register; + +implementation + +uses + Classes, + uPSComponent, + uPSComponentExt, + uPSDebugger, + uPSComponent_Default, + uPSComponent_COM, + uPSComponent_Forms, + uPSComponent_Controls, + uPSComponent_StdCtrls; + +procedure Register; +begin + RegisterComponents('Pascal Script', [TPSScript, + TPSScriptDebugger, + TPSDllPlugin, + TPSImport_Classes, + TPSImport_DateUtils, + TPSImport_ComObj, + TPSImport_Forms, + TPSImport_Controls, + TPSImport_StdCtrls, + TPSScriptExtension]); +end; + +end. diff --git a/Units/PascalScript/PascalScript_RO_Reg.pas b/Units/PascalScript/PascalScript_RO_Reg.pas new file mode 100644 index 0000000..1369293 --- /dev/null +++ b/Units/PascalScript/PascalScript_RO_Reg.pas @@ -0,0 +1,34 @@ +unit PascalScript_RO_Reg; + +{----------------------------------------------------------------------------} +{ RemObjects Pascal Script +{ +{ compiler: Delphi 2 and up, Kylix 3 and up +{ platform: Win32, Linux +{ +{ (c)opyright RemObjects Software. all rights reserved. +{ +{ Using this code requires a valid license of Pascal Script +{ which can be obtained at http://www.remobjects.com. +{----------------------------------------------------------------------------} + +{$I PascalScript.inc} + +interface + +{$R PascalScript_RO_Glyphs.res} + +procedure Register; + +implementation + +uses + Classes, + uROPSServerLink; + +procedure Register; +begin + RegisterComponents('Pascal Script', [TPSRemObjectsSdkPlugin]); +end; + +end. diff --git a/Units/PascalScript/arm.inc b/Units/PascalScript/arm.inc new file mode 100644 index 0000000..1765635 --- /dev/null +++ b/Units/PascalScript/arm.inc @@ -0,0 +1,312 @@ +{ implementation of the arm procedure call standard for function calls in pascal script + Copyright (c) 2008 by Henry Vermaak (henry.vermaak@gmail.com) + + todo: add eabi (define FPC_ABI_EABI) and wince support + + notes: + + most arm cpus don't allow unaligned access. by default (?) the linux kernel + is set up to try and correct unaligned access, which can lead to strange behaviour. + to turn this off, try (as root): + + echo 4 > /proc/cpu/alignment + + if you have an alignment problem, you will now get a crash with a backtrace like this: + (make sure you compile with -O- -gl) + + An unhandled exception occurred at $0006C014 : + EBusError : Bus error or misaligned data access + $0006C014 PROCESSREPEAT, line 9670 of upscompiler.pas + $00068AAC TPSPASCALCOMPILER__PROCESSSUB, line 10459 of upscompiler.pas + $0007D0B4 TPSPASCALCOMPILER__COMPILE, line 11704 of upscompiler.pas + + you can fix this by using the "unaligned" keyword around the pointer operation. + search for occurances of "unaligned" to see how this is done, + (use $ifdef FPC_REQUIRES_PROPER_ALIGNMENT). + + for more information, visit: + + http://www.aleph1.co.uk/oldsite/armlinux/book/afaq.html +} + +const + rtINT = 0; + rtINT64 = 1; + rtFLOAT = 2; + +type + Trint = array[1..4] of dword; + Trfloat = array[1..4] of double; + +{$goto on} +{ define labels } +label + stack_loop, + load_regs, + asmcall_end, + int_result, + int64_result, + float_result; + +{ call a function from a pointer } +{ resulttype: 0 = int, 1 = int64, 2 = float } +function armasmcall(rint: Trint; rfloat: Trfloat; proc, stack: pointer; stacksize, resulttype: integer): pointer; assembler; nostackframe; +asm + mov r12, r13 + stmfd r13!, {r4, r5, r6, r7, r8, r9, r10, r11, r12, r14, r15} + sub r11, r12, #4 + mov r4, #80 (* space for preserved registers and parameters *) + ldr r5, [r11, #4] (* stacksize we need for subroutine *) + add r4, r4, r5 + sub r13, r13, r4 (* create stack space *) + + (* store parameters on stack *) + str r0, [r11, #-44] (* rint *) + str r1, [r11, #-48] (* rfloat *) + str r2, [r11, #-52] (* proc *) + str r3, [r11, #-56] (* stack *) + ldr r0, [r11, #4] + str r0, [r11, #-60] (* stacksize *) + ldr r0, [r11, #8] + str r0, [r11, #-64] (* resulttype *) + + (* store params for sub-routine that don't fit into r0-r3 at start of stack *) + ldr r0, [r11, #-60] (* stacksize *) + cmp r0, #0 + beq load_regs (* skip if no stack *) + mov r1, r13 (* this points to the bottom now *) + ldr r2, [r11, #-56] (* stack pointer *) +stack_loop: + ldmia r2!, {r4} (* get stack + update pos *) + stmia r1!, {r4} (* store stack + update pos *) + subs r0, r0, #4 + bne stack_loop + +load_regs: + (* load general regs *) + ldr r4, [r11, #-44] (* rint *) + ldr r0, [r4] + ldr r1, [r4, #4] + ldr r2, [r4, #8] + ldr r3, [r4, #12] + +{$ifdef FPUFPA} + (* load float regs *) + ldr r4, [r11, #-48] (* rfloat *) + ldfd f0, [r4] + ldfd f1, [r4, #8] + ldfd f2, [r4, #16] + ldfd f3, [r4, #24] +{$endif} + + (* branch to the proc pointer *) + ldr r4, [r11, #-52] + mov r14, r15 + mov r15, r4 +(* blx r4 *) + + ldr r4, [r11, #-64] (* get resulttype *) + cmp r4, #1 + blt int_result + beq int64_result + bgt float_result + +int_result: + str r0, [r11, #-72] + b asmcall_end + +int64_result: + str r0, [r11, #-72] + str r1, [r11, #-68] + b asmcall_end + +float_result: +{$ifdef FPUFPA} + stfd f0, [r11, #-72] +{$else} + b int64_result +{$endif} + b asmcall_end + +asmcall_end: + sub r0, r11, #72 (* return pointer to result on stack *) + + ldmea r11,{r4,r5,r6,r7,r8,r9,r10,r11,r13,r15} +end; + +function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean; +var + rint: Trint; { registers r0 to r3 } + rfloat: Trfloat; { registers f0 to f3 } + st: packed array of byte; { stack } + i, j, rindex, findex, stindex: integer; + fvar: PPSVariantIFC; + IsConstructor: Boolean; + + { add a dword to stack } + procedure addstackdword(value: dword); + begin + setlength(st, stindex+4); + pdword(@st[stindex])^ := value; + inc(stindex, 4); + end; + + { add a float to stack } + procedure addstackfloat(value: pointer; size: integer); + begin + setlength(st, stindex + (size * 4)); + if size = 1 + then psingle(@st[stindex])^ := single(value^) + else pdouble(@st[stindex])^ := double(value^); + inc(stindex, size*4); + end; + + { add to the general registers or overflow to stack } + procedure addgen(value: dword); + begin + if rindex <= 4 + then begin + rint[rindex] := value; + inc(rindex); + end + else begin + addstackdword(value); + end; + end; + { add to the float registers or overflow to stack } + { size = 1 for single, 2 for double } + procedure addfloat(value: pointer; size: integer); + begin + if findex <= 4 + then begin + if size = 1 + then rfloat[findex] := single(value^) + else rfloat[findex] := double(value^); + inc(findex); + end + else begin + addstackfloat(value, size); + end; + end; + +begin + if (Integer(CallingConv) and 64) <> 0 then begin + IsConstructor := true; + CAllingConv := TPSCallingConvention(Integer(CallingConv) and not 64); + end else IsConstructor := false; + + rindex := 1; + findex := 1; + stindex := 0; + setlength(st, stindex); + Result := False; + + { the pointer of the result needs to be passed first in the case of some result types } + if assigned(res) + then begin + case res.atype.basetype of + btStaticArray, btRecord: addgen(dword(res.dta)); + end; + end; + + { process all parameters } + for i := 0 to Params.Count-1 do begin + if Params[i] = nil + then Exit; + fvar := Params[i]; + + { cook dynamic arrays - fpc stores size-1 at @array-4 } + if (fvar.aType.BaseType = btArray) + then dec(pdword(pointer(fvar.dta^)-4)^); + + if fvar.varparam + then begin { var param } + case fvar.aType.BaseType of + { add var params here } + btArray, btVariant, btSet, btStaticArray, btRecord, btInterface, btClass, {$IFNDEF PS_NOWIDESTRING} btUnicodeString, btWideString, btWideChar, {$ENDIF} + btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency + {$IFNDEF PS_NOINT64}, bts64{$ENDIF}: addgen(dword(fvar.dta)); + else begin + writeln(stderr, 'Parameter type not recognised!'); + Exit; + end; + end; { case } + end else begin { not a var param } + case fvar.aType.BaseType of +// btArray, btVariant, btSet, btStaticArray, btRecord, btInterface, btClass, {$IFNDEF PS_NOWIDESTRING} btWideString, btWideChar, {$ENDIF} +// btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency +// {$IFNDEF PS_NOINT64}, bts64{$ENDIF}: writeln('normal param'); + + { add normal params here } + btString: addgen(dword(pstring(fvar.dta)^)); + btU8, btS8: addgen(dword(pbyte(fvar.dta)^)); + btU16, BtS16: addgen(dword(pword(fvar.dta)^)); + btU32, btS32: addgen(dword(pdword(fvar.dta)^)); + btSingle: {$ifdef FPUFPA} + addfloat(fvar.dta, 1); + {$else} + addgen(dword(psingle(fvar.dta)^)); + {$endif} + btDouble{, btExtended}: {$ifdef FPUFPA} + addfloat(fvar.dta, 2); + {$else} + begin + addgen(lo(qword(pdouble(fvar.dta)^))); + addgen(hi(qword(pdouble(fvar.dta)^))); + end; + {$endif} + btPChar: addgen(dword(ppchar(fvar.dta)^)); + btChar: addgen(dword(pchar(fvar.dta)^)); + {$IFNDEF PS_NOINT64}bts64:{$ENDIF} begin + addgen(dword(pint64(fvar.dta)^ and $ffffffff)); + addgen(dword(pint64(fvar.dta)^ shr 32)); + end; + btStaticArray: addgen(dword(fvar.dta)); + btRecord: for j := 0 to (fvar.atype.realsize div 4)-1 do + addgen(pdword(fvar.dta + j*4)^); + btArray: addstackdword(dword(fvar.dta^)); { this is a bit weird } + +{ btVariant, btSet, btInterface, btClass } + + else begin + writeln(stderr, 'Parameter type not implemented!'); + Exit; + end; + end; { case } + end; { else } + end; { for } + + if not assigned(res) + then begin + armasmcall(rint, rfloat, address, st, stindex, rtINT); { ignore return } + end + else begin + case res.atype.basetype of + { add result types here } + btString: pstring(res.dta)^ := pstring(armasmcall(rint, rfloat, address, st, stindex, rtINT))^; + btU8, btS8: pbyte(res.dta)^ := byte(pdword(armasmcall(rint, rfloat, address, st, stindex, rtINT))^); + btU16, btS16: pword(res.dta)^ := word(pdword(armasmcall(rint, rfloat, address, st, stindex, rtINT))^); + btU32, btS32: pdword(res.dta)^ := pdword(armasmcall(rint, rfloat, address, st, stindex, rtINT))^; + btSingle: psingle(res.dta)^ := pdouble(armasmcall(rint, rfloat, address, st, stindex, rtFLOAT))^; + btDouble{, btExtended}: pdouble(res.dta)^ := pdouble(armasmcall(rint, rfloat, address, st, stindex, rtFLOAT))^; + btPChar: ppchar(res.dta)^ := pchar(pdword(armasmcall(rint, rfloat, address, st, stindex, rtINT))^); + btChar: pchar(res.dta)^ := char(pdword(armasmcall(rint, rfloat, address, st, stindex, rtINT))^); + btStaticArray, btRecord: armasmcall(rint, rfloat, address, st, stindex, rtINT); + btArray: res.dta := armasmcall(rint, rfloat, address, st, stindex, rtINT); + + else begin + writeln(stderr, 'Result type not implemented!'); + exit; + end; { else } + end; { case } + end; + + { cook dynamic arrays - fpc stores size-1 at @array-4 } + for i := 0 to Params.Count-1 do begin + fvar := Params[i]; + if (fvar.aType.BaseType = btArray) + then inc(pdword(pointer(fvar.dta^)-4)^); + end; + + Result := True; +end; diff --git a/Units/PascalScript/eDefines.inc b/Units/PascalScript/eDefines.inc new file mode 100644 index 0000000..e98de3a --- /dev/null +++ b/Units/PascalScript/eDefines.inc @@ -0,0 +1,493 @@ +{----------------------------------------------------------------------------} +{file: eDefines.inc } +{type: Delphi include file } +{ } +{compiler: Borland Pascal 7, } +{ Delphi 1-7, 2005-2007 for Win32 } +{ Kylix 1-3, } +{ C++Builder 1-6, 2006-2007 } +{ Free Pascal Compiler 2.x } +{ } +{platforms: DOS, DPMI, Win16, Win32, Win64, Linux, Mac OS X } +{ } +{author: mh@elitedev.com } +{ } +{contents: Defines that can be flexibily used to determine the exact } +{ compiler version used. } +{ } +{(c)opyright elitedevelopments software. all rights reserved. } +{ http://www.elitedev.com } +{ } +{ Third Party component developers are encouraged to use the set of defines } +{ established in this file, rather then their own system, for checking their } +{ component libraries agains different versions of Delphi and C++Builder. } +{ } +{ This file may be distributed freely with both free and commercial source } +{ libraries, but you are asked to please leave this comment in place, and } +{ to return any improvements you make to this file to the maintainer that } +{ is noted above. } +{----------------------------------------------------------------------------} + +{----------------------------------------------------------------------------} +{ Compiler and OS version defines: } +{ } +{ exact compiler versions: } +{ } +{ BP7 Borland Pascal 7.0 } +{ DELPHI1 Delphi 1.0 (any Delphi) } +{ DELPHI2 Delphi 2.0 } +{ DELPHI3 Delphi 3.0 } +{ DELPHI4 Delphi 4.0 } +{ DELPHI5 Delphi 5.0 } +{ DELPHI6 Delphi 6.0 } +{ DELPHI7 Delphi 7.0 } +{ DELPHI9 Delphi 2005 } +{ DELPHI2005 Delphi 2005 } +{ DELPHI2006 Delphi 2006 } +{ DELPHI2007 Delphi 2007 } +{ KYLIX1 Kylix 1.0 } +{ KYLIX2 Kylix 2.0 } +{ KYLIX3 Kylix 3.0 } +{ CBUILDER1 C++Builder 1.0 } +{ CBUILDER3 C++Builder 3.0 } +{ CBUILDER4 C++Builder 4.0 } +{ CBUILDER5 C++Builder 5.0 } +{ } +{ } +{ minimum compiler versions: } +{ } +{ DELPHI1UP Delphi 1.0 and above (any Delphi) } +{ DELPHI2UP Delphi 2.0 and above } +{ DELPHI3UP Delphi 3.0 and above } +{ DELPHI4UP Delphi 4.0 and above } +{ DELPHI5UP Delphi 5.0 and above } +{ DELPHI6UP Delphi 6.0 and above } +{ DELPHI7UP Delphi 7.0 and above } +{ DELPHI9UP Delphi 9.0 (2005) and above } +{ DELPHI10UP Delphi 10.0 (2006) and above } +{ DELPHI11UP Delphi 11.0 (2007) and above } +{ DELPHI2005UP Delphi 2005 and above } +{ DELPHI2006UP Delphi 2006 and above } +{ DELPHI2007UP Delphi 2007 and above } +{ KYLIX1UP Kylix 1.0 and above (any Kylix) } +{ KYLIX2UP Kylix 2.0 and above (any Kylix) } +{ KYLIX3UP Kylix 3.0 and above (any Kylix) } +{ CBUILDER1UP C++Builder 1.0 and above or Delphi 2 and above } +{ CBUILDER3UP C++Builder 3.0 and above or Delphi 3.0 and above } +{ CBUILDER4UP C++Builder 4.0 and above or Delphi 4.0 and above } +{ CBUILDER5UP C++Builder 5.0 and above or Delphi 5.0 and above } +{ CBUILDER6UP C++Builder 5.0 and above or Delphi 5.0 and above } +{ } +{ } +{ compiler types: } +{ } +{ BP Borland Pascal (not Delphi or C++Builder) } +{ DELPHI any Delphi version (but not C++Builder or Kylix) } +{ KYLIX any Kylix version (not Delphi or C++Builder for Windows) } +{ CBUILDER any C++Builder for Windows (Pascal) } +{ } +{ } +{ target platforms compiler types: } +{ } +{ DELPHI_16BIT 16bit Delphi (but not C++Builder!) } +{ DELPHI_32BIT 32bit Delphi (but not C++Builder) } +{ KYLIX_32BIT 32bit Kylix (but not C++Builder) } +{ CBUILDER_32BIT 32bit C++Builer's Pascal (but not Delphi) } +{ } +{ } +{ target cpu types } +{ } +{ CPU16 16bit Delphi or Borland Pascal } +{ CPU32 32bit Delphi or Free Pascal } +{ CPU64 64bit Free Pascal } +{ } +{ target platforms } +{ } +{ DOS any DOS (plain and DPMI) } +{ REALMODE 16bit realmode DOS } +{ PROTECTEDMODE 16bit DPMI DOS } +{ } +{ MSWINDOWS any Windows platform } +{ WIN16 16bit Windows } +{ WIN32 32bit Windows } +{ WIN64 64bit Windows } +{ DOTNET .NET } +{ } +{ LINUX any Linux platform } +{ LINUX32 32bit Linux } +{ LINUX64 64bit Linux } +{ } +{ DARWIN Any Mac OS X } +{ DARWIN32 32bit Mac OS X } +{ DARWIN64 64bit Mac OS X } +{----------------------------------------------------------------------------} + +{ defines for Borland Pascal 7.0 } +{$IFDEF VER70} + {$DEFINE BP} + {$DEFINE BP7} + {$DEFINE 16BIT} + {$DEFINE CPU16} + + { defines for BP7 DOS real mode } + {$IFDEF MSDOS} + {$DEFINE DOS} + {$DEFINE REALMODE} + {$ENDIF} + + { defines for BP7 DOS protected mode } + {$IFDEF DPMI} + {$DEFINE DOS} + {$DEFINE PROTECTEDMODE} + {$ENDIF} + + { defines for BP7 Windows } + {$IFDEF WINDOWS} + {$DEFINE MSWINDOWS} + {$DEFINE WIN16} + {$ENDIF} +{$ENDIF} + +{ defines for Delphi 1.0 thru 7.0 } +{$IFDEF MSWINDOWS} + + { defines for Delphi 1.0 } + {$IFDEF VER80} + {$DEFINE DELPHI} + {$DEFINE DELPHI1} + {$DEFINE DELPHI1UP} + {$DEFINE DELPHI_16BIT} + {$DEFINE WIN16} + {$DEFINE 16BIT} + {$DEFINE CPU16} + {$ENDIF} + + { defines for Delphi 2.0 } + {$IFDEF VER90} + {$DEFINE DELPHI} + {$DEFINE DELPHI2} + {$DEFINE DELPHI1UP} + {$DEFINE DELPHI2UP} + {$ENDIF} + + { defines for C++Builder 1.0 } + {$IFDEF VER93} + {$DEFINE DELPHI1UP} + {$DEFINE DELPHI2UP} + {$DEFINE CBUILDER} + {$DEFINE CBUILDER1} + {$DEFINE CBUILDER1UP} + {$ENDIF} + + { defines for Delphi 3.0 } + {$IFDEF VER100} + {$DEFINE DELPHI} + {$DEFINE DELPHI3} + {$DEFINE DELPHI1UP} + {$DEFINE DELPHI2UP} + {$DEFINE DELPHI3UP} + {$ENDIF} + + { defines for C++Builder 3.0 } + {$IFDEF VER110} + {$DEFINE DELPHI1UP} + {$DEFINE DELPHI2UP} + {$DEFINE DELPHI3UP} + {$DEFINE CBUILDER} + {$DEFINE CBUILDER3} + {$DEFINE CBUILDER1UP} + {$DEFINE CBUILDER3UP} + {$ENDIF} + + { defines for Delphi 4.0 } + {$IFDEF VER120} + {$DEFINE DELPHI} + {$DEFINE DELPHI4} + {$DEFINE DELPHI1UP} + {$DEFINE DELPHI2UP} + {$DEFINE DELPHI3UP} + {$DEFINE DELPHI4UP} + {$ENDIF} + + { defines for C++Builder 4.0 } + {$IFDEF VER125} + {$DEFINE DELPHI1UP} + {$DEFINE DELPHI2UP} + {$DEFINE DELPHI3UP} + {$DEFINE DELPHI4UP} + {$DEFINE CBUILDER} + {$DEFINE CBUILDER4} + {$DEFINE CBUILDER1UP} + {$DEFINE CBUILDER3UP} + {$DEFINE CBUILDER4UP} + {$ENDIF} + { defines for Delphi 5.0 } + {$IFDEF VER130} + {$DEFINE DELPHI} + {$DEFINE DELPHI5} + {$DEFINE DELPHI1UP} + {$DEFINE DELPHI2UP} + {$DEFINE DELPHI3UP} + {$DEFINE DELPHI4UP} + {$DEFINE DELPHI5UP} + {$ENDIF} + + { defines for C++Builder 5.0 } + {$IFDEF VER135} + {$DEFINE DELPHI1UP} + {$DEFINE DELPHI2UP} + {$DEFINE DELPHI3UP} + {$DEFINE DELPHI4UP} + {$DEFINE DELPHI5UP} + {$DEFINE CBUILDER} + {$DEFINE CBUILDER5} + {$DEFINE CBUILDER1UP} + {$DEFINE CBUILDER3UP} + {$DEFINE CBUILDER4UP} + {$DEFINE CBUILDER5UP} + {$ENDIF} + + { defines for Delphi 6.0 } + {$IFDEF VER140} + {$DEFINE VER140UP} + {$DEFINE DELPHI} + {$DEFINE DELPHI6} + {$DEFINE DELPHI1UP} + {$DEFINE DELPHI2UP} + {$DEFINE DELPHI3UP} + {$DEFINE DELPHI4UP} + {$DEFINE DELPHI5UP} + {$DEFINE DELPHI6UP} + {$ENDIF} + + { defines for Delphi 7.0 } + {$IFDEF VER150} + {$DEFINE VER140UP} + {$DEFINE DELPHI} + {$DEFINE DELPHI7} + {$DEFINE DELPHI1UP} + {$DEFINE DELPHI2UP} + {$DEFINE DELPHI3UP} + {$DEFINE DELPHI4UP} + {$DEFINE DELPHI5UP} + {$DEFINE DELPHI6UP} + {$DEFINE DELPHI7UP} + {$ENDIF} + + { defines for Delphi 2005 } + {$IFDEF VER170} + {$DEFINE VER140UP} + {$DEFINE DELPHI} + {$DEFINE DELPHI9} + {$DEFINE DELPHI2005} + {$DEFINE DELPHI1UP} + {$DEFINE DELPHI2UP} + {$DEFINE DELPHI3UP} + {$DEFINE DELPHI4UP} + {$DEFINE DELPHI5UP} + {$DEFINE DELPHI6UP} + {$DEFINE DELPHI7UP} + {$DEFINE DELPHI9UP} + {$DEFINE DELPHI2005UP} + {$DEFINE BDS} + {$DEFINE BDS3} + {$DEFINE BDS3UP} + {$ENDIF} + + { defines for Delphi 2006 } + {$IFDEF VER180} + {$DEFINE VER140UP} + {$DEFINE DELPHI} + {$DEFINE DELPHI10} + {$DEFINE DELPHI10A} + {$DEFINE DELPHI2006} + {$DEFINE DELPHI1UP} + {$DEFINE DELPHI2UP} + {$DEFINE DELPHI3UP} + {$DEFINE DELPHI4UP} + {$DEFINE DELPHI5UP} + {$DEFINE DELPHI6UP} + {$DEFINE DELPHI7UP} + {$DEFINE DELPHI9UP} + {$DEFINE DELPHI10UP} + {$DEFINE DELPHI2005UP} + {$DEFINE DELPHI2006UP} + {$DEFINE BDS} + {$DEFINE BDS4} + {$DEFINE BDS3UP} + {$DEFINE BDS4UP} + {$ENDIF} + + { defines for Delphi 2007 } + {$IFDEF VER185} + {$UNDEF DELPHI10A} // declared in VER180 + {$UNDEF DELPHI2006} // declared in VER180 + {$UNDEF BDS4} // declared in VER180 + + {$DEFINE DELPHI10B} + {$DEFINE DELPHI10BUP} + {$DEFINE DELPHI11} + {$DEFINE DELPHI11UP} + {$DEFINE DELPHI2007} + {$DEFINE DELPHI2007UP} + {$DEFINE BDS5} + {$DEFINE BDS5UP} + {$ENDIF} + + { defines for Delphi 2009 } + {$IFDEF VER200} + {$DEFINE VER140UP} + {$DEFINE DELPHI} + + {$DEFINE DELPHI12} + {$DEFINE DELPHI1UP} + {$DEFINE DELPHI2UP} + {$DEFINE DELPHI3UP} + {$DEFINE DELPHI4UP} + {$DEFINE DELPHI5UP} + {$DEFINE DELPHI6UP} + {$DEFINE DELPHI7UP} + {$DEFINE DELPHI9UP} + {$DEFINE DELPHI10UP} + {$DEFINE DELPHI11UP} + {$DEFINE DELPHI12UP} + + {$DEFINE DELPHI2009} + {$DEFINE DELPHI2005UP} + {$DEFINE DELPHI2006UP} + {$DEFINE DELPHI2007UP} + {$DEFINE DELPHI2009UP} + + {$DEFINE BDS} + {$DEFINE BDS6} + {$DEFINE BDS3UP} + {$DEFINE BDS4UP} + {$DEFINE BDS5UP} + {$DEFINE BDS6UP} + {$ENDIF} + + { defines for Delphi 2010 } + {$IFDEF VER210} + {$DEFINE VER140UP} + {$DEFINE DELPHI} + + {$DEFINE DELPHI14} + {$DEFINE DELPHI1UP} + {$DEFINE DELPHI2UP} + {$DEFINE DELPHI3UP} + {$DEFINE DELPHI4UP} + {$DEFINE DELPHI5UP} + {$DEFINE DELPHI6UP} + {$DEFINE DELPHI7UP} + {$DEFINE DELPHI9UP} + {$DEFINE DELPHI10UP} + {$DEFINE DELPHI11UP} + {$DEFINE DELPHI12UP} + {$DEFINE DELPHI14UP} + + {$DEFINE DELPHI2010} + {$DEFINE DELPHI2005UP} + {$DEFINE DELPHI2006UP} + {$DEFINE DELPHI2007UP} + {$DEFINE DELPHI2009UP} + {$DEFINE DELPHI2010UP} + + {$DEFINE BDS} + {$DEFINE BDS7} + {$DEFINE BDS3UP} + {$DEFINE BDS4UP} + {$DEFINE BDS5UP} + {$DEFINE BDS6UP} + {$DEFINE BDS7UP} + {$ENDIF} + + + {$IFDEF WIN32} + {$DEFINE MSWINDOWS} //not automatically defined for Delphi 2 thru 5 + {$DEFINE 32BIT} + {$DEFINE CPU32} + {$ENDIF} + +{$ENDIF MSWINDOWS} + +{ defines for "Delphi for .NET" } +{$IFDEF CLR} + {$DEFINE DOTNET} +{$ENDIF} + +{$IFDEF DELPHI} + {$IFDEF DELPHI2UP} + {$DEFINE DELPHI_32BIT} + {$ENDIF} +{$ENDIF} + +{$IFDEF CBUILDER} + {$DEFINE CBUILDER_32BIT} +{$ENDIF} + +{$IFNDEF FPC} + + { Kylix 1.0 thru 3.0 } + {$IFDEF LINUX} + + {$DEFINE VER140UP} + + { Any Kylix } + {$DEFINE 32BIT} + {$DEFINE LINUX32} + {$DEFINE KYLIX_32BIT} + {$DEFINE KYLIX} + {$DEFINE KYLIX1UP} + + {$IFDEF CONDITIONALEXPRESSIONS} + {$IF Declared(CompilerVersion)} + + { Kylix 2.0 } + {$IF Declared(RTLVersion) and (RTLVersion = 14.1)} + {$DEFINE KYLIX2} + {$DEFINE KYLIX1UP} + {$DEFINE KYLIX2UP} + {$IFEND} + + { Kylix 3.0 - Delphi portion } + {$IF Declared(RTLVersion) and (RTLVersion = 14.5)} + {$DEFINE KYLIX3} + {$DEFINE KYLIX1UP} + {$DEFINE KYLIX2UP} + {$DEFINE KYLIX3UP} + {$IFEND} + + { Kylix 1.0 } + {$ELSE} + {$DEFINE KYLIX1} + {$IFEND} + {$ENDIF CONDITIONALEXPRESSIONS} + + {$ENDIF LINUX} +{$ENDIF} + +{ CPU } + +{$IFDEF FPC} + {$IFDEF MSWINDOWS} + {$IFDEF CPU64} + {$DEFINE WIN64} + {$ENDIF} + {$ENDIF} + {$IFDEF LINUX} + {$IFDEF CPU32} + {$DEFINE LINUX32} + {$ENDIF} + {$IFDEF CPU64} + {$DEFINE LINUX64} + {$ENDIF} + {$ENDIF} + {$IFDEF DARWIN} + {$IFDEF CPU32} + {$DEFINE DARWIN32} + {$ENDIF} + {$IFDEF CPU64} + {$DEFINE DARWIN64} + {$ENDIF} + {$ENDIF} +{$ENDIF} \ No newline at end of file diff --git a/Units/PascalScript/pascalscript.pas b/Units/PascalScript/pascalscript.pas new file mode 100644 index 0000000..d5bf447 --- /dev/null +++ b/Units/PascalScript/pascalscript.pas @@ -0,0 +1,29 @@ +{ This file was automatically created by Lazarus. Do not edit! +This source is only used to compile and install the package. + } + +unit PascalScript; + +interface + +uses + uPSRuntime, PascalScript_Core_Reg, uPSC_buttons, uPSC_classes, uPSC_controls, + uPSC_dateutils, uPSC_DB, uPSC_dll, uPSC_extctrls, uPSC_forms, + uPSC_graphics, uPSC_menus, uPSC_std, uPSC_stdctrls, uPSCompiler, + uPSComponent, uPSComponent_Controls, uPSComponent_DB, uPSComponent_Default, + uPSComponent_Forms, uPSComponent_StdCtrls, uPSComponentExt, uPSDebugger, + uPSDisassembly, uPSPreProcessor, uPSR_buttons, uPSR_classes, uPSR_controls, + uPSR_dateutils, uPSR_DB, uPSR_dll, uPSR_extctrls, uPSR_forms, + uPSR_graphics, uPSR_menus, uPSR_std, uPSR_stdctrls, uPSUtils, + LazarusPackageIntf; + +implementation + +procedure Register; +begin + RegisterUnit('PascalScript_Core_Reg', @PascalScript_Core_Reg.Register); +end; + +initialization + RegisterPackage('PascalScript', @Register); +end. diff --git a/Units/PascalScript/powerpc.inc b/Units/PascalScript/powerpc.inc new file mode 100644 index 0000000..ec0c779 --- /dev/null +++ b/Units/PascalScript/powerpc.inc @@ -0,0 +1,343 @@ +{ implementation of the powerpc osx abi for function calls in pascal script + Copyright (c) 2007 by Henry Vermaak (henry.vermaak@gmail.com) } + +{$ifndef darwin} + {$fatal This code is Darwin specific at the moment!} +{$endif} + +{$ifndef cpu32} + {$fatal This code is 32bit specific at the moment!} +{$endif} + +const + rtINT = 0; + rtINT64 = 1; + rtFLOAT = 2; + +type + Trint = array[1..8] of dword; + Trfloat = array[1..13] of double; + +{$goto on} +{ define labels } +label + rfloat_loop, + stack_loop, + load_regs, + int_result, + int64_result, + float_result, + asmcall_end; + +{ call a function from a pointer } +{ resulttype: 0 = int, 1 = int64, 2 = float } +function ppcasmcall(rint: Trint; rfloat: Trfloat; proc, stack: pointer; stacksize, resulttype: integer): pointer; assembler; nostackframe; +asm + mflr r0 + stw r0, 8(r1) + + { save non-volatile register/s - make sure the stack size is sufficient! } + stw r31, -4(r1) { stacksize } + + stwu r1, -240(r1) { create stack } + + { get all the params into the stack } + stw r3, 48(r1) { rint } + stw r4, 52(r1) { rfloat } + stw r5, 56(r1) { proc } + stw r6, 60(r1) { stack } + stw r7, 64(r1) { stacksize } + stw r8, 68(r1) { resulttype } + { result is stored in 72(r1) and 76(r1) (if returning int64) } + + { write rint array into stack } + lwz r2, 48(r1) { rint } + lfd f0, 0(r2) + stfd f0, 80(r1) { rint[1], rint[2] } + lfd f0, 8(r2) + stfd f0, 88(r1) { rint[3], rint[4] } + lfd f0, 16(r2) + stfd f0, 96(r1) { rint[5], rint[6] } + lfd f0, 24(r2) + stfd f0, 104(r1) { rint[7], rint[8] } + + { write rfloat array into stack } + lwz r2, 52(r1) { rfloat } + addi r4, r1, 112 { rfloat[1] from here upwards (8 bytes apart) } + subi r2, r2, 8 { src } + subi r4, r4, 8 { dest } + li r3, 13 { counter } + +rfloat_loop: + subic. r3, r3, 1 { dec counter } + lfdu f0, 8(r2) { load rfloat[x] + update } + stfdu f0, 8(r4) { store rfloat[x] + update } + bne cr0, rfloat_loop + + { create new stack } + mflr r0 + stw r0, 8(r1) + mr r12, r1 { remember previous stack to fill in regs later } + + lwz r31, 64(r12) { load stacksize into r31 } + neg r3, r31 { negate } + stwux r1, r1, r3 { create new stack } + + { build up the stack here } + mr r3, r31 { counter } + subic. r3, r3, 24 { don't write first 24 } + blt cr0, load_regs { don't fill in stack if there is none } + + lwz r2, 60(r12) { pointer to stack } + addi r2, r2, 24 { start of params } + subi r2, r2, 1 { src } + + addi r4, r1, 24 { start of params } + subi r4, r4, 1 { dest } + +stack_loop: + subic. r3, r3, 1 { dec counter } + lbzu r5, 1(r2) { load stack + update } + stbu r5, 1(r4) { store stack + update } + bne cr0, stack_loop + +load_regs: { now load the registers from the previous stack in r12 } + lwz r3, 80(r12) + lwz r4, 84(r12) + lwz r5, 88(r12) + lwz r6, 92(r12) + lwz r7, 96(r12) + lwz r8, 100(r12) + lwz r9, 104(r12) + lwz r10, 108(r12) + + lfd f1, 112(r12) + lfd f2, 120(r12) + lfd f3, 128(r12) + lfd f4, 136(r12) + lfd f5, 144(r12) + lfd f6, 152(r12) + lfd f7, 160(r12) + lfd f8, 168(r12) + lfd f9, 176(r12) + lfd f10, 184(r12) + lfd f11, 192(r12) + lfd f12, 200(r12) + lfd f13, 208(r12) + + { now call this function } + lwz r2, 56(r12) { proc } + mtctr r2 { move to ctr } + bctrl { branch and link to ctr } + + { restore stack - use stacksize in r31 } + add r1, r1, r31 + lwz r0, 8(r1) + mtlr r0 + + { check resulttype and put appropriate pointer into r3 } + lwz r2, 68(r1) { resulttype } + cmpwi cr0, r2, 0 { int result? } + beq cr0, int_result { branch if equal } + + cmpwi cr0, r2, 1 { single result? } + beq cr0, int64_result { branch if equal } + + +float_result: { the result is a double} + stfd f1, 72(r1) { write f1 to result on stack } + b asmcall_end + + +int64_result: { the result is a single } + stw r3, 72(r1) { write high dword to result on stack } + stw r4, 76(r1) { write low dword to result on stack } + b asmcall_end + + +int_result: { the result is dword } + stw r3, 72(r1) { write r3 to result on stack } + + +asmcall_end: { epilogue } + addi r3, r1, 72 { pointer to result on the stack } + addi r1, r1, 240 { restore stack } + + { restore non-volatile register/s } + lwz r31, -4(r1) + + lwz r0, 8(r1) + mtlr r0 + blr +end; + +function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean; +var + rint: Trint; { registers r3 to r10 } + rfloat: Trfloat; { registers f1 to f13 } + st: packed array of byte; { stack } + i, j, rindex, findex, stindex: integer; + fvar: PPSVariantIFC; + IsConstructor: Boolean; + { add a dword to stack } + procedure addstackdword(value: dword); + begin + setlength(st, stindex+4); + pdword(@st[stindex])^ := value; + inc(stindex, 4); + end; + + { add a float to stack } + procedure addstackfloat(value: pointer; size: integer); + begin + setlength(st, stindex + (size * 4)); + if size = 1 + then psingle(@st[stindex])^ := single(value^) + else pdouble(@st[stindex])^ := double(value^); + inc(stindex, size*4); + end; + + { add to the general registers or overflow to stack } + procedure addgen(value: dword); + begin + if rindex <= 8 + then begin + rint[rindex] := value; + inc(rindex); + addstackdword(value); + end + else begin + addstackdword(value); + end; + end; + { add to the float registers or overflow to stack } + { size = 1 for single, 2 for double } + procedure addfloat(value: pointer; size: integer); + begin + if findex <= 13 + then begin + if size = 1 + then rfloat[findex] := single(value^) + else rfloat[findex] := double(value^); + inc(findex); + inc(rindex, size); + addstackfloat(value, size); + end + else begin + addstackfloat(value, size); + end; + end; + +begin + if (Integer(CallingConv) and 64) <> 0 then begin + IsConstructor := true; + CAllingConv := TPSCallingConvention(Integer(CallingConv) and not 64); + end else IsConstructor := false; + + rindex := 1; + findex := 1; + stindex := 24; + setlength(st, stindex); + Result := False; + + { the pointer of the result needs to be passed first in the case of some result types } + if assigned(res) + then begin + case res.atype.basetype of + btStaticArray, btRecord: addgen(dword(res.dta)); + end; + end; + + { process all parameters } + for i := 0 to Params.Count-1 do begin + if Params[i] = nil + then Exit; + fvar := Params[i]; + + { cook dynamic arrays - fpc stores size-1 at @array-4 } + if (fvar.aType.BaseType = btArray) + then dec(pdword(pointer(fvar.dta^)-4)^); + + if fvar.varparam + then begin { var param } + case fvar.aType.BaseType of + { add var params here } + btArray, btVariant, btSet, btStaticArray, btRecord, btInterface, btClass, {$IFNDEF PS_NOWIDESTRING} btWideString, btWideChar, {$ENDIF} + btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency + {$IFNDEF PS_NOINT64}, bts64{$ENDIF}: addgen(dword(fvar.dta)); { TODO: test all } + else begin + writeln(stderr, 'Parameter type not recognised!'); + Exit; + end; + end; { case } + end else begin { not a var param } + case fvar.aType.BaseType of +// btArray, btVariant, btSet, btStaticArray, btRecord, btInterface, btClass, {$IFNDEF PS_NOWIDESTRING} btWideString, btWideChar, {$ENDIF} +// btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency +// {$IFNDEF PS_NOINT64}, bts64{$ENDIF}: writeln('normal param'); + + { add normal params here } + btString: addgen(dword(pstring(fvar.dta)^)); + btU8, btS8: addgen(dword(pbyte(fvar.dta)^)); + btU16, BtS16: addgen(dword(pword(fvar.dta)^)); + btU32, btS32: addgen(dword(pdword(fvar.dta)^)); + btSingle: addfloat(fvar.dta, 1); + btDouble, btExtended: addfloat(fvar.dta, 2); + btPChar: addgen(dword(ppchar(fvar.dta)^)); + btChar: addgen(dword(pchar(fvar.dta)^)); + {$IFNDEF PS_NOINT64}bts64:{$ENDIF} begin + addgen(dword(pint64(fvar.dta)^ shr 32)); + addgen(dword(pint64(fvar.dta)^ and $ffffffff)); + end; + btStaticArray: addgen(dword(fvar.dta)); + btRecord: for j := 0 to (fvar.atype.realsize div 4)-1 do + addgen(pdword(fvar.dta + j*4)^); + btArray: addgen(dword(fvar.dta^)); + + { TODO add and test } +{ btVariant, btSet, btInterface, btClass } + + else begin + writeln(stderr, 'Parameter type not implemented!'); + Exit; + end; + end; { case } + end; { else } + end; { for } + + if not assigned(res) + then begin + ppcasmcall(rint, rfloat, address, st, stindex, rtINT); { ignore return } + end + else begin + case res.atype.basetype of + { add result types here } + btString: pstring(res.dta)^ := pstring(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^; + btU8, btS8: pbyte(res.dta)^ := byte(pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^); + btU16, btS16: pword(res.dta)^ := word(pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^); + btU32, btS32: pdword(res.dta)^ := pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^; + btSingle: psingle(res.dta)^ := pdouble(ppcasmcall(rint, rfloat, address, st, stindex, rtFLOAT))^; + btDouble, btExtended: pdouble(res.dta)^ := pdouble(ppcasmcall(rint, rfloat, address, st, stindex, rtFLOAT))^; + btPChar: ppchar(res.dta)^ := pchar(pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^); + btChar: pchar(res.dta)^ := char(pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^); + btStaticArray, btRecord: ppcasmcall(rint, rfloat, address, st, stindex, rtINT); + btArray: res.dta := ppcasmcall(rint, rfloat, address, st, stindex, rtINT); + + { TODO add and test } + + else begin + writeln(stderr, 'Result type not implemented!'); + exit; + end; { else } + end; { case } + end; + + { cook dynamic arrays - fpc stores size-1 at @array-4 } + for i := 0 to Params.Count-1 do begin + fvar := Params[i]; + if (fvar.aType.BaseType = btArray) + then inc(pdword(pointer(fvar.dta^)-4)^); + end; + + Result := True; +end; diff --git a/Units/PascalScript/uPSC_DB.pas b/Units/PascalScript/uPSC_DB.pas new file mode 100644 index 0000000..3a0cc81 --- /dev/null +++ b/Units/PascalScript/uPSC_DB.pas @@ -0,0 +1,892 @@ +{ Compiletime DB support } +Unit uPSC_DB; +{ +This file has been generated by UnitParser v0.4, written by M. Knight. +Source Code from Carlo Kok has been used to implement various sections of +UnitParser. Components of ifps3 are used in the construction of UnitParser, +code implementing the class wrapper is taken from Carlo Kok''s conv unility + +Licence : +This software is provided 'as-is', without any expressed or implied +warranty. In no event will the author be held liable for any damages +arising from the use of this software. +Permission is granted to anyone to use this software for any kind of +application, and to alter it and redistribute it freely, subject to +the following restrictions: +1. The origin of this software must not be misrepresented, you must + not claim that you wrote the original software. +2. Altered source versions must be plainly marked as such, and must + not be misrepresented as being the original software. +3. You may not create a library that uses this library as a main part + of the program and sell that library. +4. You must have a visible line in your programs aboutbox or + documentation that it is made using Innerfuse Script and where + Innerfuse Pascal Script can be found. +5. This notice may not be removed or altered from any source + distribution. + +If you have any questions concerning this license write to Carlo Kok: + ck@carlo-kok.com or try the newsserver: + news://news.carlo-kok.com/ +} +{$I PascalScript.inc} +Interface +uses + uPSCompiler; + +procedure SIRegisterTDATASET(CL: TPSPascalCompiler); +procedure SIRegisterTPARAMS(CL: TPSPascalCompiler); +procedure SIRegisterTPARAM(CL: TPSPascalCompiler); +procedure SIRegisterTGUIDFIELD(CL: TPSPascalCompiler); +procedure SIRegisterTVARIANTFIELD(CL: TPSPascalCompiler); +procedure SIRegisterTREFERENCEFIELD(CL: TPSPascalCompiler); +procedure SIRegisterTDATASETFIELD(CL: TPSPascalCompiler); +procedure SIRegisterTARRAYFIELD(CL: TPSPascalCompiler); +procedure SIRegisterTADTFIELD(CL: TPSPascalCompiler); +procedure SIRegisterTOBJECTFIELD(CL: TPSPascalCompiler); +procedure SIRegisterTGRAPHICFIELD(CL: TPSPascalCompiler); +procedure SIRegisterTMEMOFIELD(CL: TPSPascalCompiler); +procedure SIRegisterTBLOBFIELD(CL: TPSPascalCompiler); +{$IFDEF DELPHI6UP} +procedure SIRegisterTFMTBCDFIELD(CL: TPSPascalCompiler); +{$ENDIF} +procedure SIRegisterTBCDFIELD(CL: TPSPascalCompiler); +procedure SIRegisterTVARBYTESFIELD(CL: TPSPascalCompiler); +procedure SIRegisterTBYTESFIELD(CL: TPSPascalCompiler); +procedure SIRegisterTBINARYFIELD(CL: TPSPascalCompiler); +procedure SIRegisterTTIMEFIELD(CL: TPSPascalCompiler); +procedure SIRegisterTDATEFIELD(CL: TPSPascalCompiler); +procedure SIRegisterTDATETIMEFIELD(CL: TPSPascalCompiler); +procedure SIRegisterTBOOLEANFIELD(CL: TPSPascalCompiler); +procedure SIRegisterTCURRENCYFIELD(CL: TPSPascalCompiler); +procedure SIRegisterTFLOATFIELD(CL: TPSPascalCompiler); +procedure SIRegisterTAUTOINCFIELD(CL: TPSPascalCompiler); +procedure SIRegisterTWORDFIELD(CL: TPSPascalCompiler); +procedure SIRegisterTLARGEINTFIELD(CL: TPSPascalCompiler); +procedure SIRegisterTSMALLINTFIELD(CL: TPSPascalCompiler); +procedure SIRegisterTINTEGERFIELD(CL: TPSPascalCompiler); +procedure SIRegisterTNUMERICFIELD(CL: TPSPascalCompiler); +procedure SIRegisterTWIDESTRINGFIELD(CL: TPSPascalCompiler); +procedure SIRegisterTSTRINGFIELD(CL: TPSPascalCompiler); +procedure SIRegisterTFIELD(CL: TPSPascalCompiler); +procedure SIRegisterTLOOKUPLIST(CL: TPSPascalCompiler); +procedure SIRegisterTFIELDS(CL: TPSPascalCompiler); +procedure SIRegisterTFIELDLIST(CL: TPSPascalCompiler); +procedure SIRegisterTFIELDDEFLIST(CL: TPSPascalCompiler); +procedure SIRegisterTFLATLIST(CL: TPSPascalCompiler); +procedure SIRegisterTINDEXDEFS(CL: TPSPascalCompiler); +procedure SIRegisterTINDEXDEF(CL: TPSPascalCompiler); +procedure SIRegisterTFIELDDEFS(CL: TPSPascalCompiler); +procedure SIRegisterTFIELDDEF(CL: TPSPascalCompiler); +procedure SIRegisterTDEFCOLLECTION(CL: TPSPascalCompiler); +procedure SIRegisterTNAMEDITEM(CL: TPSPascalCompiler); +procedure SIRegister_DB(Cl: TPSPascalCompiler); + +implementation +Uses Sysutils; + +Function RegClassS(cl : TPSPascalCompiler;Const InheritsFrom,Classname : String) : TPSCompileTimeClass; +begin +Result := cl.FindClass(Classname); +if Result = nil then + Result := cl.AddClassN(cl.FindClass(InheritsFrom),Classname) +else + Result.ClassInheritsFrom := cl.FindClass(InheritsFrom); +end; + +procedure SIRegisterTDATASET(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TCOMPONENT','TDATASET') do + begin + RegisterMethod('Function ACTIVEBUFFER : PCHAR'); + RegisterMethod('Procedure APPEND'); + RegisterMethod('Procedure APPENDRECORD( const VALUES : array of const)'); +// RegisterMethod('Function BOOKMARKVALID( BOOKMARK : TBOOKMARK) : BOOLEAN'); + RegisterMethod('Procedure CANCEL'); + RegisterMethod('Procedure CHECKBROWSEMODE'); + RegisterMethod('Procedure CLEARFIELDS'); + RegisterMethod('Procedure CLOSE'); + RegisterMethod('Function CONTROLSDISABLED : BOOLEAN'); +// RegisterMethod('Function COMPAREBOOKMARKS( BOOKMARK1, BOOKMARK2 : TBOOKMARK) : INTEGER'); + RegisterMethod('Function CREATEBLOBSTREAM( FIELD : TFIELD; MODE : TBLOBSTREAMMODE) : TSTREAM'); + RegisterMethod('Procedure CURSORPOSCHANGED'); + RegisterMethod('Procedure DELETE'); + RegisterMethod('Procedure DISABLECONTROLS'); + RegisterMethod('Procedure EDIT'); + RegisterMethod('Procedure ENABLECONTROLS'); +{$IFDEF DELPHI2006UP} + RegisterMethod('Function FIELDBYNAME( const FIELDNAME : WIDESTRING) : TFIELD'); + RegisterMethod('Function FINDFIELD( const FIELDNAME : WideString) : TFIELD'); +{$ELSE} + RegisterMethod('Function FIELDBYNAME( const FIELDNAME : STRING) : TFIELD'); + RegisterMethod('Function FINDFIELD( const FIELDNAME : STRING) : TFIELD'); +{$ENDIF} + RegisterMethod('Function FINDFIRST : BOOLEAN'); + RegisterMethod('Function FINDLAST : BOOLEAN'); + RegisterMethod('Function FINDNEXT : BOOLEAN'); + RegisterMethod('Function FINDPRIOR : BOOLEAN'); + RegisterMethod('Procedure FIRST'); +// RegisterMethod('Procedure FREEBOOKMARK( BOOKMARK : TBOOKMARK)'); +// RegisterMethod('Function GETBOOKMARK : TBOOKMARK'); + RegisterMethod('Function GETCURRENTRECORD( BUFFER : PCHAR) : BOOLEAN'); +// RegisterMethod('Procedure GETDETAILDATASETS( LIST : TLIST)'); +// RegisterMethod('Procedure GETFIELDLIST( LIST : TLIST; const FIELDNAMES : STRING)'); +// RegisterMethod('Procedure GETDETAILLINKFIELDS( MASTERFIELDS, DETAILFIELDS : TLIST)'); +// RegisterMethod('Function GETBLOBFIELDDATA( FIELDNO : INTEGER; var BUFFER : TBLOBBYTEDATA) : INTEGER'); + RegisterMethod('Procedure GETFIELDNAMES( LIST : TSTRINGS)'); +// RegisterMethod('Procedure GOTOBOOKMARK( BOOKMARK : TBOOKMARK)'); + RegisterMethod('Procedure INSERT'); + RegisterMethod('Procedure INSERTRECORD( const VALUES : array of const)'); + RegisterMethod('Function ISEMPTY : BOOLEAN'); + RegisterMethod('Function ISLINKEDTO( DATASOURCE : TDATASOURCE) : BOOLEAN'); + RegisterMethod('Function ISSEQUENCED : BOOLEAN'); + RegisterMethod('Procedure LAST'); + RegisterMethod('Function LOCATE( const KEYFIELDS : String; const KEYVALUES : VARIANT; OPTIONS : TLOCATEOPTIONS) : BOOLEAN'); + RegisterMethod('Function LOOKUP( const KEYFIELDS : String; const KEYVALUES : VARIANT; const RESULTFIELDS : String) : VARIANT'); + RegisterMethod('Function MOVEBY( DISTANCE : INTEGER) : INTEGER'); + RegisterMethod('Procedure NEXT'); + RegisterMethod('Procedure OPEN'); + RegisterMethod('Procedure POST'); + RegisterMethod('Procedure PRIOR'); + RegisterMethod('Procedure REFRESH'); +// RegisterMethod('Procedure RESYNC( MODE : TRESYNCMODE)'); + RegisterMethod('Procedure SETFIELDS( const VALUES : array of const)'); + RegisterMethod('Function TRANSLATE( SRC, DEST : PCHAR; TOOEM : BOOLEAN) : INTEGER'); + RegisterMethod('Procedure UPDATECURSORPOS'); + RegisterMethod('Procedure UPDATERECORD'); + RegisterMethod('Function UPDATESTATUS : TUPDATESTATUS'); + RegisterProperty('AGGFIELDS', 'TFIELDS', iptr); + RegisterProperty('BOF', 'BOOLEAN', iptr); +// RegisterProperty('BOOKMARK', 'TBOOKMARKSTR', iptrw); + RegisterProperty('CANMODIFY', 'BOOLEAN', iptr); + RegisterProperty('DATASETFIELD', 'TDATASETFIELD', iptrw); + RegisterProperty('DATASOURCE', 'TDATASOURCE', iptr); + RegisterProperty('DEFAULTFIELDS', 'BOOLEAN', iptr); + RegisterProperty('DESIGNER', 'TDATASETDESIGNER', iptr); + RegisterProperty('EOF', 'BOOLEAN', iptr); + RegisterProperty('BLOCKREADSIZE', 'INTEGER', iptrw); + RegisterProperty('FIELDCOUNT', 'INTEGER', iptr); + RegisterProperty('FIELDDEFS', 'TFIELDDEFS', iptrw); + RegisterProperty('FIELDDEFLIST', 'TFIELDDEFLIST', iptr); + RegisterProperty('FIELDS', 'TFIELDS', iptr); + RegisterProperty('FIELDLIST', 'TFIELDLIST', iptr); + RegisterProperty('FIELDVALUES', 'VARIANT String', iptrw); + RegisterProperty('FOUND', 'BOOLEAN', iptr); +{$IFDEF DELPHI6UP} + RegisterProperty('ISUNIDIRECTIONAL', 'BOOLEAN', iptr); +{$ENDIF} + RegisterProperty('MODIFIED', 'BOOLEAN', iptr); + RegisterProperty('OBJECTVIEW', 'BOOLEAN', iptrw); + RegisterProperty('RECORDCOUNT', 'INTEGER', iptr); + RegisterProperty('RECNO', 'INTEGER', iptrw); + RegisterProperty('RECORDSIZE', 'WORD', iptr); + RegisterProperty('SPARSEARRAYS', 'BOOLEAN', iptrw); + RegisterProperty('STATE', 'TDATASETSTATE', iptr); + RegisterProperty('FILTER', 'String', iptrw); + RegisterProperty('FILTERED', 'BOOLEAN', iptrw); + RegisterProperty('FILTEROPTIONS', 'TFILTEROPTIONS', iptrw); + RegisterProperty('ACTIVE', 'BOOLEAN', iptrw); + RegisterProperty('AUTOCALCFIELDS', 'BOOLEAN', iptrw); + RegisterProperty('BEFOREOPEN', 'TDATASETNOTIFYEVENT', iptrw); + RegisterProperty('AFTEROPEN', 'TDATASETNOTIFYEVENT', iptrw); + RegisterProperty('BEFORECLOSE', 'TDATASETNOTIFYEVENT', iptrw); + RegisterProperty('AFTERCLOSE', 'TDATASETNOTIFYEVENT', iptrw); + RegisterProperty('BEFOREINSERT', 'TDATASETNOTIFYEVENT', iptrw); + RegisterProperty('AFTERINSERT', 'TDATASETNOTIFYEVENT', iptrw); + RegisterProperty('BEFOREEDIT', 'TDATASETNOTIFYEVENT', iptrw); + RegisterProperty('AFTEREDIT', 'TDATASETNOTIFYEVENT', iptrw); + RegisterProperty('BEFOREPOST', 'TDATASETNOTIFYEVENT', iptrw); + RegisterProperty('AFTERPOST', 'TDATASETNOTIFYEVENT', iptrw); + RegisterProperty('BEFORECANCEL', 'TDATASETNOTIFYEVENT', iptrw); + RegisterProperty('AFTERCANCEL', 'TDATASETNOTIFYEVENT', iptrw); + RegisterProperty('BEFOREDELETE', 'TDATASETNOTIFYEVENT', iptrw); + RegisterProperty('AFTERDELETE', 'TDATASETNOTIFYEVENT', iptrw); + RegisterProperty('BEFORESCROLL', 'TDATASETNOTIFYEVENT', iptrw); + RegisterProperty('AFTERSCROLL', 'TDATASETNOTIFYEVENT', iptrw); + RegisterProperty('BEFOREREFRESH', 'TDATASETNOTIFYEVENT', iptrw); + RegisterProperty('AFTERREFRESH', 'TDATASETNOTIFYEVENT', iptrw); + RegisterProperty('ONCALCFIELDS', 'TDATASETNOTIFYEVENT', iptrw); + RegisterProperty('ONDELETEERROR', 'TDATASETERROREVENT', iptrw); + RegisterProperty('ONEDITERROR', 'TDATASETERROREVENT', iptrw); + RegisterProperty('ONFILTERRECORD', 'TFILTERRECORDEVENT', iptrw); + RegisterProperty('ONNEWRECORD', 'TDATASETNOTIFYEVENT', iptrw); + RegisterProperty('ONPOSTERROR', 'TDATASETERROREVENT', iptrw); + end; +end; + +procedure SIRegisterTPARAMS(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TCOLLECTION','TPARAMS') do + begin + RegisterMethod('Procedure ASSIGNVALUES( VALUE : TPARAMS)'); + RegisterMethod('Procedure ADDPARAM( VALUE : TPARAM)'); + RegisterMethod('Procedure REMOVEPARAM( VALUE : TPARAM)'); + RegisterMethod('Function CREATEPARAM( FLDTYPE : TFIELDTYPE; const PARAMNAME : String; PARAMTYPE : TPARAMTYPE) : TPARAM'); +// RegisterMethod('Procedure GETPARAMLIST( LIST : TLIST; const PARAMNAMES : STRING)'); + RegisterMethod('Function ISEQUAL( VALUE : TPARAMS) : BOOLEAN'); + RegisterMethod('Function PARSESQL( SQL : String; DOCREATE : BOOLEAN) : String'); + RegisterMethod('Function PARAMBYNAME( const VALUE : String) : TPARAM'); + RegisterMethod('Function FINDPARAM( const VALUE : String) : TPARAM'); + RegisterProperty('ITEMS', 'TPARAM INTEGER', iptrw); + RegisterProperty('PARAMVALUES', 'VARIANT String', iptrw); + end; +end; + +procedure SIRegisterTPARAM(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TCOLLECTIONITEM','TPARAM') do + begin + RegisterMethod('Procedure ASSIGNFIELD( FIELD : TFIELD)'); + RegisterMethod('Procedure ASSIGNFIELDVALUE( FIELD : TFIELD; const VALUE : VARIANT)'); + RegisterMethod('Procedure CLEAR'); +// RegisterMethod('Procedure GETDATA( BUFFER : POINTER)'); + RegisterMethod('Function GETDATASIZE : INTEGER'); + RegisterMethod('Procedure LOADFROMFILE( const FILENAME : String; BLOBTYPE : TBLOBTYPE)'); + RegisterMethod('Procedure LOADFROMSTREAM( STREAM : TSTREAM; BLOBTYPE : TBLOBTYPE)'); +// RegisterMethod('Procedure SETBLOBDATA( BUFFER : POINTER; SIZE : INTEGER)'); +// RegisterMethod('Procedure SETDATA( BUFFER : POINTER)'); +{$IFDEF DELPHI6UP} + RegisterProperty('ASBCD', 'CURRENCY', iptrw); +{$ENDIF} +{$IFDEF DELPHI6UP} + RegisterProperty('ASFMTBCD', 'TBCD', iptrw); +{$ENDIF} + RegisterProperty('ASBLOB', 'TBLOBDATA', iptrw); + RegisterProperty('ASBOOLEAN', 'BOOLEAN', iptrw); + RegisterProperty('ASCURRENCY', 'CURRENCY', iptrw); + RegisterProperty('ASDATE', 'TDATETIME', iptrw); + RegisterProperty('ASDATETIME', 'TDATETIME', iptrw); + RegisterProperty('ASFLOAT', 'DOUBLE', iptrw); + RegisterProperty('ASINTEGER', 'LONGINT', iptrw); + RegisterProperty('ASSMALLINT', 'LONGINT', iptrw); + RegisterProperty('ASMEMO', 'String', iptrw); + RegisterProperty('ASSTRING', 'String', iptrw); + RegisterProperty('ASTIME', 'TDATETIME', iptrw); + RegisterProperty('ASWORD', 'LONGINT', iptrw); + RegisterProperty('BOUND', 'BOOLEAN', iptrw); + RegisterProperty('ISNULL', 'BOOLEAN', iptr); + RegisterProperty('NATIVESTR', 'String', iptrw); + RegisterProperty('TEXT', 'String', iptrw); + RegisterProperty('DATATYPE', 'TFIELDTYPE', iptrw); +{$IFDEF DELPHI6UP} + RegisterProperty('PRECISION', 'INTEGER', iptrw); + RegisterProperty('NUMERICSCALE', 'INTEGER', iptrw); + RegisterProperty('SIZE', 'INTEGER', iptrw); +{$ENDIF} + RegisterProperty('NAME', 'String', iptrw); + RegisterProperty('PARAMTYPE', 'TPARAMTYPE', iptrw); + RegisterProperty('VALUE', 'VARIANT', iptrw); + end; +end; + +procedure SIRegisterTGUIDFIELD(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TFIELD','TGUIDFIELD') do + begin + end; +end; + +procedure SIRegisterTVARIANTFIELD(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TFIELD','TVARIANTFIELD') do + begin + end; +end; + +procedure SIRegisterTREFERENCEFIELD(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TDATASETFIELD','TREFERENCEFIELD') do + begin + RegisterProperty('REFERENCETABLENAME', 'String', iptrw); + end; +end; + +procedure SIRegisterTDATASETFIELD(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TOBJECTFIELD','TDATASETFIELD') do + begin + RegisterProperty('NESTEDDATASET', 'TDATASET', iptr); + RegisterProperty('INCLUDEOBJECTFIELD', 'BOOLEAN', iptrw); + end; +end; + +procedure SIRegisterTARRAYFIELD(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TOBJECTFIELD','TARRAYFIELD') do + begin + end; +end; + +procedure SIRegisterTADTFIELD(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TOBJECTFIELD','TADTFIELD') do + begin + end; +end; + +procedure SIRegisterTOBJECTFIELD(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TFIELD','TOBJECTFIELD') do + begin + RegisterProperty('FIELDCOUNT', 'INTEGER', iptr); + RegisterProperty('FIELDS', 'TFIELDS', iptr); + RegisterProperty('FIELDVALUES', 'VARIANT INTEGER', iptrw); + RegisterProperty('UNNAMED', 'BOOLEAN', iptr); + RegisterProperty('OBJECTTYPE', 'String', iptrw); + end; +end; + +procedure SIRegisterTGRAPHICFIELD(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TBLOBFIELD','TGRAPHICFIELD') do + begin + end; +end; + +procedure SIRegisterTMEMOFIELD(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TBLOBFIELD','TMEMOFIELD') do + begin + end; +end; + +procedure SIRegisterTBLOBFIELD(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TFIELD','TBLOBFIELD') do + begin + RegisterMethod('Procedure LOADFROMFILE( const FILENAME : String)'); + RegisterMethod('Procedure LOADFROMSTREAM( STREAM : TSTREAM)'); + RegisterMethod('Procedure SAVETOFILE( const FILENAME : String)'); + RegisterMethod('Procedure SAVETOSTREAM( STREAM : TSTREAM)'); + RegisterProperty('BLOBSIZE', 'INTEGER', iptr); + RegisterProperty('MODIFIED', 'BOOLEAN', iptrw); + RegisterProperty('VALUE', 'String', iptrw); + RegisterProperty('TRANSLITERATE', 'BOOLEAN', iptrw); + RegisterProperty('BLOBTYPE', 'TBLOBTYPE', iptrw); +{$IFDEF DELPHI6UP} + RegisterProperty('GRAPHICHEADER', 'BOOLEAN', iptrw); +{$ENDIF} + end; +end; + +{$IFDEF DELPHI6UP} +procedure SIRegisterTFMTBCDFIELD(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TNUMERICFIELD','TFMTBCDFIELD') do + begin + RegisterProperty('VALUE', 'TBCD', iptrw); + RegisterProperty('CURRENCY', 'BOOLEAN', iptrw); + RegisterProperty('MAXVALUE', 'String', iptrw); + RegisterProperty('MINVALUE', 'String', iptrw); + RegisterProperty('PRECISION', 'INTEGER', iptrw); + end; +end; +{$ENDIF} + +procedure SIRegisterTBCDFIELD(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TNUMERICFIELD','TBCDFIELD') do + begin + RegisterProperty('VALUE', 'CURRENCY', iptrw); + RegisterProperty('CURRENCY', 'BOOLEAN', iptrw); + RegisterProperty('MAXVALUE', 'CURRENCY', iptrw); + RegisterProperty('MINVALUE', 'CURRENCY', iptrw); + RegisterProperty('PRECISION', 'INTEGER', iptrw); + end; +end; + +procedure SIRegisterTVARBYTESFIELD(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TBYTESFIELD','TVARBYTESFIELD') do + begin + end; +end; + +procedure SIRegisterTBYTESFIELD(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TBINARYFIELD','TBYTESFIELD') do + begin + end; +end; + +procedure SIRegisterTBINARYFIELD(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TFIELD','TBINARYFIELD') do + begin + end; +end; + +procedure SIRegisterTTIMEFIELD(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TDATETIMEFIELD','TTIMEFIELD') do + begin + end; +end; + +procedure SIRegisterTDATEFIELD(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TDATETIMEFIELD','TDATEFIELD') do + begin + end; +end; + +procedure SIRegisterTDATETIMEFIELD(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TFIELD','TDATETIMEFIELD') do + begin + RegisterProperty('VALUE', 'TDATETIME', iptrw); + RegisterProperty('DISPLAYFORMAT', 'String', iptrw); + end; +end; + +procedure SIRegisterTBOOLEANFIELD(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TFIELD','TBOOLEANFIELD') do + begin + RegisterProperty('VALUE', 'BOOLEAN', iptrw); + RegisterProperty('DISPLAYVALUES', 'String', iptrw); + end; +end; + +procedure SIRegisterTCURRENCYFIELD(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TFLOATFIELD','TCURRENCYFIELD') do + begin + end; +end; + +procedure SIRegisterTFLOATFIELD(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TNUMERICFIELD','TFLOATFIELD') do + begin + RegisterProperty('VALUE', 'DOUBLE', iptrw); + RegisterProperty('CURRENCY', 'BOOLEAN', iptrw); + RegisterProperty('MAXVALUE', 'DOUBLE', iptrw); + RegisterProperty('MINVALUE', 'DOUBLE', iptrw); + RegisterProperty('PRECISION', 'INTEGER', iptrw); + end; +end; + +procedure SIRegisterTAUTOINCFIELD(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TINTEGERFIELD','TAUTOINCFIELD') do + begin + end; +end; + +procedure SIRegisterTWORDFIELD(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TINTEGERFIELD','TWORDFIELD') do + begin + end; +end; + +procedure SIRegisterTLARGEINTFIELD(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TNUMERICFIELD','TLARGEINTFIELD') do + begin + RegisterProperty('ASLARGEINT', 'LARGEINT', iptrw); + RegisterProperty('VALUE', 'LARGEINT', iptrw); + RegisterProperty('MAXVALUE', 'LARGEINT', iptrw); + RegisterProperty('MINVALUE', 'LARGEINT', iptrw); + end; +end; + +procedure SIRegisterTSMALLINTFIELD(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TINTEGERFIELD','TSMALLINTFIELD') do + begin + end; +end; + +procedure SIRegisterTINTEGERFIELD(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TNUMERICFIELD','TINTEGERFIELD') do + begin + RegisterProperty('VALUE', 'LONGINT', iptrw); + RegisterProperty('MAXVALUE', 'LONGINT', iptrw); + RegisterProperty('MINVALUE', 'LONGINT', iptrw); + end; +end; + +procedure SIRegisterTNUMERICFIELD(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TFIELD','TNUMERICFIELD') do + begin + RegisterProperty('DISPLAYFORMAT', 'String', iptrw); + RegisterProperty('EDITFORMAT', 'String', iptrw); + end; +end; + +procedure SIRegisterTWIDESTRINGFIELD(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TSTRINGFIELD','TWIDESTRINGFIELD') do + begin + RegisterProperty('VALUE', 'WIDESTRING', iptrw); + end; +end; + +procedure SIRegisterTSTRINGFIELD(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TFIELD','TSTRINGFIELD') do + begin + RegisterProperty('VALUE', 'String', iptrw); + RegisterProperty('FIXEDCHAR', 'BOOLEAN', iptrw); + RegisterProperty('TRANSLITERATE', 'BOOLEAN', iptrw); + end; +end; + +procedure SIRegisterTFIELD(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TCOMPONENT','TFIELD') do + begin +//RegisterMethod('Procedure ASSIGNVALUE( const VALUE : TVARREC)'); + RegisterMethod('Procedure CLEAR'); + RegisterMethod('Procedure FOCUSCONTROL'); +// RegisterMethod('Function GETDATA( BUFFER : POINTER; NATIVEFORMAT : BOOLEAN) : BOOLEAN'); + RegisterMethod('Function ISVALIDCHAR( INPUTCHAR : CHAR) : BOOLEAN'); + RegisterMethod('Procedure REFRESHLOOKUPLIST'); +// RegisterMethod('Procedure SETDATA( BUFFER : POINTER; NATIVEFORMAT : BOOLEAN)'); + RegisterMethod('Procedure SETFIELDTYPE( VALUE : TFIELDTYPE)'); +// RegisterMethod('Procedure VALIDATE( BUFFER : POINTER)'); +{$IFDEF DELPHI6UP} + RegisterProperty('ASBCD', 'TBCD', iptrw); +{$ENDIF} + RegisterProperty('ASBOOLEAN', 'BOOLEAN', iptrw); + RegisterProperty('ASCURRENCY', 'CURRENCY', iptrw); + RegisterProperty('ASDATETIME', 'TDATETIME', iptrw); + RegisterProperty('ASFLOAT', 'DOUBLE', iptrw); + RegisterProperty('ASINTEGER', 'LONGINT', iptrw); + RegisterProperty('ASSTRING', 'String', iptrw); + RegisterProperty('ASVARIANT', 'VARIANT', iptrw); + RegisterProperty('ATTRIBUTESET', 'String', iptrw); + RegisterProperty('CALCULATED', 'BOOLEAN', iptrw); + RegisterProperty('CANMODIFY', 'BOOLEAN', iptr); + RegisterProperty('CURVALUE', 'VARIANT', iptr); + RegisterProperty('DATASET', 'TDATASET', iptrw); + RegisterProperty('DATASIZE', 'INTEGER', iptr); + RegisterProperty('DATATYPE', 'TFIELDTYPE', iptr); + RegisterProperty('DISPLAYNAME', 'String', iptr); + RegisterProperty('DISPLAYTEXT', 'String', iptr); + RegisterProperty('EDITMASK', 'TEDITMASK', iptrw); + RegisterProperty('EDITMASKPTR', 'TEDITMASK', iptr); + RegisterProperty('EDITMASK', 'String', iptrw); + RegisterProperty('EDITMASKPTR', 'String', iptr); + RegisterProperty('FIELDNO', 'INTEGER', iptr); + RegisterProperty('FULLNAME', 'String', iptr); + RegisterProperty('ISINDEXFIELD', 'BOOLEAN', iptr); + RegisterProperty('ISNULL', 'BOOLEAN', iptr); + RegisterProperty('LOOKUP', 'BOOLEAN', iptrw); + RegisterProperty('LOOKUPLIST', 'TLOOKUPLIST', iptr); + RegisterProperty('NEWVALUE', 'VARIANT', iptrw); + RegisterProperty('OFFSET', 'INTEGER', iptr); + RegisterProperty('OLDVALUE', 'VARIANT', iptr); + RegisterProperty('PARENTFIELD', 'TOBJECTFIELD', iptrw); + RegisterProperty('SIZE', 'INTEGER', iptrw); + RegisterProperty('TEXT', 'String', iptrw); + RegisterProperty('VALIDCHARS', 'TFIELDCHARS', iptrw); + RegisterProperty('VALUE', 'VARIANT', iptrw); + RegisterProperty('ALIGNMENT', 'TALIGNMENT', iptrw); + RegisterProperty('AUTOGENERATEVALUE', 'TAUTOREFRESHFLAG', iptrw); + RegisterProperty('CUSTOMCONSTRAINT', 'String', iptrw); + RegisterProperty('CONSTRAINTERRORMESSAGE', 'String', iptrw); + RegisterProperty('DEFAULTEXPRESSION', 'String', iptrw); + RegisterProperty('DISPLAYLABEL', 'String', iptrw); + RegisterProperty('DISPLAYWIDTH', 'INTEGER', iptrw); + RegisterProperty('FIELDKIND', 'TFIELDKIND', iptrw); + RegisterProperty('FIELDNAME', 'String', iptrw); + RegisterProperty('HASCONSTRAINTS', 'BOOLEAN', iptr); + RegisterProperty('INDEX', 'INTEGER', iptrw); + RegisterProperty('IMPORTEDCONSTRAINT', 'String', iptrw); + RegisterProperty('LOOKUPDATASET', 'TDATASET', iptrw); + RegisterProperty('LOOKUPKEYFIELDS', 'String', iptrw); + RegisterProperty('LOOKUPRESULTFIELD', 'String', iptrw); + RegisterProperty('KEYFIELDS', 'String', iptrw); + RegisterProperty('LOOKUPCACHE', 'BOOLEAN', iptrw); + RegisterProperty('ORIGIN', 'String', iptrw); + RegisterProperty('PROVIDERFLAGS', 'TPROVIDERFLAGS', iptrw); + RegisterProperty('READONLY', 'BOOLEAN', iptrw); + RegisterProperty('REQUIRED', 'BOOLEAN', iptrw); + RegisterProperty('VISIBLE', 'BOOLEAN', iptrw); + RegisterProperty('ONCHANGE', 'TFIELDNOTIFYEVENT', iptrw); + RegisterProperty('ONGETTEXT', 'TFIELDGETTEXTEVENT', iptrw); + RegisterProperty('ONSETTEXT', 'TFIELDSETTEXTEVENT', iptrw); + RegisterProperty('ONVALIDATE', 'TFIELDNOTIFYEVENT', iptrw); + end; +end; + +procedure SIRegisterTLOOKUPLIST(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TOBJECT','TLOOKUPLIST') do + begin + RegisterMethod('Constructor CREATE'); + RegisterMethod('Procedure ADD( const AKEY, AVALUE : VARIANT)'); + RegisterMethod('Procedure CLEAR'); + RegisterMethod('Function VALUEOFKEY( const AKEY : VARIANT) : VARIANT'); + end; +end; + +procedure SIRegisterTFIELDS(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TOBJECT','TFIELDS') do + begin + RegisterMethod('Constructor CREATE( ADATASET : TDATASET)'); + RegisterMethod('Procedure ADD( FIELD : TFIELD)'); + RegisterMethod('Procedure CHECKFIELDNAME( const FIELDNAME : String)'); + RegisterMethod('Procedure CHECKFIELDNAMES( const FIELDNAMES : String)'); + RegisterMethod('Procedure CLEAR'); + RegisterMethod('Function FINDFIELD( const FIELDNAME : String) : TFIELD'); + RegisterMethod('Function FIELDBYNAME( const FIELDNAME : String) : TFIELD'); + RegisterMethod('Function FIELDBYNUMBER( FIELDNO : INTEGER) : TFIELD'); + RegisterMethod('Procedure GETFIELDNAMES( LIST : TSTRINGS)'); + RegisterMethod('Function INDEXOF( FIELD : TFIELD) : INTEGER'); + RegisterMethod('Procedure REMOVE( FIELD : TFIELD)'); + RegisterProperty('COUNT', 'INTEGER', iptr); + RegisterProperty('DATASET', 'TDATASET', iptr); + RegisterProperty('FIELDS', 'TFIELD INTEGER', iptrw); + end; +end; + +procedure SIRegisterTFIELDLIST(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TFLATLIST','TFIELDLIST') do + begin + RegisterMethod('Function FIELDBYNAME( const NAME : String) : TFIELD'); + RegisterMethod('Function FIND( const NAME : String) : TFIELD'); + RegisterProperty('FIELDS', 'TFIELD INTEGER', iptr); + end; +end; + +procedure SIRegisterTFIELDDEFLIST(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TFLATLIST','TFIELDDEFLIST') do + begin + RegisterMethod('Function FIELDBYNAME( const NAME : String) : TFIELDDEF'); + RegisterMethod('Function FIND( const NAME : String) : TFIELDDEF'); + RegisterProperty('FIELDDEFS', 'TFIELDDEF INTEGER', iptr); + end; +end; + +procedure SIRegisterTFLATLIST(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TSTRINGLIST','TFLATLIST') do + begin + RegisterMethod('Constructor CREATE( ADATASET : TDATASET)'); + RegisterMethod('Procedure UPDATE'); + RegisterProperty('DATASET', 'TDATASET', iptr); + end; +end; + +procedure SIRegisterTINDEXDEFS(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TDEFCOLLECTION','TINDEXDEFS') do + begin + RegisterMethod('Constructor CREATE( ADATASET : TDATASET)'); + RegisterMethod('Function ADDINDEXDEF : TINDEXDEF'); + RegisterMethod('Function FIND( const NAME : String) : TINDEXDEF'); + RegisterMethod('Procedure UPDATE'); + RegisterMethod('Function FINDINDEXFORFIELDS( const FIELDS : String) : TINDEXDEF'); + RegisterMethod('Function GETINDEXFORFIELDS( const FIELDS : String; CASEINSENSITIVE : BOOLEAN) : TINDEXDEF'); + RegisterMethod('Procedure ADD( const NAME, FIELDS : String; OPTIONS : TINDEXOPTIONS)'); + RegisterProperty('ITEMS', 'TINDEXDEF INTEGER', iptrw); + end; +end; + +procedure SIRegisterTINDEXDEF(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TNAMEDITEM','TINDEXDEF') do + begin + RegisterMethod('Constructor CREATE( OWNER : TINDEXDEFS; const NAME, FIELDS : String; OPTIONS : TINDEXOPTIONS)'); + RegisterProperty('FIELDEXPRESSION', 'String', iptr); + RegisterProperty('CASEINSFIELDS', 'String', iptrw); + RegisterProperty('DESCFIELDS', 'String', iptrw); + RegisterProperty('EXPRESSION', 'String', iptrw); + RegisterProperty('FIELDS', 'String', iptrw); + RegisterProperty('OPTIONS', 'TINDEXOPTIONS', iptrw); + RegisterProperty('SOURCE', 'String', iptrw); + RegisterProperty('GROUPINGLEVEL', 'INTEGER', iptrw); + end; +end; + +procedure SIRegisterTFIELDDEFS(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TDEFCOLLECTION','TFIELDDEFS') do + begin + RegisterMethod('Constructor CREATE( AOWNER : TPERSISTENT)'); + RegisterMethod('Function ADDFIELDDEF : TFIELDDEF'); + RegisterMethod('Function FIND( const NAME : String) : TFIELDDEF'); + RegisterMethod('Procedure UPDATE'); + RegisterMethod('Procedure ADD( const NAME : String; DATATYPE : TFIELDTYPE; SIZE : INTEGER; REQUIRED : BOOLEAN)'); + RegisterProperty('HIDDENFIELDS', 'BOOLEAN', iptrw); + RegisterProperty('ITEMS', 'TFIELDDEF INTEGER', iptrw); + RegisterProperty('PARENTDEF', 'TFIELDDEF', iptr); + end; +end; + +procedure SIRegisterTFIELDDEF(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TNAMEDITEM','TFIELDDEF') do + begin +// RegisterMethod('Constructor CREATE( OWNER : TFIELDDEFS; const NAME : STRING; DATATYPE : TFIELDTYPE; SIZE : INTEGER; REQUIRED : BOOLEAN; FIELDNO : INTEGER)'); + RegisterMethod('Function ADDCHILD : TFIELDDEF'); + RegisterMethod('Function CREATEFIELD( OWNER : TCOMPONENT; PARENTFIELD : TOBJECTFIELD; const FIELDNAME : String; CREATECHILDREN : BOOLEAN) : TFIELD'); + RegisterMethod('Function HASCHILDDEFS : BOOLEAN'); + RegisterProperty('FIELDCLASS', 'TFIELDCLASS', iptr); + RegisterProperty('FIELDNO', 'INTEGER', iptrw); + RegisterProperty('INTERNALCALCFIELD', 'BOOLEAN', iptrw); + RegisterProperty('PARENTDEF', 'TFIELDDEF', iptr); + RegisterProperty('REQUIRED', 'BOOLEAN', iptrw); + RegisterProperty('ATTRIBUTES', 'TFIELDATTRIBUTES', iptrw); + RegisterProperty('CHILDDEFS', 'TFIELDDEFS', iptrw); + RegisterProperty('DATATYPE', 'TFIELDTYPE', iptrw); + RegisterProperty('PRECISION', 'INTEGER', iptrw); + RegisterProperty('SIZE', 'INTEGER', iptrw); + end; +end; + +procedure SIRegisterTDEFCOLLECTION(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TOWNEDCOLLECTION','TDEFCOLLECTION') do + begin +// RegisterMethod('Constructor CREATE( ADATASET : TDATASET; AOWNER : TPERSISTENT; ACLASS : TCOLLECTIONITEMCLASS)'); + RegisterMethod('Function FIND( const ANAME : String) : TNAMEDITEM'); + RegisterMethod('Procedure GETITEMNAMES( LIST : TSTRINGS)'); + RegisterMethod('Function INDEXOF( const ANAME : String) : INTEGER'); + RegisterProperty('DATASET', 'TDATASET', iptr); + RegisterProperty('UPDATED', 'BOOLEAN', iptrw); + end; +end; + +procedure SIRegisterTNAMEDITEM(CL: TPSPascalCompiler); +Begin +With RegClassS(cl,'TCOLLECTIONITEM','TNAMEDITEM') do + begin + RegisterProperty('NAME', 'String', iptrw); + end; +end; + +procedure SIRegister_DB(Cl: TPSPascalCompiler); +Begin +cl.AddTypeS('TFieldType', '(ftUnknown, ftString, ftSmallint, ftInteger, ftWord, ftBoolean, ftFloat, ftCurrency, ftBCD, ftDate, ftTime, ftDateTime,'+ + 'ftBytes, ftVarBytes, ftAutoInc, ftBlob, ftMemo, ftGraphic, ftFmtMemo, ftParadoxOle, ftDBaseOle, ftTypedBinary, ftCursor, ftFixedChar, ftWideString,'+ + 'ftLargeint, ftADT, ftArray, ftReference, ftDataSet, ftOraBlob, ftOraClob, ftVariant, ftInterface, ftIDispatch, ftGuid, ftTimeStamp, ftFMTBcd)'); + + CL.AddTypeS('TDataSetState', '(dsInactive, dsBrowse, dsEdit, dsInsert, dsSetKey, dsCalcFields, dsFilter, dsNewValue, dsOldValue, dsCurValue, dsBlockRead, dsInternalCalc, dsOpening)'); + +cl.addTypeS('TLocateOption','(loCaseInsensitive, loPartialKey)'); +cl.addtypes('TLocateOptions','set of TLocateOption'); +cl.addtypes('TUpdateStatus','(usUnmodified, usModified, usInserted, usDeleted)'); +cl.addtypes('TUpdateStatusSet', 'set of TUpdateStatus'); + + cl.addTypeS('TPARAMTYPE', 'BYTE'); +RegClassS(cl,'TComponent','TDATASET'); +RegClassS(cl,'TComponent','TFIELD'); +RegClassS(cl,'TComponent','TFIELDDEFS'); +RegClassS(cl,'TComponent','TINDEXDEFS'); +RegClassS(cl, 'TComponent', 'TObjectField'); +RegClassS(cl, 'TComponent', 'TDataLink'); +RegClassS(cl, 'TComponent', 'TDataSource'); +RegClassS(cl, 'TComponent', 'TParam'); + +SIRegisterTNAMEDITEM(Cl); +Cl.addTypeS('TDEFUPDATEMETHOD', 'Procedure'); +SIRegisterTDEFCOLLECTION(Cl); +cl.AddConstantN('FAHIDDENCOL','LONGINT').Value.tu32 := 1; +cl.AddConstantN('FAREADONLY','LONGINT').Value.tu32 := 2; +cl.AddConstantN('FAREQUIRED','LONGINT').Value.tu32 := 4; +cl.AddConstantN('FALINK','LONGINT').Value.tu32 := 8; +cl.AddConstantN('FAUNNAMED','LONGINT').Value.tu32 := 16; +cl.AddConstantN('FAFIXED','LONGINT').Value.tu32 := 32; +cl.addTypeS('TFIELDATTRIBUTES', 'BYTE'); +SIRegisterTFIELDDEF(Cl); +SIRegisterTFIELDDEFS(Cl); +cl.AddConstantN('IXPRIMARY','LONGINT').Value.tu32 := 1; +cl.AddConstantN('IXUNIQUE','LONGINT').Value.tu32 := 2; +cl.AddConstantN('IXDESCENDING','LONGINT').Value.tu32 := 4; +cl.AddConstantN('IXCASEINSENSITIVE','LONGINT').Value.tu32 := 8; +cl.AddConstantN('IXEXPRESSION','LONGINT').Value.tu32 := 16; +cl.AddConstantN('IXNONMAINTAINED','LONGINT').Value.tu32 := 32; +cl.addTypeS('TINDEXOPTIONS', 'BYTE'); +SIRegisterTINDEXDEF(Cl); +SIRegisterTINDEXDEFS(Cl); +SIRegisterTFLATLIST(Cl); +SIRegisterTFIELDDEFLIST(Cl); +SIRegisterTFIELDLIST(Cl); +cl.AddConstantN('FKDATA','LONGINT').Value.tu32 := 1; +cl.AddConstantN('FKCALCULATED','LONGINT').Value.tu32 := 2; +cl.AddConstantN('FKLOOKUP','LONGINT').Value.tu32 := 4; +cl.AddConstantN('FKINTERNALCALC','LONGINT').Value.tu32 := 8; +cl.AddConstantN('FKAGGREGATE','LONGINT').Value.tu32 := 16; +cl.addTypeS('TFIELDKINDS', 'BYTE'); +SIRegisterTFIELDS(Cl); +cl.AddConstantN('PFINUPDATE','LONGINT').Value.tu32 := 1; +cl.AddConstantN('PFINWHERE','LONGINT').Value.tu32 := 2; +cl.AddConstantN('PFINKEY','LONGINT').Value.tu32 := 4; +cl.AddConstantN('PFHIDDEN','LONGINT').Value.tu32 :=8; +cl.addTypeS('TPROVIDERFLAGS', 'BYTE'); +cl.addTypeS('TFIELDNOTIFYEVENT', 'Procedure ( SENDER : TFIELD)'); +cl.addTypeS('TFIELDGETTEXTEVENT', 'Procedure ( SENDER : TFIELD; var TEXT : S' + +'TRING; DISPLAYTEXT : BOOLEAN)'); +cl.addTypeS('TFIELDSETTEXTEVENT', 'Procedure ( SENDER : TFIELD; const TEXT :' + +' String)'); +cl.addTypeS('TAUTOREFRESHFLAG', '( ARNONE, ARAUTOINC, ARDEFAULT )'); +SIRegisterTLOOKUPLIST(Cl); +SIRegisterTFIELD(Cl); +SIRegisterTSTRINGFIELD(Cl); +SIRegisterTWIDESTRINGFIELD(Cl); +SIRegisterTNUMERICFIELD(Cl); +SIRegisterTINTEGERFIELD(Cl); +SIRegisterTSMALLINTFIELD(Cl); +cl.addTypeS('LARGEINT', 'INT64'); +SIRegisterTLARGEINTFIELD(Cl); +SIRegisterTWORDFIELD(Cl); +SIRegisterTAUTOINCFIELD(Cl); +SIRegisterTFLOATFIELD(Cl); +SIRegisterTCURRENCYFIELD(Cl); +SIRegisterTBOOLEANFIELD(Cl); +SIRegisterTDATETIMEFIELD(Cl); +SIRegisterTDATEFIELD(Cl); +SIRegisterTTIMEFIELD(Cl); +SIRegisterTBINARYFIELD(Cl); +SIRegisterTBYTESFIELD(Cl); +SIRegisterTVARBYTESFIELD(Cl); +SIRegisterTBCDFIELD(Cl); +{$IFDEF DELPHI6UP} +SIRegisterTFMTBCDFIELD(Cl); +{$ENDIF} +cl.addTypeS('TBLOBTYPE', 'BYTE'); +SIRegisterTBLOBFIELD(Cl); +SIRegisterTMEMOFIELD(Cl); +SIRegisterTGRAPHICFIELD(Cl); +SIRegisterTOBJECTFIELD(Cl); +SIRegisterTADTFIELD(Cl); +SIRegisterTARRAYFIELD(Cl); +SIRegisterTDATASETFIELD(Cl); +SIRegisterTREFERENCEFIELD(Cl); +SIRegisterTVARIANTFIELD(Cl); +SIRegisterTGUIDFIELD(Cl); +cl.addTypeS('TBLOBDATA', 'STRING'); +cl.AddConstantN('PTUNKNOWN','LONGINT').Value.tu32 := 1; +cl.AddConstantN('PTINPUT','LONGINT').Value.tu32 := 2; +cl.AddConstantN('PTOUTPUT','LONGINT').Value.tu32 := 4; +cl.AddConstantN('PTINPUTOUTPUT','LONGINT').Value.tu32 := 8; +cl.AddConstantN('PTRESULT','LONGINT').Value.tu32 := 16; +RegClassS(cl,'TObject','TPARAMS'); +SIRegisterTPARAM(Cl); +SIRegisterTPARAMS(Cl); +cl.addTypeS('TDATAACTION', '( DAFAIL, DAABORT, DARETRY )'); +cl.addTypeS('TBLOBSTREAMMODE', '( BMREAD, BMWRITE, BMREADWRITE )'); +cl.addTypeS('TDATAOPERATION', 'Procedure'); +cl.addTypeS('TDATASETNOTIFYEVENT', 'Procedure ( DATASET : TDATASET)'); +cl.addTypeS('TDATASETERROREVENT', 'Procedure ( DATASET : TDATASET; E : TObject' + +'; var ACTION : TDATAACTION)'); +cl.addTypeS('TFILTERRECORDEVENT', 'Procedure ( DATASET : TDATASET; var ACCEP' + +'T : BOOLEAN)'); +SIRegisterTDATASET(Cl); +end; + +{$IFDEF USEIMPORTER} +initialization +CIImporter.AddCallBack(@SIRegister_DB,PT_ClassImport); +{$ENDIF} +end. diff --git a/Units/PascalScript/uPSC_buttons.pas b/Units/PascalScript/uPSC_buttons.pas new file mode 100644 index 0000000..52c0873 --- /dev/null +++ b/Units/PascalScript/uPSC_buttons.pas @@ -0,0 +1,87 @@ +{ Compiletime Buttons support } +unit uPSC_buttons; +{$I PascalScript.inc} +interface +uses + uPSCompiler, uPSUtils; + +{ + Will register files from: + Buttons + + Requires + STD, classes, controls and graphics and StdCtrls +} +procedure SIRegister_Buttons_TypesAndConsts(Cl: TPSPascalCompiler); + +procedure SIRegisterTSPEEDBUTTON(Cl: TPSPascalCompiler); +procedure SIRegisterTBITBTN(Cl: TPSPascalCompiler); + +procedure SIRegister_Buttons(Cl: TPSPascalCompiler); + +implementation + +procedure SIRegisterTSPEEDBUTTON(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TGRAPHICCONTROL'), 'TSPEEDBUTTON') do + begin + RegisterProperty('ALLOWALLUP', 'BOOLEAN', iptrw); + RegisterProperty('GROUPINDEX', 'INTEGER', iptrw); + RegisterProperty('DOWN', 'BOOLEAN', iptrw); + RegisterProperty('CAPTION', 'String', iptrw); + RegisterProperty('FONT', 'TFont', iptrw); + RegisterProperty('GLYPH', 'TBITMAP', iptrw); + RegisterProperty('LAYOUT', 'TBUTTONLAYOUT', iptrw); + RegisterProperty('MARGIN', 'INTEGER', iptrw); + RegisterProperty('NUMGLYPHS', 'BYTE', iptrw); + RegisterProperty('PARENTFONT', 'Boolean', iptrw); + RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw); + RegisterProperty('SPACING', 'INTEGER', iptrw); + RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw); + RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw); + RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw); + RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw); + RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw); + end; +end; + +procedure SIRegisterTBITBTN(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TBUTTON'), 'TBITBTN') do + begin + RegisterProperty('GLYPH', 'TBITMAP', iptrw); + RegisterProperty('KIND', 'TBITBTNKIND', iptrw); + RegisterProperty('LAYOUT', 'TBUTTONLAYOUT', iptrw); + RegisterProperty('MARGIN', 'INTEGER', iptrw); + RegisterProperty('NUMGLYPHS', 'BYTE', iptrw); + RegisterProperty('STYLE', 'TBUTTONSTYLE', iptrw); + RegisterProperty('SPACING', 'INTEGER', iptrw); + end; +end; + + + +procedure SIRegister_Buttons_TypesAndConsts(Cl: TPSPascalCompiler); +begin + Cl.AddTypeS('TButtonLayout', '(blGlyphLeft, blGlyphRight, blGlyphTop, blGlyphBottom)'); + Cl.AddTypeS('TButtonState', '(bsUp, bsDisabled, bsDown, bsExclusive)'); + Cl.AddTypeS('TButtonStyle', '(bsAutoDetect, bsWin31, bsNew)'); + Cl.AddTypeS('TBitBtnKind', '(bkCustom, bkOK, bkCancel, bkHelp, bkYes, bkNo, bkClose, bkAbort, bkRetry, bkIgnore, bkAll)'); + +end; + +procedure SIRegister_Buttons(Cl: TPSPascalCompiler); +begin + SIRegister_Buttons_TypesAndConsts(cl); + SIRegisterTSPEEDBUTTON(cl); + SIRegisterTBITBTN(cl); +end; + +// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl) + + +end. + + + + diff --git a/Units/PascalScript/uPSC_classes.pas b/Units/PascalScript/uPSC_classes.pas new file mode 100644 index 0000000..ff86334 --- /dev/null +++ b/Units/PascalScript/uPSC_classes.pas @@ -0,0 +1,320 @@ +{ Compiletime Classes support } +unit uPSC_classes; + +{$I PascalScript.inc} +interface +uses + uPSCompiler, uPSUtils; + +{ + Will register files from: + Classes (exception TPersistent and TComponent) + + Register STD first + +} + +procedure SIRegister_Classes_TypesAndConsts(Cl: TPSPascalCompiler); + +procedure SIRegisterTStrings(cl: TPSPascalCompiler; Streams: Boolean); +procedure SIRegisterTStringList(cl: TPSPascalCompiler); +{$IFNDEF PS_MINIVCL} +procedure SIRegisterTBITS(Cl: TPSPascalCompiler); +{$ENDIF} +procedure SIRegisterTSTREAM(Cl: TPSPascalCompiler); +procedure SIRegisterTHANDLESTREAM(Cl: TPSPascalCompiler); +{$IFNDEF PS_MINIVCL} +procedure SIRegisterTMEMORYSTREAM(Cl: TPSPascalCompiler); +{$ENDIF} +procedure SIRegisterTFILESTREAM(Cl: TPSPascalCompiler); +{$IFNDEF PS_MINIVCL} +procedure SIRegisterTCUSTOMMEMORYSTREAM(Cl: TPSPascalCompiler); +procedure SIRegisterTRESOURCESTREAM(Cl: TPSPascalCompiler); +procedure SIRegisterTPARSER(Cl: TPSPascalCompiler); +procedure SIRegisterTCOLLECTIONITEM(CL: TPSPascalCompiler); +procedure SIRegisterTCOLLECTION(CL: TPSPascalCompiler); +{$IFDEF DELPHI3UP} +procedure SIRegisterTOWNEDCOLLECTION(CL: TPSPascalCompiler); +{$ENDIF} +{$ENDIF} + +procedure SIRegister_Classes(Cl: TPSPascalCompiler; Streams: Boolean{$IFDEF D4PLUS}=True{$ENDIF}); + +implementation + +procedure SIRegisterTStrings(cl: TPSPascalCompiler; Streams: Boolean); // requires TPersistent +begin + with Cl.AddClassN(cl.FindClass('TPersistent'), 'TStrings') do + begin + IsAbstract := True; + RegisterMethod('function Add(S: string): Integer;'); + RegisterMethod('procedure Append(S: string);'); + RegisterMethod('procedure AddStrings(Strings: TStrings);'); + RegisterMethod('procedure Clear;'); + RegisterMethod('procedure Delete(Index: Integer);'); + RegisterMethod('function IndexOf(const S: string): Integer; '); + RegisterMethod('procedure Insert(Index: Integer; S: string); '); + RegisterProperty('Count', 'Integer', iptR); + RegisterProperty('Text', 'String', iptrw); + RegisterProperty('CommaText', 'String', iptrw); + if Streams then + begin + RegisterMethod('procedure LoadFromFile(FileName: string); '); + RegisterMethod('procedure SaveToFile(FileName: string); '); + end; + RegisterProperty('Strings', 'String Integer', iptRW); + SetDefaultPropery('Strings'); + RegisterProperty('Objects', 'TObject Integer', iptRW); + + {$IFNDEF PS_MINIVCL} + RegisterMethod('procedure BeginUpdate;'); + RegisterMethod('procedure EndUpdate;'); + RegisterMethod('function Equals(Strings: TStrings): Boolean;'); + RegisterMethod('procedure Exchange(Index1, Index2: Integer);'); + RegisterMethod('function IndexOfName(Name: string): Integer;'); + if Streams then + RegisterMethod('procedure LoadFromStream(Stream: TStream); '); + RegisterMethod('procedure Move(CurIndex, NewIndex: Integer); '); + if Streams then + RegisterMethod('procedure SaveToStream(Stream: TStream); '); + RegisterMethod('procedure SetText(Text: PChar); '); + RegisterProperty('Names', 'String Integer', iptr); + RegisterProperty('Values', 'String String', iptRW); + RegisterMethod('function AddObject(S:String;AObject:TObject):integer'); + RegisterMethod('function GetText:PChar'); + RegisterMethod('function IndexofObject(AObject:tObject):Integer'); + RegisterMethod('procedure InsertObject(Index:Integer;S:String;AObject:TObject)'); + {$ENDIF} + end; +end; + +procedure SIRegisterTSTRINGLIST(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TStrings'), 'TStringList') do + begin + RegisterMethod('function Find(S:String;var Index:Integer):Boolean'); + RegisterMethod('procedure Sort'); + RegisterProperty('Duplicates', 'TDuplicates', iptrw); + RegisterProperty('Sorted', 'Boolean', iptrw); + RegisterProperty('OnChange', 'TNotifyEvent', iptrw); + RegisterProperty('OnChanging', 'TNotifyEvent', iptrw); + end; +end; + +{$IFNDEF PS_MINIVCL} +procedure SIRegisterTBITS(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TObject'), 'TBits') do + begin + RegisterMethod('function OpenBit:Integer'); + RegisterProperty('Bits', 'Boolean Integer', iptrw); + RegisterProperty('Size', 'Integer', iptrw); + end; +end; +{$ENDIF} + +procedure SIRegisterTSTREAM(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TOBJECT'), 'TStream') do + begin + IsAbstract := True; + RegisterMethod('function Read(Buffer:String;Count:LongInt):LongInt'); + RegisterMethod('function Write(Buffer:String;Count:LongInt):LongInt'); + RegisterMethod('function Seek(Offset:LongInt;Origin:Word):LongInt'); + RegisterMethod('procedure ReadBuffer(Buffer:String;Count:LongInt)'); + RegisterMethod('procedure WriteBuffer(Buffer:String;Count:LongInt)'); + {$IFDEF DELPHI4UP} + RegisterMethod('function CopyFrom(Source:TStream;Count:Int64):LongInt'); + {$ELSE} + RegisterMethod('function CopyFrom(Source:TStream;Count:Integer):LongInt'); + {$ENDIF} + RegisterProperty('Position', 'LongInt', iptrw); + RegisterProperty('Size', 'LongInt', iptrw); + end; +end; + +procedure SIRegisterTHANDLESTREAM(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TSTREAM'), 'THandleStream') do + begin + RegisterMethod('constructor Create(AHandle:Integer)'); + RegisterProperty('Handle', 'Integer', iptr); + end; +end; + +{$IFNDEF PS_MINIVCL} +procedure SIRegisterTMEMORYSTREAM(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TCUSTOMMEMORYSTREAM'), 'TMemoryStream') do + begin + RegisterMethod('procedure Clear'); + RegisterMethod('procedure LoadFromStream(Stream:TStream)'); + RegisterMethod('procedure LoadFromFile(FileName:String)'); + RegisterMethod('procedure SetSize(NewSize:LongInt)'); + end; +end; +{$ENDIF} + +procedure SIRegisterTFILESTREAM(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('THandleStream'), 'TFileStream') do + begin + RegisterMethod('constructor Create(FileName:String;Mode:Word)'); + end; +end; + +{$IFNDEF PS_MINIVCL} +procedure SIRegisterTCUSTOMMEMORYSTREAM(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TSTREAM'), 'TCustomMemoryStream') do + begin + IsAbstract := True; + RegisterMethod('procedure SaveToStream(Stream:TStream)'); + RegisterMethod('procedure SaveToFile(FileName:String)'); + end; +end; + +procedure SIRegisterTRESOURCESTREAM(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TCUSTOMMEMORYSTREAM'), 'TResourceStream') do + begin + RegisterMethod('constructor Create(Instance:THandle;ResName:String;ResType:PChar)'); + RegisterMethod('constructor CreateFromId(Instance:THandle;ResId:Integer;ResType:PChar)'); + end; +end; + +procedure SIRegisterTPARSER(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TOBJECT'), 'TParser') do + begin + RegisterMethod('constructor Create(Stream:TStream)'); + RegisterMethod('procedure CheckToken(t:char)'); + RegisterMethod('procedure CheckTokenSymbol(s:string)'); + RegisterMethod('procedure Error(Ident:Integer)'); + RegisterMethod('procedure ErrorStr(Message:String)'); + RegisterMethod('procedure HexToBinary(Stream:TStream)'); + RegisterMethod('function NextToken:Char'); + RegisterMethod('function SourcePos:LongInt'); + RegisterMethod('function TokenComponentIdent:String'); + RegisterMethod('function TokenFloat:Extended'); + RegisterMethod('function TokenInt:LongInt'); + RegisterMethod('function TokenString:String'); + RegisterMethod('function TokenSymbolIs(S:String):Boolean'); + RegisterProperty('SourceLine', 'Integer', iptr); + RegisterProperty('Token', 'Char', iptr); + end; +end; + +procedure SIRegisterTCOLLECTIONITEM(CL: TPSPascalCompiler); +Begin + if cl.FindClass('TCOLLECTION') = nil then cl.AddClassN(cl.FindClass('TPERSISTENT'), 'TCollection'); + With cl.AddClassN(cl.FindClass('TPERSISTENT'),'TCollectionItem') do + begin + RegisterMethod('Constructor Create( Collection : TCollection)'); + RegisterProperty('Collection', 'TCollection', iptrw); +{$IFDEF DELPHI3UP} RegisterProperty('Id', 'Integer', iptr); {$ENDIF} + RegisterProperty('Index', 'Integer', iptrw); +{$IFDEF DELPHI3UP} RegisterProperty('DisplayName', 'String', iptrw); {$ENDIF} + end; +end; + +procedure SIRegisterTCOLLECTION(CL: TPSPascalCompiler); +var + cr: TPSCompileTimeClass; +Begin + cr := CL.FindClass('TCOLLECTION'); + if cr = nil then cr := cl.AddClassN(cl.FindClass('TPERSISTENT'), 'TCollection'); +With cr do + begin +// RegisterMethod('constructor Create( ItemClass : TCollectionItemClass)'); +{$IFDEF DELPHI3UP} RegisterMethod('function Owner : TPersistent'); {$ENDIF} + RegisterMethod('function Add : TCollectionItem'); + RegisterMethod('procedure BeginUpdate'); + RegisterMethod('procedure Clear'); +{$IFDEF DELPHI5UP} RegisterMethod('procedure Delete( Index : Integer)'); {$ENDIF} + RegisterMethod('procedure EndUpdate'); +{$IFDEF DELPHI3UP} RegisterMethod('function FindItemId( Id : Integer) : TCollectionItem'); {$ENDIF} +{$IFDEF DELPHI3UP} RegisterMethod('function Insert( Index : Integer) : TCollectionItem'); {$ENDIF} + RegisterProperty('Count', 'Integer', iptr); +{$IFDEF DELPHI3UP} RegisterProperty('ItemClass', 'TCollectionItemClass', iptr); {$ENDIF} + RegisterProperty('Items', 'TCollectionItem Integer', iptrw); + end; +end; + +{$IFDEF DELPHI3UP} +procedure SIRegisterTOWNEDCOLLECTION(CL: TPSPascalCompiler); +Begin +With Cl.AddClassN(cl.FindClass('TCOLLECTION'),'TOwnedCollection') do + begin +// RegisterMethod('Constructor CREATE( AOWNER : TPERSISTENT; ITEMCLASS : TCOLLECTIONITEMCLASS)'); + end; +end; +{$ENDIF} +{$ENDIF} + +procedure SIRegister_Classes_TypesAndConsts(Cl: TPSPascalCompiler); +begin + cl.AddConstantN('soFromBeginning', 'Longint').Value.ts32 := 0; + cl.AddConstantN('soFromCurrent', 'Longint').Value.ts32 := 1; + cl.AddConstantN('soFromEnd', 'Longint').Value.ts32 := 2; + cl.AddConstantN('toEOF', 'Char').SetString(#0); + cl.AddConstantN('toSymbol', 'Char').SetString(#1); + cl.AddConstantN('toString', 'Char').SetString(#2); + cl.AddConstantN('toInteger', 'Char').SetString(#3); + cl.AddConstantN('toFloat', 'Char').SetString(#4); + cl.AddConstantN('fmCreate', 'Longint').Value.ts32 := $FFFF; + cl.AddConstantN('fmOpenRead', 'Longint').Value.ts32 := 0; + cl.AddConstantN('fmOpenWrite', 'Longint').Value.ts32 := 1; + cl.AddConstantN('fmOpenReadWrite', 'Longint').Value.ts32 := 2; + cl.AddConstantN('fmShareCompat', 'Longint').Value.ts32 := 0; + cl.AddConstantN('fmShareExclusive', 'Longint').Value.ts32 := $10; + cl.AddConstantN('fmShareDenyWrite', 'Longint').Value.ts32 := $20; + cl.AddConstantN('fmShareDenyRead', 'Longint').Value.ts32 := $30; + cl.AddConstantN('fmShareDenyNone', 'Longint').Value.ts32 := $40; + cl.AddConstantN('SecsPerDay', 'Longint').Value.ts32 := 86400; + cl.AddConstantN('MSecPerDay', 'Longint').Value.ts32 := 86400000; + cl.AddConstantN('DateDelta', 'Longint').Value.ts32 := 693594; + cl.AddTypeS('TAlignment', '(taLeftJustify, taRightJustify, taCenter)'); + cl.AddTypeS('THelpEvent', 'function (Command: Word; Data: Longint; var CallHelp: Boolean): Boolean'); + cl.AddTypeS('TGetStrProc', 'procedure(const S: string)'); + cl.AddTypeS('TDuplicates', '(dupIgnore, dupAccept, dupError)'); + cl.AddTypeS('TOperation', '(opInsert, opRemove)'); + cl.AddTypeS('THANDLE', 'Longint'); + + cl.AddTypeS('TNotifyEvent', 'procedure (Sender: TObject)'); +end; + +procedure SIRegister_Classes(Cl: TPSPascalCompiler; Streams: Boolean); +begin + SIRegister_Classes_TypesAndConsts(Cl); + if Streams then + SIRegisterTSTREAM(Cl); + SIRegisterTStrings(cl, Streams); + SIRegisterTStringList(cl); + {$IFNDEF PS_MINIVCL} + SIRegisterTBITS(cl); + {$ENDIF} + if Streams then + begin + SIRegisterTHANDLESTREAM(Cl); + SIRegisterTFILESTREAM(Cl); + {$IFNDEF PS_MINIVCL} + SIRegisterTCUSTOMMEMORYSTREAM(Cl); + SIRegisterTMEMORYSTREAM(Cl); + SIRegisterTRESOURCESTREAM(Cl); + {$ENDIF} + end; + {$IFNDEF PS_MINIVCL} + SIRegisterTPARSER(Cl); + SIRegisterTCOLLECTIONITEM(Cl); + SIRegisterTCOLLECTION(Cl); + {$IFDEF DELPHI3UP} + SIRegisterTOWNEDCOLLECTION(Cl); + {$ENDIF} + {$ENDIF} +end; + +// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl) + + +end. diff --git a/Units/PascalScript/uPSC_comobj.pas b/Units/PascalScript/uPSC_comobj.pas new file mode 100644 index 0000000..16dd254 --- /dev/null +++ b/Units/PascalScript/uPSC_comobj.pas @@ -0,0 +1,28 @@ +{ compiletime ComObj support } +unit uPSC_comobj; + +{$I PascalScript.inc} +interface +uses + uPSCompiler, uPSUtils; + +{ + +Will register: + +function CreateOleObject(const ClassName: String): IDispatch; +function GetActiveOleObject(const ClassName: String): IDispatch; + +} + +procedure SIRegister_ComObj(cl: TPSPascalCompiler); + +implementation + +procedure SIRegister_ComObj(cl: TPSPascalCompiler); +begin + cl.AddDelphiFunction('function CreateOleObject(const ClassName: String): IDispatch;'); + cl.AddDelphiFunction('function GetActiveOleObject(const ClassName: String): IDispatch;'); +end; + +end. diff --git a/Units/PascalScript/uPSC_controls.pas b/Units/PascalScript/uPSC_controls.pas new file mode 100644 index 0000000..14d734b --- /dev/null +++ b/Units/PascalScript/uPSC_controls.pas @@ -0,0 +1,236 @@ +{ Compiletime Controls support } +unit uPSC_controls; +{$I PascalScript.inc} +interface +uses + uPSCompiler, uPSUtils; + +{ + Will register files from: + Controls + + Register the STD, Classes (at least the types&consts) and Graphics libraries first + +} + +procedure SIRegister_Controls_TypesAndConsts(Cl: TPSPascalCompiler); + +procedure SIRegisterTControl(Cl: TPSPascalCompiler); +procedure SIRegisterTWinControl(Cl: TPSPascalCompiler); +procedure SIRegisterTGraphicControl(cl: TPSPascalCompiler); +procedure SIRegisterTCustomControl(cl: TPSPascalCompiler); +procedure SIRegisterTDragObject(cl: TPSPascalCompiler); + +procedure SIRegister_Controls(Cl: TPSPascalCompiler); + + +implementation + +procedure SIRegisterTControl(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TComponent'), 'TCONTROL') do + begin + RegisterMethod('constructor Create(AOwner: TComponent);'); + RegisterMethod('procedure BringToFront;'); + RegisterMethod('procedure Hide;'); + RegisterMethod('procedure Invalidate;virtual;'); + RegisterMethod('procedure refresh;'); + RegisterMethod('procedure Repaint;virtual;'); + RegisterMethod('procedure SendToBack;'); + RegisterMethod('procedure Show;'); + RegisterMethod('procedure Update;virtual;'); + RegisterMethod('procedure SetBounds(x,y,w,h: Integer);virtual;'); + RegisterProperty('Left', 'Integer', iptRW); + RegisterProperty('Top', 'Integer', iptRW); + RegisterProperty('Width', 'Integer', iptRW); + RegisterProperty('Height', 'Integer', iptRW); + RegisterProperty('Hint', 'String', iptRW); + RegisterProperty('Align', 'TAlign', iptRW); + RegisterProperty('ClientHeight', 'Longint', iptRW); + RegisterProperty('ClientWidth', 'Longint', iptRW); + RegisterProperty('ShowHint', 'Boolean', iptRW); + RegisterProperty('Visible', 'Boolean', iptRW); + RegisterProperty('ENABLED', 'BOOLEAN', iptrw); + RegisterProperty('CURSOR', 'TCURSOR', iptrw); + + {$IFNDEF PS_MINIVCL} + RegisterMethod('function Dragging: Boolean;'); + RegisterMethod('function HasParent: Boolean'); + RegisterMethod('procedure BEGINDRAG(IMMEDIATE:BOOLEAN)'); + RegisterMethod('function CLIENTTOSCREEN(POINT:TPOINT):TPOINT'); + RegisterMethod('procedure ENDDRAG(DROP:BOOLEAN)'); + {$IFNDEF CLX} + RegisterMethod('function GETTEXTBUF(BUFFER:PCHAR;BUFSIZE:INTEGER):INTEGER'); + RegisterMethod('function GETTEXTLEN:INTEGER'); + RegisterMethod('procedure SETTEXTBUF(BUFFER:PCHAR)'); + RegisterMethod('function PERFORM(MSG:CARDINAL;WPARAM,LPARAM:LONGINT):LONGINT'); + {$ENDIF} + RegisterMethod('function SCREENTOCLIENT(POINT:TPOINT):TPOINT'); + {$ENDIF} + end; +end; + +procedure SIRegisterTWinControl(Cl: TPSPascalCompiler); // requires TControl +begin + with Cl.AddClassN(cl.FindClass('TControl'), 'TWINCONTROL') do + begin + + with Cl.FindClass('TControl') do + begin + RegisterProperty('Parent', 'TWinControl', iptRW); + end; + + {$IFNDEF CLX} + RegisterProperty('Handle', 'Longint', iptR); + {$ENDIF} + RegisterProperty('Showing', 'Boolean', iptR); + RegisterProperty('TabOrder', 'Integer', iptRW); + RegisterProperty('TabStop', 'Boolean', iptRW); + RegisterMethod('function CANFOCUS:BOOLEAN'); + RegisterMethod('function FOCUSED:BOOLEAN'); + RegisterProperty('CONTROLS', 'TCONTROL INTEGER', iptr); + RegisterProperty('CONTROLCOUNT', 'INTEGER', iptr); + + {$IFNDEF PS_MINIVCL} + RegisterMethod('function HandleAllocated: Boolean;'); + RegisterMethod('procedure HandleNeeded;'); + RegisterMethod('procedure EnableAlign;'); + RegisterMethod('procedure RemoveControl(AControl: TControl);'); + RegisterMethod('procedure InsertControl(AControl: TControl);'); + RegisterMethod('procedure Realign;'); + RegisterMethod('procedure ScaleBy(M, D: Integer);'); + RegisterMethod('procedure ScrollBy(DeltaX, DeltaY: Integer);'); + RegisterMethod('procedure SetFocus; virtual;'); + {$IFNDEF CLX} + RegisterMethod('procedure PAINTTO(DC:Longint;X,Y:INTEGER)'); + {$ENDIF} + + RegisterMethod('function CONTAINSCONTROL(CONTROL:TCONTROL):BOOLEAN'); + RegisterMethod('procedure DISABLEALIGN'); + RegisterMethod('procedure UPDATECONTROLSTATE'); + + RegisterProperty('BRUSH', 'TBRUSH', iptr); + RegisterProperty('HELPCONTEXT', 'LONGINT', iptrw); + {$ENDIF} + end; +end; +procedure SIRegisterTGraphicControl(cl: TPSPascalCompiler); // requires TControl +begin + Cl.AddClassN(cl.FindClass('TControl'), 'TGRAPHICCONTROL'); +end; + +procedure SIRegisterTCustomControl(cl: TPSPascalCompiler); // requires TWinControl +begin + Cl.AddClassN(cl.FindClass('TWinControl'), 'TCUSTOMCONTROL'); +end; + +procedure SIRegister_Controls_TypesAndConsts(Cl: TPSPascalCompiler); +begin +{$IFNDEF FPC} + Cl.addTypeS('TEShiftState','(ssShift, ssAlt, ssCtrl, ssLeft, ssRight, ssMiddle, ssDouble)'); + {$ELSE} + Cl.addTypeS('TEShiftState','(ssShift, ssAlt, ssCtrl, ssLeft, ssRight, ssMiddle, ssDouble,' + + 'ssMeta, ssSuper, ssHyper, ssAltGr, ssCaps, ssNum,ssScroll,ssTriple,ssQuad)'); + {$ENDIF} + Cl.addTypeS('TShiftState','set of TEShiftState'); + cl.AddTypeS('TMouseButton', '(mbLeft, mbRight, mbMiddle)'); + cl.AddTypeS('TDragMode', '(dmManual, dmAutomatic)'); + cl.AddTypeS('TDragState', '(dsDragEnter, dsDragLeave, dsDragMove)'); + cl.AddTypeS('TDragKind', '(dkDrag, dkDock)'); + cl.AddTypeS('TMouseEvent', 'procedure (Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);'); + cl.AddTypeS('TMouseMoveEvent', 'procedure(Sender: TObject; Shift: TShiftState; X, Y: Integer);'); + cl.AddTypeS('TKeyEvent', 'procedure (Sender: TObject; var Key: Word; Shift: TShiftState);'); + cl.AddTypeS('TKeyPressEvent', 'procedure(Sender: TObject; var Key: Char);'); + cl.AddTypeS('TDragOverEvent', 'procedure(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean)'); + cl.AddTypeS('TDragDropEvent', 'procedure(Sender, Source: TObject;X, Y: Integer)'); + cl.AddTypeS('HWND', 'Longint'); + + cl.AddTypeS('TEndDragEvent', 'procedure(Sender, Target: TObject; X, Y: Integer)'); + + cl.addTypeS('TAlign', '(alNone, alTop, alBottom, alLeft, alRight, alClient)'); + + cl.addTypeS('TAnchorKind', '(akTop, akLeft, akRight, akBottom)'); + cl.addTypeS('TAnchors','set of TAnchorKind'); + cl.AddTypeS('TModalResult', 'Integer'); + cl.AddTypeS('TCursor', 'Integer'); + cl.AddTypeS('TPoint', 'record x,y: Longint; end;'); + + cl.AddConstantN('mrNone', 'Integer').Value.ts32 := 0; + cl.AddConstantN('mrOk', 'Integer').Value.ts32 := 1; + cl.AddConstantN('mrCancel', 'Integer').Value.ts32 := 2; + cl.AddConstantN('mrAbort', 'Integer').Value.ts32 := 3; + cl.AddConstantN('mrRetry', 'Integer').Value.ts32 := 4; + cl.AddConstantN('mrIgnore', 'Integer').Value.ts32 := 5; + cl.AddConstantN('mrYes', 'Integer').Value.ts32 := 6; + cl.AddConstantN('mrNo', 'Integer').Value.ts32 := 7; + cl.AddConstantN('mrAll', 'Integer').Value.ts32 := 8; + cl.AddConstantN('mrNoToAll', 'Integer').Value.ts32 := 9; + cl.AddConstantN('mrYesToAll', 'Integer').Value.ts32 := 10; + cl.AddConstantN('crDefault', 'Integer').Value.ts32 := 0; + cl.AddConstantN('crNone', 'Integer').Value.ts32 := -1; + cl.AddConstantN('crArrow', 'Integer').Value.ts32 := -2; + cl.AddConstantN('crCross', 'Integer').Value.ts32 := -3; + cl.AddConstantN('crIBeam', 'Integer').Value.ts32 := -4; + cl.AddConstantN('crSizeNESW', 'Integer').Value.ts32 := -6; + cl.AddConstantN('crSizeNS', 'Integer').Value.ts32 := -7; + cl.AddConstantN('crSizeNWSE', 'Integer').Value.ts32 := -8; + cl.AddConstantN('crSizeWE', 'Integer').Value.ts32 := -9; + cl.AddConstantN('crUpArrow', 'Integer').Value.ts32 := -10; + cl.AddConstantN('crHourGlass', 'Integer').Value.ts32 := -11; + cl.AddConstantN('crDrag', 'Integer').Value.ts32 := -12; + cl.AddConstantN('crNoDrop', 'Integer').Value.ts32 := -13; + cl.AddConstantN('crHSplit', 'Integer').Value.ts32 := -14; + cl.AddConstantN('crVSplit', 'Integer').Value.ts32 := -15; + cl.AddConstantN('crMultiDrag', 'Integer').Value.ts32 := -16; + cl.AddConstantN('crSQLWait', 'Integer').Value.ts32 := -17; + cl.AddConstantN('crNo', 'Integer').Value.ts32 := -18; + cl.AddConstantN('crAppStart', 'Integer').Value.ts32 := -19; + cl.AddConstantN('crHelp', 'Integer').Value.ts32 := -20; +{$IFDEF DELPHI3UP} + cl.AddConstantN('crHandPoint', 'Integer').Value.ts32 := -21; +{$ENDIF} +{$IFDEF DELPHI4UP} + cl.AddConstantN('crSizeAll', 'Integer').Value.ts32 := -22; +{$ENDIF} +end; + +procedure SIRegisterTDragObject(cl: TPSPascalCompiler); +begin + with CL.AddClassN(CL.FindClass('TObject'),'TDragObject') do + begin +{$IFNDEF PS_MINIVCL} +{$IFDEF DELPHI4UP} + RegisterMethod('Procedure Assign( Source : TDragObject)'); +{$ENDIF} +{$IFNDEF FPC} + RegisterMethod('Function GetName : String'); + RegisterMethod('Function Instance : Longint'); +{$ENDIF} + RegisterMethod('Procedure HideDragImage'); + RegisterMethod('Procedure ShowDragImage'); +{$IFDEF DELPHI4UP} + RegisterProperty('Cancelling', 'Boolean', iptrw); + RegisterProperty('DragHandle', 'Longint', iptrw); + RegisterProperty('DragPos', 'TPoint', iptrw); + RegisterProperty('DragTargetPos', 'TPoint', iptrw); + RegisterProperty('MouseDeltaX', 'Double', iptr); + RegisterProperty('MouseDeltaY', 'Double', iptr); +{$ENDIF} +{$ENDIF} + end; + Cl.AddTypeS('TStartDragEvent', 'procedure (Sender: TObject; var DragObject: TDragObject)'); +end; + +procedure SIRegister_Controls(Cl: TPSPascalCompiler); +begin + SIRegister_Controls_TypesAndConsts(cl); + SIRegisterTDragObject(cl); + SIRegisterTControl(Cl); + SIRegisterTWinControl(Cl); + SIRegisterTGraphicControl(cl); + SIRegisterTCustomControl(cl); +end; + +// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl) + +end. diff --git a/Units/PascalScript/uPSC_dateutils.pas b/Units/PascalScript/uPSC_dateutils.pas new file mode 100644 index 0000000..f6213c7 --- /dev/null +++ b/Units/PascalScript/uPSC_dateutils.pas @@ -0,0 +1,34 @@ +{ Compile time Date Time library } +unit uPSC_dateutils; + +interface +uses + SysUtils, uPSCompiler, uPSUtils; + + +procedure RegisterDateTimeLibrary_C(S: TPSPascalCompiler); + +implementation + +procedure RegisterDatetimeLibrary_C(S: TPSPascalCompiler); +begin + s.AddType('TDateTime', btDouble).ExportName := True; + s.AddDelphiFunction('function EncodeDate(Year, Month, Day: Word): TDateTime;'); + s.AddDelphiFunction('function EncodeTime(Hour, Min, Sec, MSec: Word): TDateTime;'); + s.AddDelphiFunction('function TryEncodeDate(Year, Month, Day: Word; var Date: TDateTime): Boolean;'); + s.AddDelphiFunction('function TryEncodeTime(Hour, Min, Sec, MSec: Word; var Time: TDateTime): Boolean;'); + s.AddDelphiFunction('procedure DecodeDate(const DateTime: TDateTime; var Year, Month, Day: Word);'); + s.AddDelphiFunction('procedure DecodeTime(const DateTime: TDateTime; var Hour, Min, Sec, MSec: Word);'); + s.AddDelphiFunction('function DayOfWeek(const DateTime: TDateTime): Word;'); + s.AddDelphiFunction('function Date: TDateTime;'); + s.AddDelphiFunction('function Time: TDateTime;'); + s.AddDelphiFunction('function Now: TDateTime;'); + s.AddDelphiFunction('function DateTimeToUnix(D: TDateTime): Int64;'); + s.AddDelphiFunction('function UnixToDateTime(U: Int64): TDateTime;'); + + s.AddDelphiFunction('function DateToStr(D: TDateTime): String;'); + s.AddDelphiFunction('function StrToDate(const s: String): TDateTime;'); + s.AddDelphiFunction('function FormatDateTime(const fmt: String; D: TDateTime): String;'); +end; + +end. diff --git a/Units/PascalScript/uPSC_dll.pas b/Units/PascalScript/uPSC_dll.pas new file mode 100644 index 0000000..dd5fcd6 --- /dev/null +++ b/Units/PascalScript/uPSC_dll.pas @@ -0,0 +1,158 @@ +{ Compiletime DLL importing support } +unit uPSC_dll; + +{$I PascalScript.inc} +interface +{ + + Function FindWindow(c1, c2: PChar): Cardinal; external 'FindWindow@user32.dll stdcall'; + +} +uses + uPSCompiler, uPSUtils; + + +{$IFDEF DELPHI3UP } +resourceString +{$ELSE } +const +{$ENDIF } + + RPS_Invalid_External = 'Invalid External'; + RPS_InvalidCallingConvention = 'Invalid Calling Convention'; + + + +function DllExternalProc(Sender: TPSPascalCompiler; Decl: TPSParametersDecl; const OriginalName, FExternal: tbtstring): TPSRegProc; +type + + TDllCallingConvention = (clRegister + , clPascal + , ClCdecl + , ClStdCall + ); + +var + DefaultCC: TDllCallingConvention; + +procedure RegisterDll_Compiletime(cs: TPSPascalCompiler); + +implementation + +function rpos(ch: tbtchar; const s: tbtstring): Longint; +var + i: Longint; +begin + for i := length(s) downto 1 do + if s[i] = ch then begin Result := i; exit; end; + result := 0; +end; + +function RemoveQuotes(s: tbtstring): tbtstring; +begin + result := s; + if result = '' then exit; + if Result[1] = '"' then delete(result ,1,1); + if (Result <> '') and (Result[Length(result)] = '"') then delete(result, length(result), 1); +end; + +function DllExternalProc(Sender: TPSPascalCompiler; Decl: TPSParametersDecl; const OriginalName, FExternal: tbtstring): TPSRegProc; +var + FuncName, + Name, + FuncCC, s, s2: AnsiString; + CC: TDllCallingConvention; + DelayLoad, LoadWithAlteredSearchPath: Boolean; + +begin + Name := FastUpperCase(OriginalName); + DelayLoad := False; + LoadWithAlteredSearchPath := false; + FuncCC := FExternal; + + if (pos(tbtChar('@'), FuncCC) = 0) then + begin + Sender.MakeError('', ecCustomError, tbtString(RPS_Invalid_External)); + Result := nil; + exit; + end; + FuncName := copy(FuncCC, 1, rpos('@', FuncCC)-1)+#0; + delete(FuncCc, 1, length(FuncName)); + if pos(tbtchar(' '), Funccc) <> 0 then + begin + if FuncCC[1] = '"' then + begin + Delete(FuncCC, 1, 1); + FuncName := RemoveQuotes(copy(FuncCC, 1, pos(tbtchar('"'), FuncCC)-1))+#0+FuncName; + Delete(FuncCC,1, pos(tbtchar('"'), FuncCC)); + if (FuncCC <> '') and( FuncCC[1] = ' ') then delete(FuncCC,1,1); + end else + begin + FuncName := copy(FuncCc, 1, pos(tbtchar(' '),FuncCC)-1)+#0+FuncName; + Delete(FuncCC, 1, pos(tbtchar(' '), FuncCC)); + end; + if pos(tbtchar(' '), FuncCC) > 0 then + begin + s := Copy(FuncCC, pos(tbtchar(' '), Funccc)+1, MaxInt); + FuncCC := FastUpperCase(Copy(FuncCC, 1, pos(tbtchar(' '), FuncCC)-1)); + Delete(FuncCC, pos(tbtchar(' '), Funccc), MaxInt); + repeat + if pos(tbtchar(' '), s) > 0 then begin + s2 := Copy(s, 1, pos(tbtchar(' '), s)-1); + delete(s, 1, pos(tbtchar(' '), s)); + end else begin + s2 := s; + s := ''; + end; + if FastUppercase(s2) = 'DELAYLOAD' then + DelayLoad := True + {$IFNDEF LINUX} + else + if FastUppercase(s2) = 'LOADWITHALTEREDSEARCHPATH' then + LoadWithAlteredSearchPath := True + {$ENDIF} + else + begin + Sender.MakeError('', ecCustomError, 'Invalid External'); + Result := nil; + exit; + end; + until s = ''; + + end else + FuncCC := FastUpperCase(FuncCC); + if FuncCC = 'STDCALL' then cc := ClStdCall else + if FuncCC = 'CDECL' then cc := ClCdecl else + if FuncCC = 'REGISTER' then cc := clRegister else + if FuncCC = 'PASCAL' then cc := clPascal else + begin + Sender.MakeError('', ecCustomError, tbtstring(RPS_InvalidCallingConvention)); + Result := nil; + exit; + end; + end else + begin + FuncName := RemoveQuotes(FuncCC)+#0+FuncName; + FuncCC := ''; + cc := DefaultCC; + end; + FuncName := 'dll:'+FuncName+tbtchar(cc)+tbtchar(bytebool(DelayLoad)) +tbtchar(bytebool(LoadWithAlteredSearchPath))+ declToBits(Decl); + Result := TPSRegProc.Create; + Result.ImportDecl := FuncName; + Result.Decl.Assign(Decl); + Result.Name := Name; + Result.OrgName := OriginalName; + Result.ExportName := False; +end; + +procedure RegisterDll_Compiletime(cs: TPSPascalCompiler); +begin + cs.OnExternalProc := DllExternalProc; + cs.AddFunction('procedure UnloadDll(s: string)'); + cs.AddFunction('function DLLGetLastError: Longint'); +end; + +begin + DefaultCc := clRegister; +end. + diff --git a/Units/PascalScript/uPSC_extctrls.pas b/Units/PascalScript/uPSC_extctrls.pas new file mode 100644 index 0000000..785b5d3 --- /dev/null +++ b/Units/PascalScript/uPSC_extctrls.pas @@ -0,0 +1,327 @@ +{ Compiletime Extctrls support } +unit uPSC_extctrls; + +{$I PascalScript.inc} +interface +uses + uPSCompiler, uPSUtils; + +(* + Will register files from: + ExtCtrls + +Requires: + STD, classes, controls, graphics {$IFNDEF PS_MINIVCL}, stdctrls {$ENDIF} +*) + +procedure SIRegister_ExtCtrls_TypesAndConsts(cl: TPSPascalCompiler); + +procedure SIRegisterTSHAPE(Cl: TPSPascalCompiler); +procedure SIRegisterTIMAGE(Cl: TPSPascalCompiler); +procedure SIRegisterTPAINTBOX(Cl: TPSPascalCompiler); +procedure SIRegisterTBEVEL(Cl: TPSPascalCompiler); +procedure SIRegisterTTIMER(Cl: TPSPascalCompiler); +procedure SIRegisterTCUSTOMPANEL(Cl: TPSPascalCompiler); +procedure SIRegisterTPANEL(Cl: TPSPascalCompiler); +{$IFNDEF CLX} +procedure SIRegisterTPAGE(Cl: TPSPascalCompiler); +procedure SIRegisterTNOTEBOOK(Cl: TPSPascalCompiler); +procedure SIRegisterTHEADER(Cl: TPSPascalCompiler); +{$ENDIF} +procedure SIRegisterTCUSTOMRADIOGROUP(Cl: TPSPascalCompiler); +procedure SIRegisterTRADIOGROUP(Cl: TPSPascalCompiler); + +procedure SIRegister_ExtCtrls(cl: TPSPascalCompiler); + +implementation +procedure SIRegisterTSHAPE(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TGRAPHICCONTROL'), 'TSHAPE') do + begin + RegisterProperty('BRUSH', 'TBRUSH', iptrw); + RegisterProperty('PEN', 'TPEN', iptrw); + RegisterProperty('SHAPE', 'TSHAPETYPE', iptrw); + + {$IFNDEF PS_MINIVCL} + RegisterMethod('procedure STYLECHANGED(SENDER:TOBJECT)'); + RegisterProperty('DRAGCURSOR', 'Longint', iptrw); + RegisterProperty('DRAGMODE', 'TDragMode', iptrw); + RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw); + RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw); + RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw); + RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw); + RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw); + RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw); + RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw); + RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw); + {$ENDIF} + end; +end; + +procedure SIRegisterTIMAGE(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TGRAPHICCONTROL'), 'TIMAGE') do + begin + RegisterProperty('CANVAS', 'TCANVAS', iptr); + RegisterProperty('AUTOSIZE', 'BOOLEAN', iptrw); + RegisterProperty('CENTER', 'BOOLEAN', iptrw); + RegisterProperty('PICTURE', 'TPICTURE', iptrw); + RegisterProperty('STRETCH', 'BOOLEAN', iptrw); + RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw); + RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw); + + {$IFNDEF PS_MINIVCL} + RegisterProperty('DRAGCURSOR', 'Longint', iptrw); + RegisterProperty('DRAGMODE', 'TDragMode', iptrw); + RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw); + RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw); + RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw); + RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw); + RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw); + RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw); + RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw); + RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw); + RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw); + {$ENDIF} + end; +end; + +procedure SIRegisterTPAINTBOX(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TGRAPHICCONTROL'), 'TPAINTBOX') do + begin + RegisterProperty('CANVAS', 'TCanvas', iptr); + RegisterProperty('COLOR', 'TColor', iptrw); + RegisterProperty('FONT', 'TFont', iptrw); + RegisterProperty('PARENTCOLOR', 'Boolean', iptrw); + RegisterProperty('PARENTFONT', 'Boolean', iptrw); + RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw); + RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw); + RegisterProperty('ONPAINT', 'TNOTIFYEVENT', iptrw); + + {$IFNDEF PS_MINIVCL} + RegisterProperty('DRAGCURSOR', 'Longint', iptrw); + RegisterProperty('DRAGMODE', 'TDragMode', iptrw); + RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw); + RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw); + RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw); + RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw); + RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw); + RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw); + RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw); + RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw); + RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw); + {$ENDIF} + end; +end; + +procedure SIRegisterTBEVEL(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TGRAPHICCONTROL'), 'TBEVEL') do + begin + RegisterProperty('SHAPE', 'TBEVELSHAPE', iptrw); + RegisterProperty('STYLE', 'TBEVELSTYLE', iptrw); + + {$IFNDEF PS_MINIVCL} + RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw); + {$ENDIF} + end; +end; + +procedure SIRegisterTTIMER(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TCOMPONENT'), 'TTIMER') do + begin + RegisterProperty('ENABLED', 'BOOLEAN', iptrw); + RegisterProperty('INTERVAL', 'CARDINAL', iptrw); + RegisterProperty('ONTIMER', 'TNOTIFYEVENT', iptrw); + end; +end; + +procedure SIRegisterTCUSTOMPANEL(Cl: TPSPascalCompiler); +begin + Cl.AddClassN(cl.FindClass('TCUSTOMCONTROL'), 'TCUSTOMPANEL'); +end; + +procedure SIRegisterTPANEL(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TCUSTOMPANEL'), 'TPANEL') do + begin + RegisterProperty('ALIGNMENT', 'TAlignment', iptrw); + RegisterProperty('BEVELINNER', 'TPanelBevel', iptrw); + RegisterProperty('BEVELOUTER', 'TPanelBevel', iptrw); + RegisterProperty('BEVELWIDTH', 'TBevelWidth', iptrw); + RegisterProperty('BORDERWIDTH', 'TBorderWidth', iptrw); + RegisterProperty('BORDERSTYLE', 'TBorderStyle', iptrw); + RegisterProperty('CAPTION', 'String', iptrw); + RegisterProperty('COLOR', 'TColor', iptrw); + RegisterProperty('FONT', 'TFont', iptrw); + RegisterProperty('PARENTCOLOR', 'Boolean', iptrw); + RegisterProperty('PARENTFONT', 'Boolean', iptrw); + RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw); + RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw); + RegisterProperty('ONENTER', 'TNotifyEvent', iptrw); + RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw); + + {$IFNDEF PS_MINIVCL} + RegisterProperty('DRAGCURSOR', 'Longint', iptrw); + RegisterProperty('DRAGMODE', 'TDragMode', iptrw); + RegisterProperty('CTL3D', 'Boolean', iptrw); + RegisterProperty('LOCKED', 'Boolean', iptrw); + RegisterProperty('PARENTCTL3D', 'Boolean', iptrw); + RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw); + RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw); + RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw); + RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw); + RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw); + RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw); + RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw); + RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw); + RegisterProperty('ONRESIZE', 'TNotifyEvent', iptrw); + RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw); + {$ENDIF} + end; +end; +{$IFNDEF CLX} +procedure SIRegisterTPAGE(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TCUSTOMCONTROL'), 'TPAGE') do + begin + RegisterProperty('CAPTION', 'String', iptrw); + end; +end; +procedure SIRegisterTNOTEBOOK(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TCUSTOMCONTROL'), 'TNOTEBOOK') do + begin + RegisterProperty('ACTIVEPAGE', 'String', iptrw); + RegisterProperty('COLOR', 'TColor', iptrw); + RegisterProperty('FONT', 'TFont', iptrw); + RegisterProperty('PAGEINDEX', 'INTEGER', iptrw); + RegisterProperty('PAGES', 'TSTRINGS', iptrw); + RegisterProperty('PARENTCOLOR', 'Boolean', iptrw); + RegisterProperty('PARENTFONT', 'Boolean', iptrw); + RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw); + RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw); + RegisterProperty('ONENTER', 'TNotifyEvent', iptrw); + RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw); + RegisterProperty('ONPAGECHANGED', 'TNOTIFYEVENT', iptrw); + + {$IFNDEF PS_MINIVCL} + RegisterProperty('CTL3D', 'Boolean', iptrw); + RegisterProperty('DRAGCURSOR', 'Longint', iptrw); + RegisterProperty('DRAGMODE', 'TDragMode', iptrw); + RegisterProperty('PARENTCTL3D', 'Boolean', iptrw); + RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw); + RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw); + RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw); + RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw); + RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw); + RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw); + RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw); + RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw); + RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw); + {$ENDIF} + end; +end; + +procedure SIRegisterTHEADER(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TCUSTOMCONTROL'), 'THEADER') do + begin + RegisterProperty('SECTIONWIDTH', 'INTEGER INTEGER', iptrw); + RegisterProperty('ALLOWRESIZE', 'BOOLEAN', iptrw); + RegisterProperty('BORDERSTYLE', 'TBORDERSTYLE', iptrw); + RegisterProperty('FONT', 'TFont', iptrw); + RegisterProperty('PARENTFONT', 'Boolean', iptrw); + RegisterProperty('SECTIONS', 'TSTRINGS', iptrw); + RegisterProperty('ONSIZING', 'TSECTIONEVENT', iptrw); + RegisterProperty('ONSIZED', 'TSECTIONEVENT', iptrw); + + {$IFNDEF PS_MINIVCL} + RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw); + RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw); + {$ENDIF} + end; +end; +{$ENDIF} + +procedure SIRegisterTCUSTOMRADIOGROUP(Cl: TPSPascalCompiler); +begin + Cl.AddClassN(cl.FindClass('TCUSTOMGROUPBOX'), 'TCUSTOMRADIOGROUP'); +end; + +procedure SIRegisterTRADIOGROUP(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TCUSTOMRADIOGROUP'), 'TRADIOGROUP') do + begin + RegisterProperty('CAPTION', 'String', iptrw); + RegisterProperty('COLOR', 'TColor', iptrw); + RegisterProperty('COLUMNS', 'Integer', iptrw); + RegisterProperty('FONT', 'TFont', iptrw); + RegisterProperty('ITEMINDEX', 'Integer', iptrw); + RegisterProperty('ITEMS', 'TStrings', iptrw); + RegisterProperty('PARENTCOLOR', 'Boolean', iptrw); + RegisterProperty('PARENTFONT', 'Boolean', iptrw); + RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw); + RegisterProperty('ONENTER', 'TNotifyEvent', iptrw); + RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw); + + {$IFNDEF PS_MINIVCL} + RegisterProperty('CTL3D', 'Boolean', iptrw); + RegisterProperty('DRAGCURSOR', 'Longint', iptrw); + RegisterProperty('DRAGMODE', 'TDragMode', iptrw); + RegisterProperty('PARENTCTL3D', 'Boolean', iptrw); + RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw); + RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw); + RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw); + RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw); + RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw); + RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw); + {$ENDIF} + end; +end; + +procedure SIRegister_ExtCtrls_TypesAndConsts(cl: TPSPascalCompiler); +begin + cl.AddTypeS('TShapeType', '(stRectangle, stSquare, stRoundRect, stRoundSquare, stEllipse, stCircle)'); + cl.AddTypeS('TBevelStyle', '(bsLowered, bsRaised)'); + cl.AddTypeS('TBevelShape', '(bsBox, bsFrame, bsTopLine, bsBottomLine, bsLeftLine, bsRightLine,bsSpacer)'); + cl.AddTypeS('TPanelBevel', '(bvNone, bvLowered, bvRaised,bvSpace)'); + cl.AddTypeS('TBevelWidth', 'Longint'); + cl.AddTypeS('TBorderWidth', 'Longint'); + cl.AddTypeS('TSectionEvent', 'procedure(Sender: TObject; ASection, AWidth: Integer)'); +end; + +procedure SIRegister_ExtCtrls(cl: TPSPascalCompiler); +begin + SIRegister_ExtCtrls_TypesAndConsts(cl); + + {$IFNDEF PS_MINIVCL} + SIRegisterTSHAPE(Cl); + SIRegisterTIMAGE(Cl); + SIRegisterTPAINTBOX(Cl); + {$ENDIF} + SIRegisterTBEVEL(Cl); + {$IFNDEF PS_MINIVCL} + SIRegisterTTIMER(Cl); + {$ENDIF} + SIRegisterTCUSTOMPANEL(Cl); + SIRegisterTPANEL(Cl); + {$IFNDEF PS_MINIVCL} + {$IFNDEF CLX} + SIRegisterTPAGE(Cl); + SIRegisterTNOTEBOOK(Cl); + SIRegisterTHEADER(Cl); + {$ENDIF} + SIRegisterTCUSTOMRADIOGROUP(Cl); + SIRegisterTRADIOGROUP(Cl); + {$ENDIF} +end; + +end. + + + + + diff --git a/Units/PascalScript/uPSC_forms.pas b/Units/PascalScript/uPSC_forms.pas new file mode 100644 index 0000000..7969094 --- /dev/null +++ b/Units/PascalScript/uPSC_forms.pas @@ -0,0 +1,271 @@ +{ Compiletime Forms support } +unit uPSC_forms; +{$I PascalScript.inc} + +interface +uses + uPSCompiler, uPSUtils; + +procedure SIRegister_Forms_TypesAndConsts(Cl: TPSPascalCompiler); + + +procedure SIRegisterTCONTROLSCROLLBAR(Cl: TPSPascalCompiler); +procedure SIRegisterTSCROLLINGWINCONTROL(Cl: TPSPascalCompiler); +procedure SIRegisterTSCROLLBOX(Cl: TPSPascalCompiler); +procedure SIRegisterTFORM(Cl: TPSPascalCompiler); +procedure SIRegisterTAPPLICATION(Cl: TPSPascalCompiler); + +procedure SIRegister_Forms(Cl: TPSPascalCompiler); + +implementation + +procedure SIRegisterTCONTROLSCROLLBAR(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TPERSISTENT'), 'TCONTROLSCROLLBAR') do + begin + RegisterProperty('KIND', 'TSCROLLBARKIND', iptr); + RegisterProperty('SCROLLPOS', 'INTEGER', iptr); + RegisterProperty('MARGIN', 'WORD', iptrw); + RegisterProperty('INCREMENT', 'TSCROLLBARINC', iptrw); + RegisterProperty('RANGE', 'INTEGER', iptrw); + RegisterProperty('POSITION', 'INTEGER', iptrw); + RegisterProperty('TRACKING', 'BOOLEAN', iptrw); + RegisterProperty('VISIBLE', 'BOOLEAN', iptrw); + end; +end; + +procedure SIRegisterTSCROLLINGWINCONTROL(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TWINCONTROL'), 'TSCROLLINGWINCONTROL') do + begin + RegisterMethod('procedure SCROLLINVIEW(ACONTROL:TCONTROL)'); + RegisterProperty('HORZSCROLLBAR', 'TCONTROLSCROLLBAR', iptrw); + RegisterProperty('VERTSCROLLBAR', 'TCONTROLSCROLLBAR', iptrw); + end; +end; + +procedure SIRegisterTSCROLLBOX(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TSCROLLINGWINCONTROL'), 'TSCROLLBOX') do + begin + RegisterProperty('BORDERSTYLE', 'TBORDERSTYLE', iptrw); + RegisterProperty('COLOR', 'TCOLOR', iptrw); + RegisterProperty('FONT', 'TFONT', iptrw); + RegisterProperty('AUTOSCROLL', 'BOOLEAN', iptrw); + RegisterProperty('PARENTCOLOR', 'BOOLEAN', iptrw); + RegisterProperty('PARENTFONT', 'BOOLEAN', iptrw); + RegisterProperty('ONCLICK', 'TNOTIFYEVENT', iptrw); + RegisterProperty('ONDBLCLICK', 'TNOTIFYEVENT', iptrw); + RegisterProperty('ONENTER', 'TNOTIFYEVENT', iptrw); + RegisterProperty('ONEXIT', 'TNOTIFYEVENT', iptrw); + + {$IFNDEF PS_MINIVCL} + RegisterProperty('ONRESIZE', 'TNOTIFYEVENT', iptrw); + RegisterProperty('DRAGCURSOR', 'TCURSOR', iptrw); + RegisterProperty('DRAGMODE', 'TDRAGMODE', iptrw); + RegisterProperty('PARENTSHOWHINT', 'BOOLEAN', iptrw); + RegisterProperty('POPUPMENU', 'TPOPUPMENU', iptrw); + RegisterProperty('CTL3D', 'BOOLEAN', iptrw); + RegisterProperty('PARENTCTL3D', 'BOOLEAN', iptrw); + RegisterProperty('ONDRAGDROP', 'TDRAGDROPEVENT', iptrw); + RegisterProperty('ONDRAGOVER', 'TDRAGOVEREVENT', iptrw); + RegisterProperty('ONENDDRAG', 'TENDDRAGEVENT', iptrw); + RegisterProperty('ONMOUSEDOWN', 'TMOUSEEVENT', iptrw); + RegisterProperty('ONMOUSEMOVE', 'TMOUSEMOVEEVENT', iptrw); + RegisterProperty('ONMOUSEUP', 'TMOUSEEVENT', iptrw); + {$ENDIF} + end; +end; + +procedure SIRegisterTFORM(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TSCROLLINGWINCONTROL'), 'TFORM') do + begin + {$IFDEF DELPHI4UP} + RegisterMethod('constructor CREATENEW(AOWNER:TCOMPONENT; Dummy: Integer)'); + {$ELSE} + RegisterMethod('constructor CREATENEW(AOWNER:TCOMPONENT)'); + {$ENDIF} + RegisterMethod('procedure CLOSE'); + RegisterMethod('procedure HIDE'); + RegisterMethod('procedure SHOW'); + RegisterMethod('function SHOWMODAL:INTEGER'); + RegisterMethod('procedure RELEASE'); + RegisterProperty('ACTIVE', 'BOOLEAN', iptr); + RegisterProperty('ACTIVECONTROL', 'TWINCONTROL', iptrw); + RegisterProperty('BORDERICONS', 'TBorderIcons', iptrw); + RegisterProperty('BORDERSTYLE', 'TFORMBORDERSTYLE', iptrw); + RegisterProperty('CAPTION', 'NativeString', iptrw); + RegisterProperty('AUTOSCROLL', 'BOOLEAN', iptrw); + RegisterProperty('COLOR', 'TCOLOR', iptrw); + RegisterProperty('FONT', 'TFONT', iptrw); + RegisterProperty('FORMSTYLE', 'TFORMSTYLE', iptrw); + RegisterProperty('KEYPREVIEW', 'BOOLEAN', iptrw); + RegisterProperty('POSITION', 'TPOSITION', iptrw); + RegisterProperty('ONACTIVATE', 'TNOTIFYEVENT', iptrw); + RegisterProperty('ONCLICK', 'TNOTIFYEVENT', iptrw); + RegisterProperty('ONDBLCLICK', 'TNOTIFYEVENT', iptrw); + RegisterProperty('ONCLOSE', 'TCLOSEEVENT', iptrw); + RegisterProperty('ONCLOSEQUERY', 'TCLOSEQUERYEVENT', iptrw); + RegisterProperty('ONCREATE', 'TNOTIFYEVENT', iptrw); + RegisterProperty('ONDESTROY', 'TNOTIFYEVENT', iptrw); + RegisterProperty('ONDEACTIVATE', 'TNOTIFYEVENT', iptrw); + RegisterProperty('ONHIDE', 'TNOTIFYEVENT', iptrw); + RegisterProperty('ONKEYDOWN', 'TKEYEVENT', iptrw); + RegisterProperty('ONKEYPRESS', 'TKEYPRESSEVENT', iptrw); + RegisterProperty('ONKEYUP', 'TKEYEVENT', iptrw); + RegisterProperty('ONRESIZE', 'TNOTIFYEVENT', iptrw); + RegisterProperty('ONSHOW', 'TNOTIFYEVENT', iptrw); + + + {$IFNDEF PS_MINIVCL} + {$IFNDEF CLX} + RegisterMethod('procedure ARRANGEICONS'); +// RegisterMethod('function GETFORMIMAGE:TBITMAP'); + RegisterMethod('procedure PRINT'); + RegisterMethod('procedure SENDCANCELMODE(SENDER:TCONTROL)'); + RegisterProperty('ACTIVEOLECONTROL', 'TWINCONTROL', iptrw); + RegisterProperty('OLEFORMOBJECT', 'TOLEFORMOBJECT', iptrw); + RegisterProperty('CLIENTHANDLE', 'LONGINT', iptr); + RegisterProperty('TILEMODE', 'TTILEMODE', iptrw); + {$ENDIF} + RegisterMethod('procedure CASCADE'); + RegisterMethod('function CLOSEQUERY:BOOLEAN'); + RegisterMethod('procedure DEFOCUSCONTROL(CONTROL:TWINCONTROL;REMOVING:BOOLEAN)'); + RegisterMethod('procedure FOCUSCONTROL(CONTROL:TWINCONTROL)'); + RegisterMethod('procedure NEXT'); + RegisterMethod('procedure PREVIOUS'); + RegisterMethod('function SETFOCUSEDCONTROL(CONTROL:TWINCONTROL):BOOLEAN'); + RegisterMethod('procedure TILE'); + RegisterProperty('ACTIVEMDICHILD', 'TFORM', iptr); + RegisterProperty('CANVAS', 'TCANVAS', iptr); + RegisterProperty('DROPTARGET', 'BOOLEAN', iptrw); + RegisterProperty('MODALRESULT', 'Longint', iptrw); + RegisterProperty('MDICHILDCOUNT', 'INTEGER', iptr); + RegisterProperty('MDICHILDREN', 'TFORM INTEGER', iptr); + RegisterProperty('ICON', 'TICON', iptrw); + RegisterProperty('MENU', 'TMAINMENU', iptrw); + RegisterProperty('OBJECTMENUITEM', 'TMENUITEM', iptrw); + RegisterProperty('PIXELSPERINCH', 'INTEGER', iptrw); + RegisterProperty('PRINTSCALE', 'TPRINTSCALE', iptrw); + RegisterProperty('SCALED', 'BOOLEAN', iptrw); + RegisterProperty('WINDOWSTATE', 'TWINDOWSTATE', iptrw); + RegisterProperty('WINDOWMENU', 'TMENUITEM', iptrw); + RegisterProperty('CTL3D', 'BOOLEAN', iptrw); + RegisterProperty('POPUPMENU', 'TPOPUPMENU', iptrw); + RegisterProperty('ONDRAGDROP', 'TDRAGDROPEVENT', iptrw); + RegisterProperty('ONDRAGOVER', 'TDRAGOVEREVENT', iptrw); + RegisterProperty('ONMOUSEDOWN', 'TMOUSEEVENT', iptrw); + RegisterProperty('ONMOUSEMOVE', 'TMOUSEMOVEEVENT', iptrw); + RegisterProperty('ONMOUSEUP', 'TMOUSEEVENT', iptrw); + RegisterProperty('ONPAINT', 'TNOTIFYEVENT', iptrw); + {$ENDIF} + end; +end; + +procedure SIRegisterTAPPLICATION(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TCOMPONENT'), 'TAPPLICATION') do + begin + RegisterMethod('procedure BRINGTOFRONT'); +{$IFDEF PS_PANSICHAR} + RegisterMethod('function MESSAGEBOX(TEXT,CAPTION:PANSICHAR;FLAGS:WORD):INTEGER'); +{$ELSE} + RegisterMethod('function MESSAGEBOX(TEXT,CAPTION:PCHAR;FLAGS:WORD):INTEGER'); +{$ENDIF} + RegisterMethod('procedure MINIMIZE'); + RegisterMethod('procedure PROCESSMESSAGES'); + RegisterMethod('procedure RESTORE'); + RegisterMethod('procedure TERMINATE'); + RegisterProperty('ACTIVE', 'BOOLEAN', iptr); + RegisterProperty('EXENAME', 'NativeString', iptr); + {$IFNDEF CLX} + RegisterProperty('HANDLE', 'LONGINT', iptrw); + RegisterProperty('UPDATEFORMATSETTINGS', 'BOOLEAN', iptrw); + {$ENDIF} + RegisterProperty('HINT', 'NativeString', iptrw); + RegisterProperty('MAINFORM', 'TFORM', iptr); + RegisterProperty('SHOWHINT', 'BOOLEAN', iptrw); + RegisterProperty('SHOWMAINFORM', 'BOOLEAN', iptrw); + RegisterProperty('TERMINATED', 'BOOLEAN', iptr); + RegisterProperty('TITLE', 'NativeString', iptrw); + RegisterProperty('ONACTIVATE', 'TNOTIFYEVENT', iptrw); + RegisterProperty('ONDEACTIVATE', 'TNOTIFYEVENT', iptrw); + RegisterProperty('ONIDLE', 'TIDLEEVENT', iptrw); + RegisterProperty('ONHINT', 'TNOTIFYEVENT', iptrw); + RegisterProperty('ONMINIMIZE', 'TNOTIFYEVENT', iptrw); + RegisterProperty('ONRESTORE', 'TNOTIFYEVENT', iptrw); + + {$IFNDEF PS_MINIVCL} + RegisterMethod('procedure CONTROLDESTROYED(CONTROL:TCONTROL)'); + RegisterMethod('procedure CANCELHINT'); + RegisterMethod('procedure HANDLEEXCEPTION(SENDER:TOBJECT)'); + RegisterMethod('procedure HANDLEMESSAGE'); + RegisterMethod('procedure HIDEHINT'); +// RegisterMethod('procedure HINTMOUSEMESSAGE(CONTROL:TCONTROL;var MESSAGE:TMESSAGE)'); + RegisterMethod('procedure INITIALIZE'); + RegisterMethod('procedure NORMALIZETOPMOSTS'); + RegisterMethod('procedure RESTORETOPMOSTS'); + RegisterMethod('procedure RUN'); +// RegisterMethod('procedure SHOWEXCEPTION(E:EXCEPTION)'); + {$IFNDEF CLX} + RegisterMethod('function HELPCOMMAND(COMMAND:INTEGER;DATA:LONGINT):BOOLEAN'); + RegisterMethod('function HELPCONTEXT(CONTEXT:THELPCONTEXT):BOOLEAN'); + RegisterMethod('function HELPJUMP(JUMPID:NativeString):BOOLEAN'); + RegisterProperty('DIALOGHANDLE', 'LONGINT', iptrw); + RegisterMethod('procedure CREATEHANDLE'); +// RegisterMethod('procedure HOOKMAINWINDOW(HOOK:TWINDOWHOOK)'); +// RegisterMethod('procedure UNHOOKMAINWINDOW(HOOK:TWINDOWHOOK)'); + {$ENDIF} + RegisterProperty('HELPFILE', 'NativeString', iptrw); + RegisterProperty('HINTCOLOR', 'TCOLOR', iptrw); + RegisterProperty('HINTPAUSE', 'INTEGER', iptrw); + RegisterProperty('HINTSHORTPAUSE', 'INTEGER', iptrw); + RegisterProperty('HINTHIDEPAUSE', 'INTEGER', iptrw); + RegisterProperty('ICON', 'TICON', iptrw); + RegisterProperty('ONHELP', 'THELPEVENT', iptrw); + {$ENDIF} + end; +end; + +procedure SIRegister_Forms_TypesAndConsts(Cl: TPSPascalCompiler); +begin + Cl.AddTypeS('TIdleEvent', 'procedure (Sender: TObject; var Done: Boolean)'); + cl.AddTypeS('TScrollBarKind', '(sbHorizontal, sbVertical)'); + cl.AddTypeS('TScrollBarInc', 'SmallInt'); + cl.AddTypeS('TFormBorderStyle', '(bsNone, bsSingle, bsSizeable, bsDialog, bsToolWindow, bsSizeToolWin)'); + cl.AddTypeS('TBorderStyle', 'TFormBorderStyle'); + cl.AddTypeS('TWindowState', '(wsNormal, wsMinimized, wsMaximized)'); + cl.AddTypeS('TFormStyle', '(fsNormal, fsMDIChild, fsMDIForm, fsStayOnTop)'); + cl.AddTypeS('TPosition', '(poDesigned, poDefault, poDefaultPosOnly, poDefaultSizeOnly, poScreenCenter, poDesktopCenter, poMainFormCenter, poOwnerFormCenter)'); + cl.AddTypeS('TPrintScale', '(poNone, poProportional, poPrintToFit)'); + cl.AddTypeS('TCloseAction', '(caNone, caHide, caFree, caMinimize)'); + cl.AddTypeS('TCloseEvent' ,'procedure(Sender: TObject; var Action: TCloseAction)'); + cl.AddTypeS('TCloseQueryEvent' ,'procedure(Sender: TObject; var CanClose: Boolean)'); + cl.AddTypeS('TBorderIcon' ,'(biSystemMenu, biMinimize, biMaximize, biHelp)'); + cl.AddTypeS('TBorderIcons', 'set of TBorderIcon'); + cl.AddTypeS('THELPCONTEXT', 'Longint'); +end; + +procedure SIRegister_Forms(Cl: TPSPascalCompiler); +begin + SIRegister_Forms_TypesAndConsts(cl); + + {$IFNDEF PS_MINIVCL} + SIRegisterTCONTROLSCROLLBAR(cl); + {$ENDIF} + SIRegisterTScrollingWinControl(cl); + {$IFNDEF PS_MINIVCL} + SIRegisterTSCROLLBOX(cl); + {$ENDIF} + SIRegisterTForm(Cl); + {$IFNDEF PS_MINIVCL} + SIRegisterTApplication(Cl); + {$ENDIF} +end; + +// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl) + + +end. + diff --git a/Units/PascalScript/uPSC_graphics.pas b/Units/PascalScript/uPSC_graphics.pas new file mode 100644 index 0000000..e96bbe2 --- /dev/null +++ b/Units/PascalScript/uPSC_graphics.pas @@ -0,0 +1,275 @@ +{ Compiletime Graphics support } +unit uPSC_graphics; + +{$I PascalScript.inc} +interface +uses + uPSCompiler, uPSUtils; + + + +procedure SIRegister_Graphics_TypesAndConsts(Cl: TPSPascalCompiler); +procedure SIRegisterTGRAPHICSOBJECT(Cl: TPSPascalCompiler); +procedure SIRegisterTFont(Cl: TPSPascalCompiler); +procedure SIRegisterTPEN(Cl: TPSPascalCompiler); +procedure SIRegisterTBRUSH(Cl: TPSPascalCompiler); +procedure SIRegisterTCanvas(cl: TPSPascalCompiler); +procedure SIRegisterTGraphic(CL: TPSPascalCompiler); +procedure SIRegisterTBitmap(CL: TPSPascalCompiler; Streams: Boolean); + +procedure SIRegister_Graphics(Cl: TPSPascalCompiler; Streams: Boolean); + +implementation +{$IFNDEF PS_NOGRAPHCONST} +uses + {$IFDEF CLX}QGraphics{$ELSE}Graphics{$ENDIF}; +{$ELSE} +{$IFNDEF CLX} +{$IFNDEF FPC} +uses + Windows; +{$ENDIF} +{$ENDIF} +{$ENDIF} + +procedure SIRegisterTGRAPHICSOBJECT(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TPERSISTENT'), 'TGRAPHICSOBJECT') do + begin + RegisterProperty('ONCHANGE', 'TNOTIFYEVENT', iptrw); + end; +end; + +procedure SIRegisterTFont(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TGraphicsObject'), 'TFONT') do + begin + RegisterMethod('constructor Create;'); +{$IFNDEF CLX} + RegisterProperty('Handle', 'Integer', iptRW); +{$ENDIF} + RegisterProperty('Color', 'TColor', iptRW); + RegisterProperty('Height', 'Integer', iptRW); + RegisterProperty('Name', 'String', iptRW); + RegisterProperty('Pitch', 'Byte', iptRW); + RegisterProperty('Size', 'Integer', iptRW); + RegisterProperty('PixelsPerInch', 'Integer', iptRW); + RegisterProperty('Style', 'TFontStyles', iptrw); + end; +end; + +procedure SIRegisterTCanvas(cl: TPSPascalCompiler); // requires TPersistent +begin + with Cl.AddClassN(cl.FindClass('TPersistent'), 'TCANVAS') do + begin + RegisterMethod('procedure Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);'); + RegisterMethod('procedure Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);'); +// RegisterMethod('procedure Draw(X, Y: Integer; Graphic: TGraphic);'); + RegisterMethod('procedure Ellipse(X1, Y1, X2, Y2: Integer);'); + RegisterMethod('procedure FillRect(const Rect: TRect);'); +{$IFNDEF CLX} + RegisterMethod('procedure FloodFill(X, Y: Integer; Color: TColor; FillStyle: Byte);'); +{$ENDIF} + RegisterMethod('procedure LineTo(X, Y: Integer);'); + RegisterMethod('procedure MoveTo(X, Y: Integer);'); + RegisterMethod('procedure Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);'); + RegisterMethod('procedure Rectangle(X1, Y1, X2, Y2: Integer);'); + RegisterMethod('procedure Refresh;'); + RegisterMethod('procedure RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer);'); + RegisterMethod('function TextHeight(Text: String): Integer;'); + RegisterMethod('procedure TextOut(X, Y: Integer; Text: String);'); + RegisterMethod('function TextWidth(Text: String): Integer;'); +{$IFNDEF CLX} + RegisterProperty('Handle', 'Integer', iptRw); +{$ENDIF} + RegisterProperty('Pixels', 'Integer Integer Integer', iptRW); + RegisterProperty('Brush', 'TBrush', iptR); + RegisterProperty('CopyMode', 'Byte', iptRw); + RegisterProperty('Font', 'TFont', iptR); + RegisterProperty('Pen', 'TPen', iptR); + end; +end; + +procedure SIRegisterTPEN(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TGRAPHICSOBJECT'), 'TPEN') do + begin + RegisterMethod('constructor CREATE'); + RegisterProperty('COLOR', 'TCOLOR', iptrw); + RegisterProperty('MODE', 'TPENMODE', iptrw); + RegisterProperty('STYLE', 'TPENSTYLE', iptrw); + RegisterProperty('WIDTH', 'INTEGER', iptrw); + end; +end; + +procedure SIRegisterTBRUSH(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TGRAPHICSOBJECT'), 'TBRUSH') do + begin + RegisterMethod('constructor CREATE'); + RegisterProperty('COLOR', 'TCOLOR', iptrw); + RegisterProperty('STYLE', 'TBRUSHSTYLE', iptrw); + end; +end; + +procedure SIRegister_Graphics_TypesAndConsts(Cl: TPSPascalCompiler); +{$IFDEF PS_NOGRAPHCONST} +const + clSystemColor = {$IFDEF DELPHI7UP} $FF000000 {$ELSE} $80000000 {$ENDIF}; +{$ENDIF} +begin +{$IFNDEF PS_NOGRAPHCONST} + cl.AddConstantN('clScrollBar', 'Integer').Value.ts32 := clScrollBar; + cl.AddConstantN('clBackground', 'Integer').Value.ts32 := clBackground; + cl.AddConstantN('clActiveCaption', 'Integer').Value.ts32 := clActiveCaption; + cl.AddConstantN('clInactiveCaption', 'Integer').Value.ts32 := clInactiveCaption; + cl.AddConstantN('clMenu', 'Integer').Value.ts32 := clMenu; + cl.AddConstantN('clWindow', 'Integer').Value.ts32 := clWindow; + cl.AddConstantN('clWindowFrame', 'Integer').Value.ts32 := clWindowFrame; + cl.AddConstantN('clMenuText', 'Integer').Value.ts32 := clMenuText; + cl.AddConstantN('clWindowText', 'Integer').Value.ts32 := clWindowText; + cl.AddConstantN('clCaptionText', 'Integer').Value.ts32 := clCaptionText; + cl.AddConstantN('clActiveBorder', 'Integer').Value.ts32 := clActiveBorder; + cl.AddConstantN('clInactiveBorder', 'Integer').Value.ts32 := clInactiveCaption; + cl.AddConstantN('clAppWorkSpace', 'Integer').Value.ts32 := clAppWorkSpace; + cl.AddConstantN('clHighlight', 'Integer').Value.ts32 := clHighlight; + cl.AddConstantN('clHighlightText', 'Integer').Value.ts32 := clHighlightText; + cl.AddConstantN('clBtnFace', 'Integer').Value.ts32 := clBtnFace; + cl.AddConstantN('clBtnShadow', 'Integer').Value.ts32 := clBtnShadow; + cl.AddConstantN('clGrayText', 'Integer').Value.ts32 := clGrayText; + cl.AddConstantN('clBtnText', 'Integer').Value.ts32 := clBtnText; + cl.AddConstantN('clInactiveCaptionText', 'Integer').Value.ts32 := clInactiveCaptionText; + cl.AddConstantN('clBtnHighlight', 'Integer').Value.ts32 := clBtnHighlight; + cl.AddConstantN('cl3DDkShadow', 'Integer').Value.ts32 := cl3DDkShadow; + cl.AddConstantN('cl3DLight', 'Integer').Value.ts32 := cl3DLight; + cl.AddConstantN('clInfoText', 'Integer').Value.ts32 := clInfoText; + cl.AddConstantN('clInfoBk', 'Integer').Value.ts32 := clInfoBk; +{$ELSE} +{$IFNDEF CLX} // These are VCL-only; CLX uses different constant values + cl.AddConstantN('clScrollBar', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_SCROLLBAR); + cl.AddConstantN('clBackground', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_BACKGROUND); + cl.AddConstantN('clActiveCaption', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_ACTIVECAPTION); + cl.AddConstantN('clInactiveCaption', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_INACTIVECAPTION); + cl.AddConstantN('clMenu', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_MENU); + cl.AddConstantN('clWindow', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_WINDOW); + cl.AddConstantN('clWindowFrame', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_WINDOWFRAME); + cl.AddConstantN('clMenuText', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_MENUTEXT); + cl.AddConstantN('clWindowText', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_WINDOWTEXT); + cl.AddConstantN('clCaptionText', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_CAPTIONTEXT); + cl.AddConstantN('clActiveBorder', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_ACTIVEBORDER); + cl.AddConstantN('clInactiveBorder', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_INACTIVEBORDER); + cl.AddConstantN('clAppWorkSpace', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_APPWORKSPACE); + cl.AddConstantN('clHighlight', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_HIGHLIGHT); + cl.AddConstantN('clHighlightText', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_HIGHLIGHTTEXT); + cl.AddConstantN('clBtnFace', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_BTNFACE); + cl.AddConstantN('clBtnShadow', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_BTNSHADOW); + cl.AddConstantN('clGrayText', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_GRAYTEXT); + cl.AddConstantN('clBtnText', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_BTNTEXT); + cl.AddConstantN('clInactiveCaptionText', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_INACTIVECAPTIONTEXT); + cl.AddConstantN('clBtnHighlight', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_BTNHIGHLIGHT); + cl.AddConstantN('cl3DDkShadow', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_3DDKSHADOW); + cl.AddConstantN('cl3DLight', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_3DLIGHT); + cl.AddConstantN('clInfoText', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_INFOTEXT); + cl.AddConstantN('clInfoBk', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_INFOBK); +{$ENDIF} +{$ENDIF} + cl.AddConstantN('clBlack', 'Integer').Value.ts32 := $000000; + cl.AddConstantN('clMaroon', 'Integer').Value.ts32 := $000080; + cl.AddConstantN('clGreen', 'Integer').Value.ts32 := $008000; + cl.AddConstantN('clOlive', 'Integer').Value.ts32 := $008080; + cl.AddConstantN('clNavy', 'Integer').Value.ts32 := $800000; + cl.AddConstantN('clPurple', 'Integer').Value.ts32 := $800080; + cl.AddConstantN('clTeal', 'Integer').Value.ts32 := $808000; + cl.AddConstantN('clGray', 'Integer').Value.ts32 := $808080; + cl.AddConstantN('clSilver', 'Integer').Value.ts32 := $C0C0C0; + cl.AddConstantN('clRed', 'Integer').Value.ts32 := $0000FF; + cl.AddConstantN('clLime', 'Integer').Value.ts32 := $00FF00; + cl.AddConstantN('clYellow', 'Integer').Value.ts32 := $00FFFF; + cl.AddConstantN('clBlue', 'Integer').Value.ts32 := $FF0000; + cl.AddConstantN('clFuchsia', 'Integer').Value.ts32 := $FF00FF; + cl.AddConstantN('clAqua', 'Integer').Value.ts32 := $FFFF00; + cl.AddConstantN('clLtGray', 'Integer').Value.ts32 := $C0C0C0; + cl.AddConstantN('clDkGray', 'Integer').Value.ts32 := $808080; + cl.AddConstantN('clWhite', 'Integer').Value.ts32 := $FFFFFF; + cl.AddConstantN('clNone', 'Integer').Value.ts32 := $1FFFFFFF; + cl.AddConstantN('clDefault', 'Integer').Value.ts32 := $20000000; + + Cl.addTypeS('TFONTSTYLE', '(FSBOLD, FSITALIC, FSUNDERLINE, FSSTRIKEOUT)'); + Cl.addTypeS('TFONTSTYLES', 'set of TFONTSTYLE'); + + cl.AddTypeS('TFontPitch', '(fpDefault, fpVariable, fpFixed)'); + cl.AddTypeS('TPenStyle', '(psSolid, psDash, psDot, psDashDot, psDashDotDot, psClear, psInsideFrame)'); + cl.AddTypeS('TPenMode', '(pmBlack, pmWhite, pmNop, pmNot, pmCopy, pmNotCopy, pmMergePenNot, pmMaskPenNot, pmMergeNotPen, pmMaskNotPen, pmMerge, pmNotMerge, pmMask, pmNotMask, pmXor, pmNotXor)'); + cl.AddTypeS('TBrushStyle', '(bsSolid, bsClear, bsHorizontal, bsVertical, bsFDiagonal, bsBDiagonal, bsCross, bsDiagCross)'); + cl.addTypeS('TColor', 'integer'); + +{$IFNDEF CLX} + cl.addTypeS('HBITMAP', 'Integer'); + cl.addTypeS('HPALETTE', 'Integer'); +{$ENDIF} +end; + +procedure SIRegisterTGraphic(CL: TPSPascalCompiler); +begin + with CL.AddClassN(CL.FindClass('TPersistent'),'TGraphic') do + begin + RegisterMethod('constructor Create'); + RegisterMethod('Procedure LoadFromFile( const Filename : String)'); + RegisterMethod('Procedure SaveToFile( const Filename : String)'); + RegisterProperty('Empty', 'Boolean', iptr); + RegisterProperty('Height', 'Integer', iptrw); + RegisterProperty('Modified', 'Boolean', iptrw); + RegisterProperty('Width', 'Integer', iptrw); + RegisterProperty('OnChange', 'TNotifyEvent', iptrw); + end; +end; + +procedure SIRegisterTBitmap(CL: TPSPascalCompiler; Streams: Boolean); +begin + with CL.AddClassN(CL.FindClass('TGraphic'),'TBitmap') do + begin + if Streams then begin + RegisterMethod('Procedure LoadFromStream( Stream : TStream)'); + RegisterMethod('Procedure SaveToStream( Stream : TStream)'); + end; + RegisterProperty('Canvas', 'TCanvas', iptr); +{$IFNDEF CLX} + RegisterProperty('Handle', 'HBITMAP', iptrw); +{$ENDIF} + + {$IFNDEF IFPS_MINIVCL} + RegisterMethod('Procedure Dormant'); + RegisterMethod('Procedure FreeImage'); +{$IFNDEF CLX} + RegisterMethod('Procedure LoadFromClipboardFormat( AFormat : Word; AData : THandle; APalette : HPALETTE)'); +{$ENDIF} + RegisterMethod('Procedure LoadFromResourceName( Instance : THandle; const ResName : String)'); + RegisterMethod('Procedure LoadFromResourceID( Instance : THandle; ResID : Integer)'); +{$IFNDEF CLX} + RegisterMethod('Function ReleaseHandle : HBITMAP'); + RegisterMethod('Function ReleasePalette : HPALETTE'); + RegisterMethod('Procedure SaveToClipboardFormat( var Format : Word; var Data : THandle; var APalette : HPALETTE)'); + RegisterProperty('Monochrome', 'Boolean', iptrw); + RegisterProperty('Palette', 'HPALETTE', iptrw); + RegisterProperty('IgnorePalette', 'Boolean', iptrw); +{$ENDIF} + RegisterProperty('TransparentColor', 'TColor', iptr); + {$ENDIF} + end; +end; + +procedure SIRegister_Graphics(Cl: TPSPascalCompiler; Streams: Boolean); +begin + SIRegister_Graphics_TypesAndConsts(Cl); + SIRegisterTGRAPHICSOBJECT(Cl); + SIRegisterTFont(Cl); + SIRegisterTPEN(cl); + SIRegisterTBRUSH(cl); + SIRegisterTCanvas(cl); + SIRegisterTGraphic(Cl); + SIRegisterTBitmap(Cl, Streams); +end; + +// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl) + +End. diff --git a/Units/PascalScript/uPSC_menus.pas b/Units/PascalScript/uPSC_menus.pas new file mode 100644 index 0000000..698f16b --- /dev/null +++ b/Units/PascalScript/uPSC_menus.pas @@ -0,0 +1,214 @@ +{ Menus Import Unit } +Unit uPSC_menus; +{$I PascalScript.inc} +Interface +Uses uPSCompiler; + +procedure SIRegisterTMENUITEMSTACK(CL: TPSPascalCompiler); +procedure SIRegisterTPOPUPLIST(CL: TPSPascalCompiler); +procedure SIRegisterTPOPUPMENU(CL: TPSPascalCompiler); +procedure SIRegisterTMAINMENU(CL: TPSPascalCompiler); +procedure SIRegisterTMENU(CL: TPSPascalCompiler); +procedure SIRegisterTMENUITEM(CL: TPSPascalCompiler); +procedure SIRegister_Menus(Cl: TPSPascalCompiler); + +implementation + +procedure SIRegisterTMENUITEMSTACK(CL: TPSPascalCompiler); +begin + With cl.AddClassN(Cl.FindClass('TSTACK'),'TMENUITEMSTACK') do + begin + RegisterMethod('Procedure CLEARITEM( AITEM : TMENUITEM)'); + end; +end; + +procedure SIRegisterTPOPUPLIST(CL: TPSPascalCompiler); +begin + With cl.AddClassN(Cl.FindClass('TLIST'),'TPOPUPLIST') do + begin + RegisterProperty('WINDOW', 'HWND', iptr); + RegisterMethod('Procedure ADD( POPUP : TPOPUPMENU)'); + RegisterMethod('Procedure REMOVE( POPUP : TPOPUPMENU)'); + end; +end; + +procedure SIRegisterTPOPUPMENU(CL: TPSPascalCompiler); +var + cc: TPSCompileTimeClass; +begin + With cl.AddClassN(Cl.FindClass('TMENU'),'TPOPUPMENU') do + begin + cc := Cl.FindClass('TLabel'); + if cc <> nil then + RegisterProperty('POPUPMENU', 'TPOPUPMENU', iptRW); + with Cl.FindClass('TForm') do + begin + RegisterProperty('POPUPMENU', 'TPOPUPMENU', iptRW); + end; + RegisterMethod('Constructor CREATE( AOWNER : TCOMPONENT)'); + RegisterMethod('Procedure POPUP( X, Y : INTEGER)'); + RegisterProperty('POPUPCOMPONENT', 'TCOMPONENT', iptrw); + RegisterProperty('ALIGNMENT', 'TPOPUPALIGNMENT', iptrw); + RegisterProperty('AUTOPOPUP', 'BOOLEAN', iptrw); + RegisterProperty('HELPCONTEXT', 'THELPCONTEXT', iptrw); + RegisterProperty('MENUANIMATION', 'TMENUANIMATION', iptrw); + RegisterProperty('TRACKBUTTON', 'TTRACKBUTTON', iptrw); + RegisterProperty('ONPOPUP', 'TNOTIFYEVENT', iptrw); + end; +end; + +procedure SIRegisterTMAINMENU(CL: TPSPascalCompiler); +begin + With cl.AddClassN(Cl.FindClass('TMENU'),'TMAINMENU') do + begin + RegisterMethod('Procedure MERGE( MENU : TMAINMENU)'); + RegisterMethod('Procedure UNMERGE( MENU : TMAINMENU)'); + RegisterMethod('Procedure POPULATEOLE2MENU( SHAREDMENU : HMENU; GROUPS : array of INTEGER; var WIDTHS : array of LONGINT)'); + RegisterMethod('Procedure GETOLE2ACCELERATORTABLE( var ACCELTABLE : HACCEL; var ACCELCOUNT : INTEGER; GROUPS : array of INTEGER)'); + RegisterMethod('Procedure SETOLE2MENUHANDLE( HANDLE : HMENU)'); + RegisterProperty('AUTOMERGE', 'BOOLEAN', iptrw); + end; +end; + +procedure SIRegisterTMENU(CL: TPSPascalCompiler); +begin + With cl.AddClassN(Cl.FindClass('TCOMPONENT'),'TMENU') do + begin + RegisterMethod('Constructor CREATE( AOWNER : TCOMPONENT)'); + RegisterMethod('Function DISPATCHCOMMAND( ACOMMAND : WORD) : BOOLEAN'); + RegisterMethod('Function DISPATCHPOPUP( AHANDLE : HMENU) : BOOLEAN'); + RegisterMethod('Function FINDITEM( VALUE : INTEGER; KIND : TFINDITEMKIND) : TMENUITEM'); + RegisterMethod('Function GETHELPCONTEXT( VALUE : INTEGER; BYCOMMAND : BOOLEAN) : THELPCONTEXT'); + RegisterProperty('IMAGES', 'TCUSTOMIMAGELIST', iptrw); + RegisterMethod('Function ISRIGHTTOLEFT : BOOLEAN'); + RegisterMethod('Procedure PARENTBIDIMODECHANGED( ACONTROL : TOBJECT)'); + RegisterMethod('Procedure PROCESSMENUCHAR( var MESSAGE : TWMMENUCHAR)'); + RegisterProperty('AUTOHOTKEYS', 'TMENUAUTOFLAG', iptrw); + RegisterProperty('AUTOLINEREDUCTION', 'TMENUAUTOFLAG', iptrw); + RegisterProperty('BIDIMODE', 'TBIDIMODE', iptrw); + RegisterProperty('HANDLE', 'HMENU', iptr); + RegisterProperty('OWNERDRAW', 'BOOLEAN', iptrw); + RegisterProperty('PARENTBIDIMODE', 'BOOLEAN', iptrw); + RegisterProperty('WINDOWHANDLE', 'HWND', iptrw); + RegisterProperty('ITEMS', 'TMENUITEM', iptr); + end; +end; + +procedure SIRegisterTMENUITEM(CL: TPSPascalCompiler); +begin + With cl.AddClassN(Cl.FindClass('TCOMPONENT'),'TMENUITEM') do + begin + RegisterMethod('Constructor CREATE( AOWNER : TCOMPONENT)'); + RegisterMethod('Procedure INITIATEACTION'); + RegisterMethod('Procedure INSERT( INDEX : INTEGER; ITEM : TMENUITEM)'); + RegisterMethod('Procedure DELETE( INDEX : INTEGER)'); + RegisterMethod('Procedure CLEAR'); + RegisterMethod('Procedure CLICK'); + RegisterMethod('Function FIND( ACAPTION : String) : TMENUITEM'); + RegisterMethod('Function INDEXOF( ITEM : TMENUITEM) : INTEGER'); + RegisterMethod('Function ISLINE : BOOLEAN'); + RegisterMethod('Function GETIMAGELIST : TCUSTOMIMAGELIST'); + RegisterMethod('Function GETPARENTCOMPONENT : TCOMPONENT'); + RegisterMethod('Function GETPARENTMENU : TMENU'); + RegisterMethod('Function HASPARENT : BOOLEAN'); + RegisterMethod('Function NEWTOPLINE : INTEGER'); + RegisterMethod('Function NEWBOTTOMLINE : INTEGER'); + RegisterMethod('Function INSERTNEWLINEBEFORE( AITEM : TMENUITEM) : INTEGER'); + RegisterMethod('Function INSERTNEWLINEAFTER( AITEM : TMENUITEM) : INTEGER'); + RegisterMethod('Procedure ADD( ITEM : TMENUITEM)'); + RegisterMethod('Procedure REMOVE( ITEM : TMENUITEM)'); + RegisterMethod('Function RETHINKHOTKEYS : BOOLEAN'); + RegisterMethod('Function RETHINKLINES : BOOLEAN'); + RegisterProperty('COMMAND', 'WORD', iptr); + RegisterProperty('HANDLE', 'HMENU', iptr); + RegisterProperty('COUNT', 'INTEGER', iptr); + RegisterProperty('ITEMS', 'TMENUITEM INTEGER', iptr); + RegisterProperty('MENUINDEX', 'INTEGER', iptrw); + RegisterProperty('PARENT', 'TMENUITEM', iptr); + {$IFDEF DELPHI5UP} + RegisterProperty('ACTION', 'TBASICACTION', iptrw); + {$ENDIF} + RegisterProperty('AUTOHOTKEYS', 'TMENUITEMAUTOFLAG', iptrw); + RegisterProperty('AUTOLINEREDUCTION', 'TMENUITEMAUTOFLAG', iptrw); + RegisterProperty('BITMAP', 'TBITMAP', iptrw); + RegisterProperty('CAPTION', 'String', iptrw); + RegisterProperty('CHECKED', 'BOOLEAN', iptrw); + RegisterProperty('SUBMENUIMAGES', 'TCUSTOMIMAGELIST', iptrw); + RegisterProperty('DEFAULT', 'BOOLEAN', iptrw); + RegisterProperty('ENABLED', 'BOOLEAN', iptrw); + RegisterProperty('GROUPINDEX', 'BYTE', iptrw); + RegisterProperty('HELPCONTEXT', 'THELPCONTEXT', iptrw); + RegisterProperty('HINT', 'String', iptrw); + RegisterProperty('IMAGEINDEX', 'TIMAGEINDEX', iptrw); + RegisterProperty('RADIOITEM', 'BOOLEAN', iptrw); + RegisterProperty('SHORTCUT', 'TSHORTCUT', iptrw); + RegisterProperty('VISIBLE', 'BOOLEAN', iptrw); + RegisterProperty('ONCLICK', 'TNOTIFYEVENT', iptrw); + {$IFNDEF FPC} RegisterProperty('ONDRAWITEM', 'TMENUDRAWITEMEVENT', iptrw); + RegisterProperty('ONADVANCEDDRAWITEM', 'TADVANCEDMENUDRAWITEMEVENT', iptrw); + RegisterProperty('ONMEASUREITEM', 'TMENUMEASUREITEMEVENT', iptrw);{$ENDIF} + end; +end; + +procedure SIRegister_Menus(Cl: TPSPascalCompiler); +begin + Cl.AddTypeS('HMenu', 'Cardinal'); + Cl.AddTypeS('HACCEL', 'Cardinal'); + + cl.addClassN(cl.FindClass('EXCEPTION'),'EMENUERROR'); + Cl.addTypeS('TMENUBREAK', '( MBNONE, MBBREAK, MBBARBREAK )'); +{$IFNDEF FPC} + Cl.addTypeS('TMENUDRAWITEMEVENT', 'Procedure ( SENDER : TOBJECT; ACANVAS : TC' + +'ANVAS; ARECT : TRECT; SELECTED : BOOLEAN)'); + Cl.addTypeS('TADVANCEDMENUDRAWITEMEVENT', 'Procedure ( SENDER : TOBJECT; ACAN' + +'VAS : TCANVAS; ARECT : TRECT; STATE : TOWNERDRAWSTATE)'); + Cl.addTypeS('TMENUMEASUREITEMEVENT', 'Procedure ( SENDER : TOBJECT; ACANVAS :' + +' TCANVAS; var WIDTH, HEIGHT : INTEGER)'); +{$ENDIF} + Cl.addTypeS('TMENUITEMAUTOFLAG', '( MAAUTOMATIC, MAMANUAL, MAPARENT )'); + Cl.AddTypeS('TMenuAutoFlag', 'TMENUITEMAUTOFLAG'); + Cl.addTypeS('TSHORTCUT', 'WORD'); + cl.addClassN(cl.FindClass('TACTIONLINK'),'TMENUACTIONLINK'); + SIRegisterTMENUITEM(Cl); + Cl.addTypeS('TMENUCHANGEEVENT', 'Procedure ( SENDER : TOBJECT; SOURCE : TMENU' + +'ITEM; REBUILD : BOOLEAN)'); + Cl.addTypeS('TFINDITEMKIND', '( FKCOMMAND, FKHANDLE, FKSHORTCUT )'); + SIRegisterTMENU(Cl); + SIRegisterTMAINMENU(Cl); + Cl.addTypeS('TPOPUPALIGNMENT', '( PALEFT, PARIGHT, PACENTER )'); + Cl.addTypeS('TTRACKBUTTON', '( TBRIGHTBUTTON, TBLEFTBUTTON )'); + Cl.addTypeS('TMENUANIMATIONS', '( MALEFTTORIGHT, MARIGHTTOLEFT, MATOPTOBOTTOM' + +', MABOTTOMTOTOP, MANONE )'); + Cl.addTypeS('TMENUANIMATION', 'set of TMENUANIMATIONS'); + SIRegisterTPOPUPMENU(Cl); + SIRegisterTPOPUPLIST(Cl); + SIRegisterTMENUITEMSTACK(Cl); + Cl.addTypeS('TCMENUITEM', 'TMENUITEM'); +{$IFNDEF FPC} +//TODO: it should work,but somehow TShiftState is not defined + Cl.AddDelphiFunction('Function SHORTCUT( KEY : WORD; SHIFT : TSHIFTSTATE) : T' + +'SHORTCUT'); + Cl.AddDelphiFunction('Procedure SHORTCUTTOKEY( SHORTCUT : TSHORTCUT; var KEY ' + +': WORD; var SHIFT : TSHIFTSTATE)'); +{$ENDIF} + Cl.AddDelphiFunction('Function SHORTCUTTOTEXT( SHORTCUT : TSHORTCUT) : String' + +''); + Cl.AddDelphiFunction('Function TEXTTOSHORTCUT( TEXT : String) : TSHORTCUT'); + Cl.AddDelphiFunction('Function NEWMENU( OWNER : TCOMPONENT; const ANAME : STR' + +'ING; ITEMS : array of TMenuItem) : TMAINMENU'); + Cl.AddDelphiFunction('Function NEWPOPUPMENU( OWNER : TCOMPONENT; const ANAME ' + +': String; ALIGNMENT : TPOPUPALIGNMENT; AUTOPOPUP : BOOLEAN; const ITEMS : array of ' + +'TCMENUITEM) : TPOPUPMENU'); + Cl.AddDelphiFunction('Function NEWSUBMENU( const ACAPTION : String; HCTX : WO' + +'RD; const ANAME : String; ITEMS : array of TMenuItem; AENABLED : BOOLEAN) : TMENUITEM'); + Cl.AddDelphiFunction('Function NEWITEM( const ACAPTION : String; ASHORTCUT : ' + +'TSHORTCUT; ACHECKED, AENABLED : BOOLEAN; AONCLICK : TNOTIFYEVENT; HCTX : W' + +'ORD; const ANAME : String) : TMENUITEM'); + Cl.AddDelphiFunction('Function NEWLINE : TMENUITEM'); +{$IFNDEF FPC} + Cl.AddDelphiFunction('Procedure DRAWMENUITEM( MENUITEM : TMENUITEM; ACANVAS :' + +' TCANVAS; ARECT : TRECT; STATE : TOWNERDRAWSTATE)'); +{$ENDIF} +end; + +end. diff --git a/Units/PascalScript/uPSC_std.pas b/Units/PascalScript/uPSC_std.pas new file mode 100644 index 0000000..460ba64 --- /dev/null +++ b/Units/PascalScript/uPSC_std.pas @@ -0,0 +1,87 @@ +{ Compiletime TObject, TPersistent and TComponent definitions } +unit uPSC_std; +{$I PascalScript.inc} +interface +uses + uPSCompiler, uPSUtils; + +{ + Will register files from: + System + Classes (Only TComponent and TPersistent) + +} + +procedure SIRegister_Std_TypesAndConsts(Cl: TPSPascalCompiler); +procedure SIRegisterTObject(CL: TPSPascalCompiler); +procedure SIRegisterTPersistent(Cl: TPSPascalCompiler); +procedure SIRegisterTComponent(Cl: TPSPascalCompiler); + +procedure SIRegister_Std(Cl: TPSPascalCompiler); + +implementation + +procedure SIRegisterTObject(CL: TPSPascalCompiler); +begin + with Cl.AddClassN(nil, 'TObject') do + begin + RegisterMethod('constructor Create'); + RegisterMethod('procedure Free'); + end; +end; + +procedure SIRegisterTPersistent(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TObject'), 'TPersistent') do + begin + RegisterMethod('procedure Assign(Source: TPersistent)'); + end; +end; + +procedure SIRegisterTComponent(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TPersistent'), 'TComponent') do + begin + RegisterMethod('function FindComponent(AName: String): TComponent;'); + RegisterMethod('constructor Create(AOwner: TComponent); virtual;'); + + RegisterProperty('Owner', 'TComponent', iptRW); + RegisterMethod('procedure DestroyComponents'); + RegisterMethod('procedure Destroying'); + RegisterMethod('procedure FreeNotification(AComponent:TComponent)'); + RegisterMethod('procedure InsertComponent(AComponent:TComponent)'); + RegisterMethod('procedure RemoveComponent(AComponent:TComponent)'); + RegisterProperty('Components', 'TComponent Integer', iptr); + RegisterProperty('ComponentCount', 'Integer', iptr); + RegisterProperty('ComponentIndex', 'Integer', iptrw); + RegisterProperty('ComponentState', 'Byte', iptr); + RegisterProperty('Designinfo', 'LongInt', iptrw); + RegisterProperty('Name', 'String', iptrw); + RegisterProperty('Tag', 'LongInt', iptrw); + end; +end; + + + + +procedure SIRegister_Std_TypesAndConsts(Cl: TPSPascalCompiler); +begin + Cl.AddTypeS('TComponentStateE', '(csLoading, csReading, csWriting, csDestroying, csDesigning, csAncestor, csUpdating, csFixups, csFreeNotification, csInline, csDesignInstance)'); + cl.AddTypeS('TComponentState', 'set of TComponentStateE'); + Cl.AddTypeS('TRect', 'record Left, Top, Right, Bottom: Integer; end;'); +end; + +procedure SIRegister_Std(Cl: TPSPascalCompiler); +begin + SIRegister_Std_TypesAndConsts(Cl); + SIRegisterTObject(CL); + SIRegisterTPersistent(Cl); + SIRegisterTComponent(Cl); +end; + +// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl) + + +End. + + diff --git a/Units/PascalScript/uPSC_stdctrls.pas b/Units/PascalScript/uPSC_stdctrls.pas new file mode 100644 index 0000000..52ff4bc --- /dev/null +++ b/Units/PascalScript/uPSC_stdctrls.pas @@ -0,0 +1,633 @@ +{ Compiletime STDCtrls support } +unit uPSC_stdctrls; + +{$I PascalScript.inc} +interface +uses + uPSCompiler, uPSUtils; + +{ + Will register files from: + stdctrls + +Requires: + STD, classes, controls and graphics +} + +procedure SIRegister_StdCtrls_TypesAndConsts(cl: TPSPascalCompiler); + + + +procedure SIRegisterTCUSTOMGROUPBOX(Cl: TPSPascalCompiler); +procedure SIRegisterTGROUPBOX(Cl: TPSPascalCompiler); +procedure SIRegisterTCUSTOMLABEL(Cl: TPSPascalCompiler); +procedure SIRegisterTLABEL(Cl: TPSPascalCompiler); +procedure SIRegisterTCUSTOMEDIT(Cl: TPSPascalCompiler); +procedure SIRegisterTEDIT(Cl: TPSPascalCompiler); +procedure SIRegisterTCUSTOMMEMO(Cl: TPSPascalCompiler); +procedure SIRegisterTMEMO(Cl: TPSPascalCompiler); +procedure SIRegisterTCUSTOMCOMBOBOX(Cl: TPSPascalCompiler); +procedure SIRegisterTCOMBOBOX(Cl: TPSPascalCompiler); +procedure SIRegisterTBUTTONCONTROL(Cl: TPSPascalCompiler); +procedure SIRegisterTBUTTON(Cl: TPSPascalCompiler); +procedure SIRegisterTCUSTOMCHECKBOX(Cl: TPSPascalCompiler); +procedure SIRegisterTCHECKBOX(Cl: TPSPascalCompiler); +procedure SIRegisterTRADIOBUTTON(Cl: TPSPascalCompiler); +procedure SIRegisterTCUSTOMLISTBOX(Cl: TPSPascalCompiler); +procedure SIRegisterTLISTBOX(Cl: TPSPascalCompiler); +procedure SIRegisterTSCROLLBAR(Cl: TPSPascalCompiler); + +procedure SIRegister_StdCtrls(cl: TPSPascalCompiler); + + +implementation + +procedure SIRegisterTCUSTOMGROUPBOX(Cl: TPSPascalCompiler); +begin + Cl.AddClassN(cl.FindClass('TCUSTOMCONTROL'), 'TCUSTOMGROUPBOX'); +end; + + +procedure SIRegisterTGROUPBOX(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TCUSTOMGROUPBOX'), 'TGROUPBOX') do + begin + RegisterProperty('CAPTION', 'String', iptrw); + RegisterProperty('COLOR', 'TColor', iptrw); + RegisterProperty('FONT', 'TFont', iptrw); + RegisterProperty('PARENTCOLOR', 'Boolean', iptrw); + RegisterProperty('PARENTFONT', 'Boolean', iptrw); + RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw); + RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw); + RegisterProperty('ONENTER', 'TNotifyEvent', iptrw); + RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw); + + {$IFNDEF PS_MINIVCL} + RegisterProperty('CTL3D', 'Boolean', iptrw); + RegisterProperty('DRAGCURSOR', 'Longint', iptrw); + RegisterProperty('DRAGMODE', 'TDragMode', iptrw); + RegisterProperty('PARENTCTL3D', 'Boolean', iptrw); + RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw); + RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw); + RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw); + RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw); + RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw); + RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw); + RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw); + RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw); + RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw); + {$ENDIF} + end; +end; + + + + + +procedure SIRegisterTCUSTOMLABEL(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TGRAPHICCONTROL'), 'TCUSTOMLABEL') do + begin + {$IFNDEF PS_MINIVCL} +{$IFNDEF CLX} + RegisterProperty('CANVAS', 'TCANVAS', iptr); +{$ENDIF} + {$ENDIF} + end; +end; + + +procedure SIRegisterTLABEL(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TCUSTOMLABEL'), 'TLABEL') do + begin + RegisterProperty('ALIGNMENT', 'TAlignment', iptrw); + RegisterProperty('AUTOSIZE', 'Boolean', iptrw); + RegisterProperty('CAPTION', 'String', iptrw); + RegisterProperty('COLOR', 'TColor', iptrw); + RegisterProperty('DRAGCURSOR', 'Longint', iptrw); + RegisterProperty('DRAGMODE', 'TDragMode', iptrw); + RegisterProperty('FOCUSCONTROL', 'TWinControl', iptrw); + RegisterProperty('FONT', 'TFont', iptrw); + RegisterProperty('LAYOUT', 'TTextLayout', iptrw); + RegisterProperty('PARENTCOLOR', 'Boolean', iptrw); + RegisterProperty('PARENTFONT', 'Boolean', iptrw); + RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw); + RegisterProperty('SHOWACCELCHAR', 'Boolean', iptrw); + RegisterProperty('TRANSPARENT', 'Boolean', iptrw); + RegisterProperty('WORDWRAP', 'Boolean', iptrw); + RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw); + RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw); + RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw); + RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw); + RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw); + RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw); + RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw); + RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw); + RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw); + end; +end; + + + + + + + +procedure SIRegisterTCUSTOMEDIT(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TWINCONTROL'), 'TCUSTOMEDIT') do + begin + RegisterMethod('procedure CLEAR'); + RegisterMethod('procedure CLEARSELECTION'); + RegisterMethod('procedure SELECTALL'); + RegisterProperty('MODIFIED', 'BOOLEAN', iptrw); + RegisterProperty('SELLENGTH', 'INTEGER', iptrw); + RegisterProperty('SELSTART', 'INTEGER', iptrw); + RegisterProperty('SELTEXT', 'String', iptrw); + RegisterProperty('TEXT', 'String', iptrw); + + {$IFNDEF PS_MINIVCL} + RegisterMethod('procedure COPYTOCLIPBOARD'); + RegisterMethod('procedure CUTTOCLIPBOARD'); + RegisterMethod('procedure PASTEFROMCLIPBOARD'); + RegisterMethod('function GETSELTEXTBUF(BUFFER:PCHAR;BUFSIZE:INTEGER):INTEGER'); + RegisterMethod('procedure SETSELTEXTBUF(BUFFER:PCHAR)'); + {$ENDIF} + end; +end; + + + + +procedure SIRegisterTEDIT(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TCUSTOMEDIT'), 'TEDIT') do + begin + RegisterProperty('AUTOSELECT', 'Boolean', iptrw); + RegisterProperty('AUTOSIZE', 'Boolean', iptrw); + RegisterProperty('BORDERSTYLE', 'TBorderStyle', iptrw); + RegisterProperty('CHARCASE', 'TEditCharCase', iptrw); + RegisterProperty('COLOR', 'TColor', iptrw); + RegisterProperty('FONT', 'TFont', iptrw); + RegisterProperty('HIDESELECTION', 'Boolean', iptrw); + RegisterProperty('MAXLENGTH', 'Integer', iptrw); + RegisterProperty('PARENTCOLOR', 'Boolean', iptrw); + RegisterProperty('PARENTFONT', 'Boolean', iptrw); + RegisterProperty('PASSWORDCHAR', 'Char', iptrw); + RegisterProperty('READONLY', 'Boolean', iptrw); + RegisterProperty('TEXT', 'String', iptrw); + RegisterProperty('ONCHANGE', 'TNotifyEvent', iptrw); + RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw); + RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw); + RegisterProperty('ONENTER', 'TNotifyEvent', iptrw); + RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw); + RegisterProperty('ONKEYDOWN', 'TKeyEvent', iptrw); + RegisterProperty('ONKEYPRESS', 'TKeyPressEvent', iptrw); + RegisterProperty('ONKEYUP', 'TKeyEvent', iptrw); + + {$IFNDEF PS_MINIVCL} + RegisterProperty('CTL3D', 'Boolean', iptrw); + RegisterProperty('DRAGCURSOR', 'Longint', iptrw); + RegisterProperty('DRAGMODE', 'TDragMode', iptrw); + RegisterProperty('OEMCONVERT', 'Boolean', iptrw); + RegisterProperty('PARENTCTL3D', 'Boolean', iptrw); + RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw); + RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw); + RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw); + RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw); + RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw); + RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw); + RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw); + RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw); + RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw); + {$ENDIF} + end; +end; + + + + +procedure SIRegisterTCUSTOMMEMO(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TCUSTOMEDIT'), 'TCUSTOMMEMO') do + begin + {$IFNDEF CLX} + RegisterProperty('LINES', 'TSTRINGS', iptrw); + {$ENDIF} + end; +end; + + +procedure SIRegisterTMEMO(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TCUSTOMMEMO'), 'TMEMO') do + begin + {$IFDEF CLX} + RegisterProperty('LINES', 'TSTRINGS', iptrw); + {$ENDIF} + RegisterProperty('ALIGNMENT', 'TAlignment', iptrw); + RegisterProperty('BORDERSTYLE', 'TBorderStyle', iptrw); + RegisterProperty('COLOR', 'TColor', iptrw); + RegisterProperty('FONT', 'TFont', iptrw); + RegisterProperty('HIDESELECTION', 'Boolean', iptrw); + RegisterProperty('MAXLENGTH', 'Integer', iptrw); + RegisterProperty('PARENTCOLOR', 'Boolean', iptrw); + RegisterProperty('PARENTFONT', 'Boolean', iptrw); + RegisterProperty('READONLY', 'Boolean', iptrw); + RegisterProperty('SCROLLBARS', 'TScrollStyle', iptrw); + RegisterProperty('WANTRETURNS', 'Boolean', iptrw); + RegisterProperty('WANTTABS', 'Boolean', iptrw); + RegisterProperty('WORDWRAP', 'Boolean', iptrw); + RegisterProperty('ONCHANGE', 'TNotifyEvent', iptrw); + RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw); + RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw); + RegisterProperty('ONENTER', 'TNotifyEvent', iptrw); + RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw); + RegisterProperty('ONKEYDOWN', 'TKeyEvent', iptrw); + RegisterProperty('ONKEYPRESS', 'TKeyPressEvent', iptrw); + RegisterProperty('ONKEYUP', 'TKeyEvent', iptrw); + + {$IFNDEF PS_MINIVCL} + RegisterProperty('CTL3D', 'Boolean', iptrw); + RegisterProperty('DRAGCURSOR', 'Longint', iptrw); + RegisterProperty('DRAGMODE', 'TDragMode', iptrw); + RegisterProperty('OEMCONVERT', 'Boolean', iptrw); + RegisterProperty('PARENTCTL3D', 'Boolean', iptrw); + RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw); + RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw); + RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw); + RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw); + RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw); + RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw); + RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw); + RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw); + RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw); + {$ENDIF} + end; +end; + + + + + +procedure SIRegisterTCUSTOMCOMBOBOX(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TWINCONTROL'), 'TCUSTOMCOMBOBOX') do + begin + RegisterProperty('DROPPEDDOWN', 'BOOLEAN', iptrw); + RegisterProperty('ITEMS', 'TSTRINGS', iptrw); + RegisterProperty('ITEMINDEX', 'INTEGER', iptrw); + + {$IFNDEF PS_MINIVCL} + RegisterMethod('procedure CLEAR'); + RegisterMethod('procedure SELECTALL'); + RegisterProperty('CANVAS', 'TCANVAS', iptr); + RegisterProperty('SELLENGTH', 'INTEGER', iptrw); + RegisterProperty('SELSTART', 'INTEGER', iptrw); + RegisterProperty('SELTEXT', 'String', iptrw); + {$ENDIF} + end; +end; + + +procedure SIRegisterTCOMBOBOX(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TCUSTOMCOMBOBOX'), 'TCOMBOBOX') do + begin + RegisterProperty('STYLE', 'TComboBoxStyle', iptrw); + RegisterProperty('COLOR', 'TColor', iptrw); + RegisterProperty('DROPDOWNCOUNT', 'Integer', iptrw); + RegisterProperty('FONT', 'TFont', iptrw); + RegisterProperty('MAXLENGTH', 'Integer', iptrw); + RegisterProperty('PARENTCOLOR', 'Boolean', iptrw); + RegisterProperty('PARENTFONT', 'Boolean', iptrw); + RegisterProperty('SORTED', 'Boolean', iptrw); + RegisterProperty('TEXT', 'String', iptrw); + RegisterProperty('ONCHANGE', 'TNotifyEvent', iptrw); + RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw); + RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw); + RegisterProperty('ONDROPDOWN', 'TNotifyEvent', iptrw); + RegisterProperty('ONENTER', 'TNotifyEvent', iptrw); + RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw); + RegisterProperty('ONKEYDOWN', 'TKeyEvent', iptrw); + RegisterProperty('ONKEYPRESS', 'TKeyPressEvent', iptrw); + RegisterProperty('ONKEYUP', 'TKeyEvent', iptrw); + + {$IFNDEF PS_MINIVCL} + RegisterProperty('CTL3D', 'Boolean', iptrw); + RegisterProperty('DRAGMODE', 'TDragMode', iptrw); + RegisterProperty('DRAGCURSOR', 'Longint', iptrw); + RegisterProperty('ITEMHEIGHT', 'Integer', iptrw); + RegisterProperty('PARENTCTL3D', 'Boolean', iptrw); + RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw); + RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw); + RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw); + RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw); + RegisterProperty('ONDRAWITEM', 'TDrawItemEvent', iptrw); + RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw); + RegisterProperty('ONMEASUREITEM', 'TMeasureItemEvent', iptrw); + RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw); + {$ENDIF} + end; +end; + + + +procedure SIRegisterTBUTTONCONTROL(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TWINCONTROL'), 'TBUTTONCONTROL') do + begin + end; +end; + + + +procedure SIRegisterTBUTTON(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TBUTTONCONTROL'), 'TBUTTON') do + begin + RegisterProperty('CANCEL', 'BOOLEAN', iptrw); + RegisterProperty('CAPTION', 'String', iptrw); + RegisterProperty('DEFAULT', 'BOOLEAN', iptrw); + RegisterProperty('FONT', 'TFont', iptrw); + RegisterProperty('MODALRESULT', 'LONGINT', iptrw); + RegisterProperty('PARENTFONT', 'Boolean', iptrw); + RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw); + RegisterProperty('ONENTER', 'TNotifyEvent', iptrw); + RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw); + + {$IFNDEF PS_MINIVCL} + RegisterProperty('DRAGCURSOR', 'Longint', iptrw); + RegisterProperty('DRAGMODE', 'TDragMode', iptrw); + RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw); + RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw); + RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw); + RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw); + RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw); + RegisterProperty('ONKEYDOWN', 'TKeyEvent', iptrw); + RegisterProperty('ONKEYPRESS', 'TKeyPressEvent', iptrw); + RegisterProperty('ONKEYUP', 'TKeyEvent', iptrw); + RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw); + RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw); + RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw); + RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw); + {$ENDIF} + end; +end; + + + +procedure SIRegisterTCUSTOMCHECKBOX(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TBUTTONCONTROL'), 'TCUSTOMCHECKBOX') do + begin + end; +end; + + + +procedure SIRegisterTCHECKBOX(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TCUSTOMCHECKBOX'), 'TCHECKBOX') do + begin + RegisterProperty('ALIGNMENT', 'TAlignment', iptrw); + RegisterProperty('ALLOWGRAYED', 'Boolean', iptrw); + RegisterProperty('CAPTION', 'String', iptrw); + RegisterProperty('CHECKED', 'Boolean', iptrw); + RegisterProperty('COLOR', 'TColor', iptrw); + RegisterProperty('FONT', 'TFont', iptrw); + RegisterProperty('PARENTCOLOR', 'Boolean', iptrw); + RegisterProperty('PARENTFONT', 'Boolean', iptrw); + RegisterProperty('STATE', 'TCheckBoxState', iptrw); + RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw); + RegisterProperty('ONENTER', 'TNotifyEvent', iptrw); + RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw); + + {$IFNDEF PS_MINIVCL} + RegisterProperty('CTL3D', 'Boolean', iptrw); + RegisterProperty('DRAGCURSOR', 'Longint', iptrw); + RegisterProperty('DRAGMODE', 'TDragMode', iptrw); + RegisterProperty('PARENTCTL3D', 'Boolean', iptrw); + RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw); + RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw); + RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw); + RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw); + RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw); + RegisterProperty('ONKEYDOWN', 'TKeyEvent', iptrw); + RegisterProperty('ONKEYPRESS', 'TKeyPressEvent', iptrw); + RegisterProperty('ONKEYUP', 'TKeyEvent', iptrw); + RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw); + RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw); + RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw); + RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw); + {$ENDIF} + end; +end; + + + + + +procedure SIRegisterTRADIOBUTTON(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TBUTTONCONTROL'), 'TRADIOBUTTON') do + begin + RegisterProperty('ALIGNMENT', 'TALIGNMENT', iptrw); + RegisterProperty('CAPTION', 'String', iptrw); + RegisterProperty('CHECKED', 'BOOLEAN', iptrw); + RegisterProperty('COLOR', 'TColor', iptrw); + RegisterProperty('FONT', 'TFont', iptrw); + RegisterProperty('PARENTCOLOR', 'Boolean', iptrw); + RegisterProperty('PARENTFONT', 'Boolean', iptrw); + RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw); + RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw); + RegisterProperty('ONENTER', 'TNotifyEvent', iptrw); + RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw); + + {$IFNDEF PS_MINIVCL} + RegisterProperty('CTL3D', 'Boolean', iptrw); + RegisterProperty('DRAGCURSOR', 'Longint', iptrw); + RegisterProperty('DRAGMODE', 'TDragMode', iptrw); + RegisterProperty('PARENTCTL3D', 'Boolean', iptrw); + RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw); + RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw); + RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw); + RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw); + RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw); + RegisterProperty('ONKEYDOWN', 'TKeyEvent', iptrw); + RegisterProperty('ONKEYPRESS', 'TKeyPressEvent', iptrw); + RegisterProperty('ONKEYUP', 'TKeyEvent', iptrw); + RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw); + RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw); + RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw); + RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw); + {$ENDIF} + end; +end; + + + +procedure SIRegisterTCUSTOMLISTBOX(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TWINCONTROL'), 'TCUSTOMLISTBOX') do + begin + RegisterProperty('ITEMS', 'TSTRINGS', iptrw); + RegisterProperty('ITEMINDEX', 'INTEGER', iptrw); + RegisterProperty('SELCOUNT', 'INTEGER', iptr); + RegisterProperty('SELECTED', 'BOOLEAN INTEGER', iptrw); + + {$IFNDEF PS_MINIVCL} + RegisterMethod('procedure CLEAR'); + RegisterMethod('function ITEMATPOS(POS:TPOINT;EXISTING:BOOLEAN):INTEGER'); + RegisterMethod('function ITEMRECT(INDEX:INTEGER):TRECT'); + RegisterProperty('CANVAS', 'TCANVAS', iptr); + RegisterProperty('TOPINDEX', 'INTEGER', iptrw); + {$ENDIF} + end; +end; + + + +procedure SIRegisterTLISTBOX(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TCUSTOMLISTBOX'), 'TLISTBOX') do + begin + RegisterProperty('BORDERSTYLE', 'TBorderStyle', iptrw); + RegisterProperty('COLOR', 'TColor', iptrw); + RegisterProperty('FONT', 'TFont', iptrw); + RegisterProperty('MULTISELECT', 'Boolean', iptrw); + RegisterProperty('PARENTCOLOR', 'Boolean', iptrw); + RegisterProperty('PARENTFONT', 'Boolean', iptrw); + RegisterProperty('SORTED', 'Boolean', iptrw); + RegisterProperty('STYLE', 'TListBoxStyle', iptrw); + RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw); + RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw); + RegisterProperty('ONENTER', 'TNotifyEvent', iptrw); + RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw); + RegisterProperty('ONKEYDOWN', 'TKeyEvent', iptrw); + RegisterProperty('ONKEYPRESS', 'TKeyPressEvent', iptrw); + RegisterProperty('ONKEYUP', 'TKeyEvent', iptrw); + + {$IFNDEF PS_MINIVCL} + RegisterProperty('COLUMNS', 'Integer', iptrw); + RegisterProperty('CTL3D', 'Boolean', iptrw); + RegisterProperty('DRAGCURSOR', 'Longint', iptrw); + RegisterProperty('DRAGMODE', 'TDragMode', iptrw); + RegisterProperty('EXTENDEDSELECT', 'Boolean', iptrw); + RegisterProperty('INTEGRALHEIGHT', 'Boolean', iptrw); + RegisterProperty('ITEMHEIGHT', 'Integer', iptrw); + RegisterProperty('PARENTCTL3D', 'Boolean', iptrw); + RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw); + RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw); + RegisterProperty('TABWIDTH', 'Integer', iptrw); + RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw); + RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw); + RegisterProperty('ONDRAWITEM', 'TDrawItemEvent', iptrw); + RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw); + RegisterProperty('ONMEASUREITEM', 'TMeasureItemEvent', iptrw); + RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw); + RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw); + RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw); + RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw); + {$ENDIF} + end; +end; + + + + + + +procedure SIRegisterTSCROLLBAR(Cl: TPSPascalCompiler); +begin + with Cl.AddClassN(cl.FindClass('TWINCONTROL'), 'TSCROLLBAR') do + begin + RegisterProperty('KIND', 'TSCROLLBARKIND', iptrw); + RegisterProperty('MAX', 'INTEGER', iptrw); + RegisterProperty('MIN', 'INTEGER', iptrw); + RegisterProperty('POSITION', 'INTEGER', iptrw); + RegisterProperty('ONCHANGE', 'TNOTIFYEVENT', iptrw); + RegisterProperty('ONENTER', 'TNotifyEvent', iptrw); + RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw); + + {$IFNDEF PS_MINIVCL} + RegisterMethod('procedure SETPARAMS(APOSITION,AMIN,AMAX:INTEGER)'); + RegisterProperty('CTL3D', 'Boolean', iptrw); + RegisterProperty('DRAGCURSOR', 'Longint', iptrw); + RegisterProperty('DRAGMODE', 'TDragMode', iptrw); + RegisterProperty('LARGECHANGE', 'TSCROLLBARINC', iptrw); + RegisterProperty('PARENTCTL3D', 'Boolean', iptrw); + RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw); + RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw); + RegisterProperty('SMALLCHANGE', 'TSCROLLBARINC', iptrw); + RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw); + RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw); + RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw); + RegisterProperty('ONKEYDOWN', 'TKeyEvent', iptrw); + RegisterProperty('ONKEYPRESS', 'TKeyPressEvent', iptrw); + RegisterProperty('ONKEYUP', 'TKeyEvent', iptrw); + RegisterProperty('ONSCROLL', 'TSCROLLEVENT', iptrw); + RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw); + {$ENDIF} + end; +end; + + + +procedure SIRegister_StdCtrls_TypesAndConsts(cl: TPSPascalCompiler); +begin + cl.AddTypeS('TEditCharCase', '(ecNormal, ecUpperCase, ecLowerCase)'); + cl.AddTypeS('TScrollStyle', '(ssNone, ssHorizontal, ssVertical, ssBoth)'); + cl.AddTypeS('TComboBoxStyle', '(csDropDown, csSimple, csDropDownList, csOwnerDrawFixed, csOwnerDrawVariable)'); + cl.AddTypeS('TDrawItemEvent', 'procedure(Control: TWinControl; Index: Integer; Rect: TRect; State: Byte)'); + cl.AddTypeS('TMeasureItemEvent', 'procedure(Control: TWinControl; Index: Integer; var Height: Integer)'); + cl.AddTypeS('TCheckBoxState', '(cbUnchecked, cbChecked, cbGrayed)'); + cl.AddTypeS('TListBoxStyle', '(lbStandard, lbOwnerDrawFixed, lbOwnerDrawVariable)'); + cl.AddTypeS('TScrollCode', '(scLineUp, scLineDown, scPageUp, scPageDown, scPosition, scTrack, scTop, scBottom, scEndScroll)'); + cl.AddTypeS('TScrollEvent', 'procedure(Sender: TObject; ScrollCode: TScrollCode;var ScrollPos: Integer)'); + + Cl.addTypeS('TEOwnerDrawState', '(odSelected, odGrayed, odDisabled, odChecked,' + +' odFocused, odDefault, odHotLight, odInactive, odNoAccel, odNoFocusRect,' + +' odReserved1, odReserved2, odComboBoxEdit)'); + cl.AddTypeS('TTextLayout', '( tlTop, tlCenter, tlBottom )'); + cl.AddTypeS('TOwnerDrawState', 'set of TEOwnerDrawState'); +end; + + +procedure SIRegister_stdctrls(cl: TPSPascalCompiler); +begin + SIRegister_StdCtrls_TypesAndConsts(cl); + {$IFNDEF PS_MINIVCL} + SIRegisterTCUSTOMGROUPBOX(Cl); + SIRegisterTGROUPBOX(Cl); + {$ENDIF} + SIRegisterTCUSTOMLABEL(Cl); + SIRegisterTLABEL(Cl); + SIRegisterTCUSTOMEDIT(Cl); + SIRegisterTEDIT(Cl); + SIRegisterTCUSTOMMEMO(Cl); + SIRegisterTMEMO(Cl); + SIRegisterTCUSTOMCOMBOBOX(Cl); + SIRegisterTCOMBOBOX(Cl); + SIRegisterTBUTTONCONTROL(Cl); + SIRegisterTBUTTON(Cl); + SIRegisterTCUSTOMCHECKBOX(Cl); + SIRegisterTCHECKBOX(Cl); + SIRegisterTRADIOBUTTON(Cl); + SIRegisterTCUSTOMLISTBOX(Cl); + SIRegisterTLISTBOX(Cl); + {$IFNDEF PS_MINIVCL} + SIRegisterTSCROLLBAR(Cl); + {$ENDIF} +end; + +// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl) + + +end. + + + + + diff --git a/Units/PascalScript/uPSCompiler.pas b/Units/PascalScript/uPSCompiler.pas new file mode 100644 index 0000000..6329849 --- /dev/null +++ b/Units/PascalScript/uPSCompiler.pas @@ -0,0 +1,15397 @@ +unit uPSCompiler; +{$I PascalScript.inc} +interface +uses + {$IFNDEF DELPHI3UP}{$IFNDEF PS_NOINTERFACES}{$IFNDEF LINUX}Windows, Ole2,{$ENDIF} + {$ENDIF}{$ENDIF}SysUtils, uPSUtils; + + +type +{$IFNDEF PS_NOINTERFACES} + TPSInterface = class; +{$ENDIF} + + TPSParameterMode = (pmIn, pmOut, pmInOut); + TPSPascalCompiler = class; + TPSType = class; + TPSValue = class; + TPSParameters = class; + + TPSSubOptType = (tMainBegin, tProcBegin, tSubBegin, tOneLiner, tifOneliner, tRepeat, tTry, tTryEnd + {$IFDEF PS_USESSUPPORT},tUnitInit, tUnitFinish {$ENDIF}); //nvds + + + {TPSExternalClass is used when external classes need to be called} + TPSCompileTimeClass = class; + TPSAttributes = class; + TPSAttribute = class; + + EPSCompilerException = class(Exception) end; + + TPSParameterDecl = class(TObject) + private + FName: tbtString; + FOrgName: tbtString; + FMode: TPSParameterMode; + FType: TPSType; + {$IFDEF PS_USESSUPPORT} + FDeclareUnit: tbtString; + {$ENDIF} + FDeclarePos: Cardinal; + FDeclareRow: Cardinal; + FDeclareCol: Cardinal; + procedure SetName(const s: tbtString); + public + + property Name: tbtString read FName; + + property OrgName: tbtString read FOrgName write SetName; + + property aType: TPSType read FType write FType; + + property Mode: TPSParameterMode read FMode write FMode; + + {$IFDEF PS_USESSUPPORT} + property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit; + {$ENDIF} + + property DeclarePos: Cardinal read FDeclarePos write FDeclarePos; + + property DeclareRow: Cardinal read FDeclareRow write FDeclareRow; + + property DeclareCol: Cardinal read FDeclareCol write FDeclareCol; + + end; + + + TPSParametersDecl = class(TObject) + private + FParams: TPSList; + FResult: TPSType; + function GetParam(I: Longint): TPSParameterDecl; + function GetParamCount: Longint; + public + + property Params[I: Longint]: TPSParameterDecl read GetParam; + + property ParamCount: Longint read GetParamCount; + + + function AddParam: TPSParameterDecl; + + procedure DeleteParam(I: Longint); + + + property Result : TPSType read FResult write FResult; + + + procedure Assign(Params: TPSParametersDecl); + + + function Same(d: TPSParametersDecl): boolean; + + + constructor Create; + + destructor Destroy; override; + end; + + + TPSRegProc = class(TObject) + private + FNameHash: Longint; + FName: tbtString; + FDecl: TPSParametersDecl; + FExportName: Boolean; + FImportDecl: tbtString; + FOrgName: tbtString; + procedure SetName(const Value: tbtString); + public + + property OrgName: tbtString read FOrgName write FOrgName; + + property Name: tbtString read FName write SetName; + + property NameHash: Longint read FNameHash; + + property Decl: TPSParametersDecl read FDecl; + + property ExportName: Boolean read FExportName write FExportName; + + property ImportDecl: tbtString read FImportDecl write FImportDecl; + + + constructor Create; + + destructor Destroy; override; + end; + + PIFPSRegProc = TPSRegProc; + + PIfRVariant = ^TIfRVariant; + + TIfRVariant = record + + FType: TPSType; + case Byte of + 1: (tu8: TbtU8); + 2: (tS8: TbtS8); + 3: (tu16: TbtU16); + 4: (ts16: TbtS16); + 5: (tu32: TbtU32); + 6: (ts32: TbtS32); + 7: (tsingle: TbtSingle); + 8: (tdouble: TbtDouble); + 9: (textended: TbtExtended); + 11: (tcurrency: tbtCurrency); + 10: (tstring: Pointer); + {$IFNDEF PS_NOINT64} + 17: (ts64: Tbts64); + {$ENDIF} + 19: (tchar: tbtChar); + {$IFNDEF PS_NOWIDESTRING} + 18: (twidestring: Pointer); + 20: (twidechar: tbtwidechar); + {$ENDIF} + 21: (ttype: TPSType); + 22: (tunistring: Pointer); + end; + + TPSRecordFieldTypeDef = class(TObject) + private + FFieldOrgName: tbtString; + FFieldName: tbtString; + FFieldNameHash: Longint; + FType: TPSType; + procedure SetFieldOrgName(const Value: tbtString); + public + + property FieldOrgName: tbtString read FFieldOrgName write SetFieldOrgName; + + property FieldName: tbtString read FFieldName; + + property FieldNameHash: Longint read FFieldNameHash; + + property aType: TPSType read FType write FType; + end; + + PIFPSRecordFieldTypeDef = TPSRecordFieldTypeDef; + + TPSType = class(TObject) + private + FNameHash: Longint; + FName: tbtString; + FBaseType: TPSBaseType; + {$IFDEF PS_USESSUPPORT} + FDeclareUnit: tbtString; + {$ENDIF} + FDeclarePos: Cardinal; + FDeclareRow: Cardinal; + FDeclareCol: Cardinal; + FUsed: Boolean; + FExportName: Boolean; + FOriginalName: tbtString; + FAttributes: TPSAttributes; + FFinalTypeNo: cardinal; + procedure SetName(const Value: tbtString); + public + + constructor Create; + + destructor Destroy; override; + + property Attributes: TPSAttributes read FAttributes; + + + property FinalTypeNo: cardinal read FFinalTypeNo; + + + property OriginalName: tbtString read FOriginalName write FOriginalName; + + property Name: tbtString read FName write SetName; + + property NameHash: Longint read FNameHash; + + property BaseType: TPSBaseType read FBaseType write FBaseType; + + {$IFDEF PS_USESSUPPORT} + property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit; + {$ENDIF} + + property DeclarePos: Cardinal read FDeclarePos write FDeclarePos; + + property DeclareRow: Cardinal read FDeclareRow write FDeclareRow; + + property DeclareCol: Cardinal read FDeclareCol write FDeclareCol; + + property Used: Boolean read FUsed; + + property ExportName: Boolean read FExportName write FExportName; + + procedure Use; + end; + + + PIFPSType = TPSType; + + TPSVariantType = class(TPSType) + private + public + function GetDynInvokeProcNo(Owner: TPSPascalCompiler; const Name: tbtString; Params: TPSParameters): Cardinal; virtual; + function GetDynIvokeSelfType(Owner: TPSPascalCompiler): TPSType; virtual; + function GetDynInvokeParamType(Owner: TPSPascalCompiler): TPSType; virtual; + function GetDynIvokeResulType(Owner: TPSPascalCompiler): TPSType; virtual; + end; + + + TPSRecordType = class(TPSType) + private + FRecordSubVals: TPSList; + public + + constructor Create; + + destructor Destroy; override; + + function RecValCount: Longint; + + function RecVal(I: Longint): PIFPSRecordFieldTypeDef; + + function AddRecVal: PIFPSRecordFieldTypeDef; + end; + + TPSClassType = class(TPSType) + private + FCL: TPSCompiletimeClass; + public + + property Cl: TPSCompileTimeClass read FCL write FCL; + end; + TPSExternalClass = class; + TPSUndefinedClassType = class(TPSType) + private + FExtClass: TPSExternalClass; + public + property ExtClass: TPSExternalClass read FExtClass write FExtClass; + end; +{$IFNDEF PS_NOINTERFACES} + + TPSInterfaceType = class(TPSType) + private + FIntf: TPSInterface; + public + + property Intf: TPSInterface read FIntf write FIntf; + end; +{$ENDIF} + + + TPSProceduralType = class(TPSType) + private + FProcDef: TPSParametersDecl; + public + + property ProcDef: TPSParametersDecl read FProcDef; + + constructor Create; + + destructor Destroy; override; + end; + + TPSArrayType = class(TPSType) + private + FArrayTypeNo: TPSType; + public + + property ArrayTypeNo: TPSType read FArrayTypeNo write FArrayTypeNo; + end; + + TPSStaticArrayType = class(TPSArrayType) + private + FStartOffset: Longint; + FLength: Cardinal; + public + + property StartOffset: Longint read FStartOffset write FStartOffset; + + property Length: Cardinal read FLength write FLength; + end; + + TPSSetType = class(TPSType) + private + FSetType: TPSType; + function GetByteSize: Longint; + function GetBitSize: Longint; + public + + property SetType: TPSType read FSetType write FSetType; + + property ByteSize: Longint read GetByteSize; + + property BitSize: Longint read GetBitSize; + end; + + TPSTypeLink = class(TPSType) + private + FLinkTypeNo: TPSType; + public + + property LinkTypeNo: TPSType read FLinkTypeNo write FLinkTypeNo; + end; + + TPSEnumType = class(TPSType) + private + FHighValue: Cardinal; + public + + property HighValue: Cardinal read FHighValue write FHighValue; + end; + + + TPSProcedure = class(TObject) + private + FAttributes: TPSAttributes; + public + + property Attributes: TPSAttributes read FAttributes; + + + constructor Create; + + destructor Destroy; override; + end; + + TPSAttributeType = class; + + TPSAttributeTypeField = class(TObject) + private + FOwner: TPSAttributeType; + FFieldOrgName: tbtString; + FFieldName: tbtString; + FFieldNameHash: Longint; + FFieldType: TPSType; + FHidden: Boolean; + procedure SetFieldOrgName(const Value: tbtString); + public + + constructor Create(AOwner: TPSAttributeType); + + property Owner: TPSAttributeType read FOwner; + + property FieldOrgName: tbtString read FFieldOrgName write SetFieldOrgName; + + property FieldName: tbtString read FFieldName; + + property FieldNameHash: Longint read FFieldNameHash; + + property FieldType: TPSType read FFieldType write FFieldType; + + property Hidden: Boolean read FHidden write FHidden; + end; + + TPSApplyAttributeToType = function (Sender: TPSPascalCompiler; aType: TPSType; Attr: TPSAttribute): Boolean; + + TPSApplyAttributeToProc = function (Sender: TPSPascalCompiler; aProc: TPSProcedure; Attr: TPSAttribute): Boolean; + { An attribute type } + TPSAttributeType = class(TPSType) + private + FFields: TPSList; + FName: tbtString; + FOrgname: tbtString; + FNameHash: Longint; + FAAProc: TPSApplyAttributeToProc; + FAAType: TPSApplyAttributeToType; + function GetField(I: Longint): TPSAttributeTypeField; + function GetFieldCount: Longint; + procedure SetName(const s: tbtString); + public + + property OnApplyAttributeToType: TPSApplyAttributeToType read FAAType write FAAType; + + property OnApplyAttributeToProc: TPSApplyAttributeToProc read FAAProc write FAAProc; + + property Fields[i: Longint]: TPSAttributeTypeField read GetField; + + property FieldCount: Longint read GetFieldCount; + + procedure DeleteField(I: Longint); + + function AddField: TPSAttributeTypeField; + + property Name: tbtString read FName; + + property OrgName: tbtString read FOrgName write SetName; + + property NameHash: Longint read FNameHash; + + constructor Create; + + destructor Destroy; override; + end; + + TPSAttribute = class(TObject) + private + FAttribType: TPSAttributeType; + FValues: TPSList; + function GetValueCount: Longint; + function GetValue(I: Longint): PIfRVariant; + public + + constructor Create(AttribType: TPSAttributeType); + + procedure Assign(Item: TPSAttribute); + + property AType: TPSAttributeType read FAttribType; + + property Count: Longint read GetValueCount; + + property Values[i: Longint]: PIfRVariant read GetValue; default; + + procedure DeleteValue(i: Longint); + + function AddValue(v: PIFRVariant): Longint; + + destructor Destroy; override; + end; + + + TPSAttributes = class(TObject) + private + FItems: TPSList; + function GetCount: Longint; + function GetItem(I: Longint): TPSAttribute; + public + + procedure Assign(attr: TPSAttributes; Move: Boolean); + + property Count: Longint read GetCount; + + property Items[i: Longint]: TPSAttribute read GetItem; default; + + procedure Delete(i: Longint); + + function Add(AttribType: TPSAttributeType): TPSAttribute; + + function FindAttribute(const Name: tbtString): TPSAttribute; + + constructor Create; + + destructor Destroy; override; + end; + + + TPSProcVar = class(TObject) + private + FNameHash: Longint; + FName: tbtString; + FOrgName: tbtString; + FType: TPSType; + FUsed: Boolean; + {$IFDEF PS_USESSUPPORT} + FDeclareUnit: tbtString; + {$ENDIF} + FDeclarePos, FDeclareRow, FDeclareCol: Cardinal; + procedure SetName(const Value: tbtString); + public + + property OrgName: tbtString read FOrgName write FOrgname; + + property NameHash: Longint read FNameHash; + + property Name: tbtString read FName write SetName; + + property AType: TPSType read FType write FType; + + property Used: Boolean read FUsed; + + {$IFDEF PS_USESSUPPORT} + property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit; + {$ENDIF} + + property DeclarePos: Cardinal read FDeclarePos write FDeclarePos; + + property DeclareRow: Cardinal read FDeclareRow write FDeclareRow; + + property DeclareCol: Cardinal read FDeclareCol write FDeclareCol; + + procedure Use; + end; + + PIFPSProcVar = TPSProcVar; + + TPSExternalProcedure = class(TPSProcedure) + private + FRegProc: TPSRegProc; + public + + property RegProc: TPSRegProc read FRegProc write FRegProc; + end; + + + TPSInternalProcedure = class(TPSProcedure) + private + FForwarded: Boolean; + FData: tbtString; + FNameHash: Longint; + FName: tbtString; + FDecl: TPSParametersDecl; + FProcVars: TPSList; + FUsed: Boolean; + FOutputDeclPosition: Cardinal; + FResultUsed: Boolean; + FLabels: TIfStringList; + FGotos: TIfStringList; + FDeclareRow: Cardinal; + {$IFDEF PS_USESSUPPORT} + FDeclareUnit: tbtString; + {$ENDIF} + FDeclarePos: Cardinal; + FDeclareCol: Cardinal; + FOriginalName: tbtString; + procedure SetName(const Value: tbtString); + public + + constructor Create; + + destructor Destroy; override; + {Attributes} + + + property Forwarded: Boolean read FForwarded write FForwarded; + + property Data: tbtString read FData write FData; + + property Decl: TPSParametersDecl read FDecl; + + property OriginalName: tbtString read FOriginalName write FOriginalName; + + property Name: tbtString read FName write SetName; + + property NameHash: Longint read FNameHash; + + property ProcVars: TPSList read FProcVars; + + property Used: Boolean read FUsed; + + {$IFDEF PS_USESSUPPORT} + property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit; + {$ENDIF} + + property DeclarePos: Cardinal read FDeclarePos write FDeclarePos; + + property DeclareRow: Cardinal read FDeclareRow write FDeclareRow; + + property DeclareCol: Cardinal read FDeclareCol write FDeclareCol; + + property OutputDeclPosition: Cardinal read FOutputDeclPosition write FOutputDeclPosition; + + property ResultUsed: Boolean read FResultUsed; + + + property Labels: TIfStringList read FLabels; + + property Gotos: TIfStringList read FGotos; + + procedure Use; + + procedure ResultUse; + end; + + TPSVar = class(TObject) + private + FNameHash: Longint; + FOrgName: tbtString; + FName: tbtString; + FType: TPSType; + FUsed: Boolean; + FExportName: tbtString; + FDeclareRow: Cardinal; + {$IFDEF PS_USESSUPPORT} + FDeclareUnit: tbtString; + {$ENDIF} + FDeclarePos: Cardinal; + FDeclareCol: Cardinal; + FSaveAsPointer: Boolean; + procedure SetName(const Value: tbtString); + public + + property SaveAsPointer: Boolean read FSaveAsPointer write FSaveAsPointer; + + property ExportName: tbtString read FExportName write FExportName; + + property Used: Boolean read FUsed; + + property aType: TPSType read FType write FType; + + property OrgName: tbtString read FOrgName write FOrgName; + + property Name: tbtString read FName write SetName; + + property NameHash: Longint read FNameHash; + + {$IFDEF PS_USESSUPPORT} + property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit; + {$ENDIF} + + property DeclarePos: Cardinal read FDeclarePos write FDeclarePos; + + property DeclareRow: Cardinal read FDeclareRow write FDeclareRow; + + property DeclareCol: Cardinal read FDeclareCol write FDeclareCol; + + procedure Use; + end; + + PIFPSVar = TPSVar; + + TPSConstant = class(TObject) + private + + FOrgName: tbtString; + + FNameHash: Longint; + + FName: tbtString; + + FDeclareRow: Cardinal; + {$IFDEF PS_USESSUPPORT} + FDeclareUnit: tbtString; + {$ENDIF} + FDeclarePos: Cardinal; + FDeclareCol: Cardinal; + + FValue: PIfRVariant; + procedure SetName(const Value: tbtString); + public + + property OrgName: tbtString read FOrgName write FOrgName; + + property Name: tbtString read FName write SetName; + + property NameHash: Longint read FNameHash; + + property Value: PIfRVariant read FValue write FValue; + + {$IFDEF PS_USESSUPPORT} + property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit; + {$ENDIF} + + property DeclarePos: Cardinal read FDeclarePos write FDeclarePos; + + property DeclareRow: Cardinal read FDeclareRow write FDeclareRow; + + property DeclareCol: Cardinal read FDeclareCol write FDeclareCol; + + + procedure SetSet(const val); + + + procedure SetInt(const Val: Longint); + + procedure SetUInt(const Val: Cardinal); + {$IFNDEF PS_NOINT64} + + procedure SetInt64(const Val: Int64); + {$ENDIF} + + procedure SetString(const Val: tbtString); + + procedure SetChar(c: tbtChar); + {$IFNDEF PS_NOWIDESTRING} + + procedure SetWideChar(const val: WideChar); + + procedure SetWideString(const val: tbtwidestring); + procedure SetUnicodeString(const val: tbtunicodestring); + {$ENDIF} + + procedure SetExtended(const Val: Extended); + + + destructor Destroy; override; + end; + + PIFPSConstant = TPSConstant; + + TPSPascalCompilerErrorType = ( + ecUnknownIdentifier, + ecIdentifierExpected, + ecCommentError, + ecStringError, + ecCharError, + ecSyntaxError, + ecUnexpectedEndOfFile, + ecSemicolonExpected, + ecBeginExpected, + ecPeriodExpected, + ecDuplicateIdentifier, + ecColonExpected, + ecUnknownType, + ecCloseRoundExpected, + ecTypeMismatch, + ecInternalError, + ecAssignmentExpected, + ecThenExpected, + ecDoExpected, + ecNoResult, + ecOpenRoundExpected, + ecCommaExpected, + ecToExpected, + ecIsExpected, + ecOfExpected, + ecCloseBlockExpected, + ecVariableExpected, + ecStringExpected, + ecEndExpected, + ecUnSetLabel, + ecNotInLoop, + ecInvalidJump, + ecOpenBlockExpected, + ecWriteOnlyProperty, + ecReadOnlyProperty, + ecClassTypeExpected, + ecCustomError, + ecDivideByZero, + ecMathError, + ecUnsatisfiedForward, + ecForwardParameterMismatch, + ecInvalidnumberOfParameters + {$IFDEF PS_USESSUPPORT} + , ecNotAllowed, + ecUnitNotFoundOrContainsErrors + {$ENDIF} + ); + + TPSPascalCompilerHintType = ( + ehVariableNotUsed, + ehFunctionNotUsed, + ehCustomHint + ); + + TPSPascalCompilerWarningType = ( + ewCalculationAlwaysEvaluatesTo, + ewIsNotNeeded, + ewAbstractClass, + ewCustomWarning + ); + + TPSPascalCompilerMessage = class(TObject) + protected + + FRow: Cardinal; + + FCol: Cardinal; + + FModuleName: tbtString; + + FParam: tbtString; + + FPosition: Cardinal; + + procedure SetParserPos(Parser: TPSPascalParser); + public + + property ModuleName: tbtString read FModuleName write FModuleName; + + property Param: tbtString read FParam write FParam; + + property Pos: Cardinal read FPosition write FPosition; + + property Row: Cardinal read FRow write FRow; + + property Col: Cardinal read FCol write FCol; + + function ErrorType: tbtString; virtual; abstract; + + procedure SetCustomPos(Pos, Row, Col: Cardinal); + + function MessageToString: tbtString; virtual; + + function ShortMessageToString: tbtString; virtual; abstract; + end; + + TPSPascalCompilerError = class(TPSPascalCompilerMessage) + protected + + FError: TPSPascalCompilerErrorType; + public + + property Error: TPSPascalCompilerErrorType read FError; + + function ErrorType: tbtString; override; + function ShortMessageToString: tbtString; override; + end; + + TPSPascalCompilerHint = class(TPSPascalCompilerMessage) + protected + + FHint: TPSPascalCompilerHintType; + public + + property Hint: TPSPascalCompilerHintType read FHint; + + function ErrorType: tbtString; override; + function ShortMessageToString: tbtString; override; + end; + + TPSPascalCompilerWarning = class(TPSPascalCompilerMessage) + protected + + FWarning: TPSPascalCompilerWarningType; + public + + property Warning: TPSPascalCompilerWarningType read FWarning; + + function ErrorType: tbtString; override; + function ShortMessageToString: tbtString; override; + end; + TPSDuplicCheck = set of (dcTypes, dcProcs, dcVars, dcConsts); + + TPSBlockInfo = class(TObject) + private + FOwner: TPSBlockInfo; + FWithList: TPSList; + FProcNo: Cardinal; + FProc: TPSInternalProcedure; + FSubType: TPSSubOptType; + public + + property WithList: TPSList read FWithList; + + property ProcNo: Cardinal read FProcNo write FProcNo; + + property Proc: TPSInternalProcedure read FProc write FProc; + + property SubType: TPSSubOptType read FSubType write FSubType; + + procedure Clear; + + constructor Create(Owner: TPSBlockInfo); + + destructor Destroy; override; + end; + + + + TPSBinOperatorType = (otAdd, otSub, otMul, otDiv, otMod, otShl, otShr, otAnd, otOr, otXor, otAs, + otGreaterEqual, otLessEqual, otGreater, otLess, otEqual, + otNotEqual, otIs, otIn); + + TPSUnOperatorType = (otNot, otMinus, otCast); + + TPSOnUseVariable = procedure (Sender: TPSPascalCompiler; VarType: TPSVariableType; VarNo: Longint; ProcNo, Position: Cardinal; const PropData: tbtString); + + TPSOnUses = function(Sender: TPSPascalCompiler; const Name: tbtString): Boolean; + + TPSOnExportCheck = function(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure; const ProcDecl: tbtString): Boolean; + + {$IFNDEF PS_USESSUPPORT} + TPSOnWriteLineEvent = function (Sender: TPSPascalCompiler; Position: Cardinal): Boolean; + {$ELSE} + TPSOnWriteLineEvent = function (Sender: TPSPascalCompiler; FileName: tbtString; Position: Cardinal): Boolean; + {$ENDIF} + + TPSOnExternalProc = function (Sender: TPSPascalCompiler; Decl: TPSParametersDecl; const Name, FExternal: tbtString): TPSRegProc; + + TPSOnTranslateLineInfoProc = procedure (Sender: TPSPascalCompiler; var Pos, Row, Col: Cardinal; var Name: tbtString); + TPSOnNotify = function (Sender: TPSPascalCompiler): Boolean; + + TPSOnFunction = procedure(name: tbtString; Pos, Row, Col: Integer) of object; + + + TPSPascalCompiler = class + protected + FAnyString: TPSType; + FUnitName: tbtString; + FID: Pointer; + FOnExportCheck: TPSOnExportCheck; + FDefaultBoolType: TPSType; + FRegProcs: TPSList; + FConstants: TPSList; + FProcs: TPSList; + FTypes: TPSList; + FAttributeTypes: TPSList; + FVars: TPSList; + FOutput: tbtString; + FParser: TPSPascalParser; + FParserHadError: Boolean; + FMessages: TPSList; + FOnUses: TPSOnUses; + FUtf8Decode: Boolean; + FIsUnit: Boolean; + FAllowNoBegin: Boolean; + FAllowNoEnd: Boolean; + FAllowUnit: Boolean; + FBooleanShortCircuit: Boolean; + FDebugOutput: tbtString; + FOnExternalProc: TPSOnExternalProc; + FOnUseVariable: TPSOnUseVariable; + FOnBeforeOutput: TPSOnNotify; + FOnBeforeCleanup: TPSOnNotify; + FOnWriteLine: TPSOnWriteLineEvent; + FContinueOffsets, FBreakOffsets: TPSList; + FOnTranslateLineInfo: TPSOnTranslateLineInfoProc; + FAutoFreeList: TPSList; + FClasses: TPSList; + FOnFunctionStart: TPSOnFunction; + FOnFunctionEnd: TPSOnFunction; + + + FWithCount: Integer; + FTryCount: Integer; + FExceptFinallyCount: Integer; + + + {$IFDEF PS_USESSUPPORT} + FUnitInits : TPSList; //nvds + FUnitFinits: TPSList; //nvds + FUses : TIFStringList; + fModule : tbtString; + {$ENDIF} + fInCompile : Integer; +{$IFNDEF PS_NOINTERFACES} + FInterfaces: TPSList; +{$ENDIF} + + FCurrUsedTypeNo: Cardinal; + FGlobalBlock: TPSBlockInfo; + + function IsBoolean(aType: TPSType): Boolean; + {$IFNDEF PS_NOWIDESTRING} + + function GetWideString(Src: PIfRVariant; var s: Boolean): tbtwidestring; + function GetUnicodeString(Src: PIfRVariant; var s: Boolean): tbtunicodestring; + {$ENDIF} + function PreCalc(FUseUsedTypes: Boolean; Var1Mod: Byte; var1: PIFRVariant; Var2Mod: Byte; + Var2: PIfRVariant; Cmd: TPSBinOperatorType; Pos, Row, Col: Cardinal): Boolean; + + function FindBaseType(BaseType: TPSBaseType): TPSType; + + function IsIntBoolType(aType: TPSType): Boolean; + function GetTypeCopyLink(p: TPSType): TPSType; + + function at2ut(p: TPSType): TPSType; + procedure UseProc(procdecl: TPSParametersDecl); + + + function GetMsgCount: Longint; + + function GetMsg(l: Longint): TPSPascalCompilerMessage; + + + function MakeExportDecl(decl: TPSParametersDecl): tbtString; + + + procedure DefineStandardTypes; + + procedure DefineStandardProcedures; + + function ReadReal(const s: tbtString): PIfRVariant; + function ReadString: PIfRVariant; + function ReadInteger(const s: tbtString): PIfRVariant; + function ReadAttributes(Dest: TPSAttributes): Boolean; + function ReadConstant(FParser: TPSPascalParser; StopOn: TPSPasToken): PIfRVariant; + + function ApplyAttribsToFunction(func: TPSProcedure): boolean; + function ProcessFunction(AlwaysForward: Boolean; Att: TPSAttributes): Boolean; + function ValidateParameters(BlockInfo: TPSBlockInfo; Params: TPSParameters; ParamTypes: TPSParametersDecl): boolean; + + function IsVarInCompatible(ft1, ft2: TPSType): Boolean; + function GetTypeNo(BlockInfo: TPSBlockInfo; p: TPSValue): TPSType; + function DoVarBlock(proc: TPSInternalProcedure): Boolean; + function DoTypeBlock(FParser: TPSPascalParser): Boolean; + function ReadType(const Name: tbtString; FParser: TPSPascalParser): TPSType; + function ProcessLabel(Proc: TPSInternalProcedure): Boolean; + function ProcessSub(BlockInfo: TPSBlockInfo): Boolean; + function ProcessLabelForwards(Proc: TPSInternalProcedure): Boolean; + + procedure WriteDebugData(const s: tbtString); + + procedure Debug_SavePosition(ProcNo: Cardinal; Proc: TPSInternalProcedure); + + procedure Debug_WriteParams(ProcNo: Cardinal; Proc: TPSInternalProcedure); + + procedure Debug_WriteLine(BlockInfo: TPSBlockInfo); + + + function IsCompatibleType(p1, p2: TPSType; Cast: Boolean): Boolean; + + function IsDuplicate(const s: tbtString; const check: TPSDuplicCheck): Boolean; + + function NewProc(const OriginalName, Name: tbtString): TPSInternalProcedure; + + function AddUsedFunction(var Proc: TPSInternalProcedure): Cardinal; + + function AddUsedFunction2(var Proc: TPSExternalProcedure): Cardinal; + + + function CheckCompatProc(P: TPSType; ProcNo: Cardinal): Boolean; + + + procedure ParserError(Parser: TObject; Kind: TPSParserErrorKind); + + function ReadTypeAddProcedure(const Name: tbtString; FParser: TPSPascalParser): TPSType; + + function VarIsDuplicate(Proc: TPSInternalProcedure; const VarNames, s: tbtString): Boolean; + + function IsProcDuplicLabel(Proc: TPSInternalProcedure; const s: tbtString): Boolean; + + procedure CheckForUnusedVars(Func: TPSInternalProcedure); + function ProcIsDuplic(Decl: TPSParametersDecl; const FunctionName, FunctionParamNames: tbtString; const s: tbtString; Func: TPSInternalProcedure): Boolean; + public + function GetConstant(const Name: tbtString): TPSConstant; + + function UseExternalProc(const Name: tbtString): TPSParametersDecl; + + function FindProc(const aName: tbtString): Cardinal; + + function GetTypeCount: Longint; + + function GetType(I: Longint): TPSType; + + function GetVarCount: Longint; + + function GetVar(I: Longint): TPSVar; + + function GetProcCount: Longint; + + function GetProc(I: Longint): TPSProcedure; + + function GetConstCount: Longint; + + function GetConst(I: Longint): TPSConstant; + + function GetRegProcCount: Longint; + + function GetRegProc(I: Longint): TPSRegProc; + + function AddAttributeType: TPSAttributeType; + function FindAttributeType(const Name: tbtString): TPSAttributeType; + + procedure AddToFreeList(Obj: TObject); + + property ID: Pointer read FID write FID; + + function MakeError(const Module: tbtString; E: TPSPascalCompilerErrorType; const + Param: tbtString): TPSPascalCompilerMessage; + + function MakeWarning(const Module: tbtString; E: TPSPascalCompilerWarningType; + const Param: tbtString): TPSPascalCompilerMessage; + + function MakeHint(const Module: tbtString; E: TPSPascalCompilerHintType; + const Param: tbtString): TPSPascalCompilerMessage; + +{$IFNDEF PS_NOINTERFACES} + + function AddInterface(InheritedFrom: TPSInterface; Guid: TGuid; const Name: tbtString): TPSInterface; + + function FindInterface(const Name: tbtString): TPSInterface; + +{$ENDIF} + function AddClass(InheritsFrom: TPSCompileTimeClass; aClass: TClass): TPSCompileTimeClass; + + function AddClassN(InheritsFrom: TPSCompileTimeClass; const aClass: tbtString): TPSCompileTimeClass; + + + function FindClass(const aClass: tbtString): TPSCompileTimeClass; + + function AddFunction(const Header: tbtString): TPSRegProc; + + function AddDelphiFunction(const Decl: tbtString): TPSRegProc; + + function AddType(const Name: tbtString; const BaseType: TPSBaseType): TPSType; + + function AddTypeS(const Name, Decl: tbtString): TPSType; + + function AddTypeCopy(const Name: tbtString; TypeNo: TPSType): TPSType; + + function AddTypeCopyN(const Name, FType: tbtString): TPSType; + + function AddConstant(const Name: tbtString; FType: TPSType): TPSConstant; + + function AddConstantN(const Name, FType: tbtString): TPSConstant; + + function AddVariable(const Name: tbtString; FType: TPSType): TPSVar; + + function AddVariableN(const Name, FType: tbtString): TPSVar; + + function AddUsedVariable(const Name: tbtString; FType: TPSType): TPSVar; + + function AddUsedVariableN(const Name, FType: tbtString): TPSVar; + + function AddUsedPtrVariable(const Name: tbtString; FType: TPSType): TPSVar; + + function AddUsedPtrVariableN(const Name, FType: tbtString): TPSVar; + + function FindType(const Name: tbtString): TPSType; + + function MakeDecl(decl: TPSParametersDecl): tbtString; + + function Compile(const s: tbtString): Boolean; + + function GetOutput(var s: tbtString): Boolean; + + function GetDebugOutput(var s: tbtString): Boolean; + + procedure Clear; + + constructor Create; + + destructor Destroy; override; + + property MsgCount: Longint read GetMsgCount; + + property Msg[l: Longint]: TPSPascalCompilerMessage read GetMsg; + + property OnTranslateLineInfo: TPSOnTranslateLineInfoProc read FOnTranslateLineInfo write FOnTranslateLineInfo; + + property OnUses: TPSOnUses read FOnUses write FOnUses; + + property OnExportCheck: TPSOnExportCheck read FOnExportCheck write FOnExportCheck; + + property OnWriteLine: TPSOnWriteLineEvent read FOnWriteLine write FOnWriteLine; + + property OnExternalProc: TPSOnExternalProc read FOnExternalProc write FOnExternalProc; + + property OnUseVariable: TPSOnUseVariable read FOnUseVariable write FOnUseVariable; + + property OnBeforeOutput: TPSOnNotify read FOnBeforeOutput write FOnBeforeOutput; + + property OnBeforeCleanup: TPSOnNotify read FOnBeforeCleanup write FOnBeforeCleanup; + + property OnFunctionStart: TPSOnFunction read FOnFunctionStart write FOnFunctionStart; + + property OnFunctionEnd: TPSOnFunction read FOnFunctionEnd write FOnFunctionEnd; + + property IsUnit: Boolean read FIsUnit; + + property AllowNoBegin: Boolean read FAllowNoBegin write FAllowNoBegin; + + property AllowUnit: Boolean read FAllowUnit write FAllowUnit; + + property AllowNoEnd: Boolean read FAllowNoEnd write FAllowNoEnd; + + + property BooleanShortCircuit: Boolean read FBooleanShortCircuit write FBooleanShortCircuit; + + property UTF8Decode: Boolean read FUtf8Decode write FUtf8Decode; + + property UnitName: tbtString read FUnitName; + end; + TIFPSPascalCompiler = TPSPascalCompiler; + + TPSValue = class(TObject) + private + FPos, FRow, FCol: Cardinal; + public + + property Pos: Cardinal read FPos write FPos; + + property Row: Cardinal read FRow write FRow; + + property Col: Cardinal read FCol write FCol; + + procedure SetParserPos(P: TPSPascalParser); + + end; + + TPSParameter = class(TObject) + private + FValue: TPSValue; + FTempVar: TPSValue; + FParamMode: TPSParameterMode; + FExpectedType: TPSType; + public + + property Val: TPSValue read FValue write FValue; + + property ExpectedType: TPSType read FExpectedType write FExpectedType; + + property TempVar: TPSValue read FTempVar write FTempVar; + + property ParamMode: TPSParameterMode read FParamMode write FParamMode; + + destructor Destroy; override; + end; + + TPSParameters = class(TObject) + private + FItems: TPSList; + function GetCount: Cardinal; + function GetItem(I: Longint): TPSParameter; + public + + constructor Create; + + destructor Destroy; override; + + property Count: Cardinal read GetCount; + + property Item[I: Longint]: TPSParameter read GetItem; default; + + procedure Delete(I: Cardinal); + + function Add: TPSParameter; + end; + + TPSSubItem = class(TObject) + private + FType: TPSType; + public + + property aType: TPSType read FType write FType; + end; + + TPSSubNumber = class(TPSSubItem) + private + FSubNo: Cardinal; + public + + property SubNo: Cardinal read FSubNo write FSubNo; + end; + + TPSSubValue = class(TPSSubItem) + private + FSubNo: TPSValue; + public + + property SubNo: TPSValue read FSubNo write FSubNo; + + destructor Destroy; override; + end; + + TPSValueVar = class(TPSValue) + private + FRecItems: TPSList; + function GetRecCount: Cardinal; + function GetRecItem(I: Cardinal): TPSSubItem; + public + constructor Create; + destructor Destroy; override; + + function RecAdd(Val: TPSSubItem): Cardinal; + + procedure RecDelete(I: Cardinal); + + property RecItem[I: Cardinal]: TPSSubItem read GetRecItem; + + property RecCount: Cardinal read GetRecCount; + end; + + TPSValueGlobalVar = class(TPSValueVar) + private + FAddress: Cardinal; + public + + property GlobalVarNo: Cardinal read FAddress write FAddress; + end; + + + TPSValueLocalVar = class(TPSValueVar) + private + FLocalVarNo: Longint; + public + + property LocalVarNo: Longint read FLocalVarNo write FLocalVarNo; + end; + + TPSValueParamVar = class(TPSValueVar) + private + FParamNo: Longint; + public + + property ParamNo: Longint read FParamNo write FParamNo; + end; + + TPSValueAllocatedStackVar = class(TPSValueLocalVar) + private + FProc: TPSInternalProcedure; + public + + property Proc: TPSInternalProcedure read FProc write FProc; + destructor Destroy; override; + end; + + TPSValueData = class(TPSValue) + private + FData: PIfRVariant; + public + + property Data: PIfRVariant read FData write FData; + destructor Destroy; override; + end; + + TPSValueReplace = class(TPSValue) + private + FPreWriteAllocated: Boolean; + FFreeOldValue: Boolean; + FFreeNewValue: Boolean; + FOldValue: TPSValue; + FNewValue: TPSValue; + FReplaceTimes: Longint; + public + + property OldValue: TPSValue read FOldValue write FOldValue; + + property NewValue: TPSValue read FNewValue write FNewValue; + {Should it free the old value when destroyed?} + property FreeOldValue: Boolean read FFreeOldValue write FFreeOldValue; + property FreeNewValue: Boolean read FFreeNewValue write FFreeNewValue; + property PreWriteAllocated: Boolean read FPreWriteAllocated write FPreWriteAllocated; + + property ReplaceTimes: Longint read FReplaceTimes write FReplaceTimes; + + constructor Create; + destructor Destroy; override; + end; + + + TPSUnValueOp = class(TPSValue) + private + FVal1: TPSValue; + FOperator: TPSUnOperatorType; + FType: TPSType; + public + + property Val1: TPSValue read FVal1 write FVal1; + {The operator} + property Operator: TPSUnOperatorType read FOperator write FOperator; + + property aType: TPSType read FType write FType; + destructor Destroy; override; + end; + + TPSBinValueOp = class(TPSValue) + private + FVal1, + FVal2: TPSValue; + FOperator: TPSBinOperatorType; + FType: TPSType; + public + + property Val1: TPSValue read FVal1 write FVal1; + + property Val2: TPSValue read FVal2 write FVal2; + {The operator for this value} + property Operator: TPSBinOperatorType read FOperator write FOperator; + + property aType: TPSType read FType write FType; + + destructor Destroy; override; + end; + + TPSValueNil = class(TPSValue) + end; + + TPSValueProcPtr = class(TPSValue) + private + FProcNo: Cardinal; + public + + property ProcPtr: Cardinal read FProcNo write FProcNo; + end; + + TPSValueProc = class(TPSValue) + private + FSelfPtr: TPSValue; + FParameters: TPSParameters; + FResultType: TPSType; + public + property ResultType: TPSType read FResultType write FResultType; + + property SelfPtr: TPSValue read FSelfPtr write FSelfPtr; + + property Parameters: TPSParameters read FParameters write FParameters; + destructor Destroy; override; + end; + + TPSValueProcNo = class(TPSValueProc) + private + FProcNo: Cardinal; + public + + property ProcNo: Cardinal read FProcNo write FProcNo; + end; + + TPSValueProcVal = class(TPSValueProc) + private + FProcNo: TPSValue; + public + + property ProcNo: TPSValue read FProcNo write FProcNo; + + destructor Destroy; override; + end; + + TPSValueArray = class(TPSValue) + private + FItems: TPSList; + function GetCount: Cardinal; + function GetItem(I: Cardinal): TPSValue; + public + function Add(Item: TPSValue): Cardinal; + procedure Delete(I: Cardinal); + property Item[I: Cardinal]: TPSValue read GetItem; + property Count: Cardinal read GetCount; + + constructor Create; + destructor Destroy; override; + end; + + TPSDelphiClassItem = class; + + TPSPropType = (iptRW, iptR, iptW); + + TPSCompileTimeClass = class + private + FInheritsFrom: TPSCompileTimeClass; + FClass: TClass; + FClassName: tbtString; + FClassNameHash: Longint; + FClassItems: TPSList; + FDefaultProperty: Cardinal; + FIsAbstract: Boolean; + FCastProc, + FNilProc: Cardinal; + FType: TPSType; + + FOwner: TPSPascalCompiler; + function GetCount: Longint; + function GetItem(i: Longint): TPSDelphiClassItem; + public + + property aType: TPSType read FType; + + property Items[i: Longint]: TPSDelphiClassItem read GetItem; + + property Count: Longint read GetCount; + + property IsAbstract: Boolean read FIsAbstract write FIsAbstract; + + + property ClassInheritsFrom: TPSCompileTimeClass read FInheritsFrom write FInheritsFrom; + + function RegisterMethod(const Decl: tbtString): Boolean; + + procedure RegisterProperty(const PropertyName, PropertyType: tbtString; PropAC: TPSPropType); + + procedure RegisterPublishedProperties; + + function RegisterPublishedProperty(const Name: tbtString): Boolean; + + procedure SetDefaultPropery(const Name: tbtString); + + constructor Create(ClassName: tbtString; aOwner: TPSPascalCompiler; aType: TPSType); + + class function CreateC(FClass: TClass; aOwner: TPSPascalCompiler; aType: TPSType): TPSCompileTimeClass; + + + destructor Destroy; override; + + + function IsCompatibleWith(aType: TPSType): Boolean; + + function SetNil(var ProcNo: Cardinal): Boolean; + + function CastToType(IntoType: TPSType; var ProcNo: Cardinal): Boolean; + + + function Property_Find(const Name: tbtString; var Index: IPointer): Boolean; + + function Property_Get(Index: IPointer; var ProcNo: Cardinal): Boolean; + + function Property_Set(Index: IPointer; var ProcNo: Cardinal): Boolean; + + function Property_GetHeader(Index: IPointer; Dest: TPSParametersDecl): Boolean; + + + function Func_Find(const Name: tbtString; var Index: IPointer): Boolean; + + function Func_Call(Index: IPointer; var ProcNo: Cardinal): Boolean; + + + function ClassFunc_Find(const Name: tbtString; var Index: IPointer): Boolean; + + function ClassFunc_Call(Index: IPointer; var ProcNo: Cardinal): Boolean; + end; + + TPSDelphiClassItem = class(TObject) + private + FOwner: TPSCompileTimeClass; + FOrgName: tbtString; + FName: tbtString; + FNameHash: Longint; + FDecl: TPSParametersDecl; + procedure SetName(const s: tbtString); + public + + constructor Create(Owner: TPSCompileTimeClass); + + destructor Destroy; override; + + property Decl: TPSParametersDecl read FDecl; + + property Name: tbtString read FName; + + property OrgName: tbtString read FOrgName write SetName; + + property NameHash: Longint read FNameHash; + + property Owner: TPSCompileTimeClass read FOwner; + end; + + TPSDelphiClassItemMethod = class(TPSDelphiClassItem) + private + FMethodNo: Cardinal; + public + + property MethodNo: Cardinal read FMethodNo write FMethodNo; + end; + + TPSDelphiClassItemProperty = class(TPSDelphiClassItem) + private + FReadProcNo: Cardinal; + FWriteProcNo: Cardinal; + FAccessType: TPSPropType; + public + + property AccessType: TPSPropType read FAccessType write FAccessType; + + property ReadProcNo: Cardinal read FReadProcNo write FReadProcNo; + + property WriteProcNo: Cardinal read FWriteProcNo write FWriteProcNo; + end; + + + TPSDelphiClassItemConstructor = class(TPSDelphiClassItemMethod) + end; + +{$IFNDEF PS_NOINTERFACES} + + TPSInterface = class(TObject) + private + FOwner: TPSPascalCompiler; + FType: TPSType; + FInheritedFrom: TPSInterface; + FGuid: TGuid; + FCastProc, + FNilProc: Cardinal; + FItems: TPSList; + FName: tbtString; + FNameHash: Longint; + procedure SetInheritedFrom(p: TPSInterface); + public + + constructor Create(Owner: TPSPascalCompiler; InheritedFrom: TPSInterface; Guid: TGuid; const Name: tbtString; aType: TPSType); + + destructor Destroy; override; + + property aType: TPSType read FType; + + property InheritedFrom: TPSInterface read FInheritedFrom write SetInheritedFrom; + + property Guid: TGuid read FGuid write FGuid; + + property Name: tbtString read FName write FName; + + property NameHash: Longint read FNameHash; + + + function RegisterMethod(const Declaration: tbtString; const cc: TPSCallingConvention): Boolean; + + procedure RegisterDummyMethod; + + function IsCompatibleWith(aType: TPSType): Boolean; + + function SetNil(var ProcNo: Cardinal): Boolean; + + function CastToType(IntoType: TPSType; var ProcNo: Cardinal): Boolean; + + function Func_Find(const Name: tbtString; var Index: Cardinal): Boolean; + + function Func_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; + end; + + + TPSInterfaceMethod = class(TObject) + private + FName: tbtString; + FDecl: TPSParametersDecl; + FNameHash: Longint; + FCC: TPSCallingConvention; + FScriptProcNo: Cardinal; + FOrgName: tbtString; + FOwner: TPSInterface; + FOffsetCache: Cardinal; + function GetAbsoluteProcOffset: Cardinal; + public + + property AbsoluteProcOffset: Cardinal read GetAbsoluteProcOffset; + + property ScriptProcNo: Cardinal read FScriptProcNo; + + property OrgName: tbtString read FOrgName; + + property Name: tbtString read FName; + + property NameHash: Longint read FNameHash; + + property Decl: TPSParametersDecl read FDecl; + + property CC: TPSCallingConvention read FCC; + + + constructor Create(Owner: TPSInterface); + + destructor Destroy; override; + end; +{$ENDIF} + + + TPSExternalClass = class(TObject) + protected + + SE: TPSPascalCompiler; + + FTypeNo: TPSType; + public + + function SelfType: TPSType; virtual; + + constructor Create(Se: TPSPascalCompiler; TypeNo: TPSType); + + function ClassFunc_Find(const Name: tbtString; var Index: Cardinal): Boolean; virtual; + + function ClassFunc_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; virtual; + + function Func_Find(const Name: tbtString; var Index: Cardinal): Boolean; virtual; + + function Func_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; virtual; + + function IsCompatibleWith(Cl: TPSExternalClass): Boolean; virtual; + + function SetNil(var ProcNo: Cardinal): Boolean; virtual; + + function CastToType(IntoType: TPSType; var ProcNo: Cardinal): Boolean; virtual; + + function CompareClass(OtherTypeNo: TPSType; var ProcNo: Cardinal): Boolean; virtual; + end; + + +function ExportCheck(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure; + Types: array of TPSBaseType; Modes: array of TPSParameterMode): Boolean; + + +procedure SetVarExportName(P: TPSVar; const ExpName: tbtString); + +function AddImportedClassVariable(Sender: TPSPascalCompiler; const VarName, VarType: tbtString): Boolean; + +const + {Invalid value, this is returned by most functions of pascal script that return a cardinal, when they fail} + InvalidVal = Cardinal(-1); + +type + TIFPSCompileTimeClass = TPSCompileTimeClass; + TIFPSInternalProcedure = TPSInternalProcedure; + TIFPSPascalCompilerError = TPSPascalCompilerError; + + TPMFuncType = (mftProc + , mftConstructor + ); + + +function PS_mi2s(i: Cardinal): tbtString; + +function ParseMethod(Owner: TPSPascalCompiler; const FClassName: tbtString; Decl: tbtString; var OrgName: tbtString; DestDecl: TPSParametersDecl; var Func: TPMFuncType): Boolean; + +function DeclToBits(const Decl: TPSParametersDecl): tbtString; + +function NewVariant(FType: TPSType): PIfRVariant; +procedure DisposeVariant(p: PIfRVariant); + +implementation + +uses Classes, typInfo; + +{$IFDEF DELPHI3UP} +resourceString +{$ELSE} +const +{$ENDIF} + + RPS_OnUseEventOnly = 'This function can only be called from within the OnUses event'; + RPS_UnableToRegisterFunction = 'Unable to register function %s'; + RPS_UnableToRegisterConst = 'Unable to register constant %s'; + RPS_InvalidTypeForVar = 'Invalid type for variable %s'; + RPS_InvalidType = 'Invalid Type'; + RPS_UnableToRegisterType = 'Unable to register type %s'; + RPS_UnknownInterface = 'Unknown interface: %s'; + RPS_ConstantValueMismatch = 'Constant Value Type Mismatch'; + RPS_ConstantValueNotAssigned = 'Constant Value is not assigned'; + + RPS_Error = 'Error'; + RPS_UnknownIdentifier = 'Unknown identifier ''%s'''; + RPS_IdentifierExpected = 'Identifier expected'; + RPS_CommentError = 'Comment error'; + RPS_StringError = 'String error'; + RPS_CharError = 'Char error'; + RPS_SyntaxError = 'Syntax error'; + RPS_EOF = 'Unexpected end of file'; + RPS_SemiColonExpected = 'Semicolon ('';'') expected'; + RPS_BeginExpected = '''BEGIN'' expected'; + RPS_PeriodExpected = 'period (''.'') expected'; + RPS_DuplicateIdent = 'Duplicate identifier ''%s'''; + RPS_ColonExpected = 'colon ('':'') expected'; + RPS_UnknownType = 'Unknown type ''%s'''; + RPS_CloseRoundExpected = 'Closing parenthesis expected'; + RPS_TypeMismatch = 'Type mismatch'; + RPS_InternalError = 'Internal error (%s)'; + RPS_AssignmentExpected = 'Assignment expected'; + RPS_ThenExpected = '''THEN'' expected'; + RPS_DoExpected = '''DO'' expected'; + RPS_NoResult = 'No result'; + RPS_OpenRoundExpected = 'opening parenthesis (''('')expected'; + RPS_CommaExpected = 'comma ('','') expected'; + RPS_ToExpected = '''TO'' expected'; + RPS_IsExpected = 'is (''='') expected'; + RPS_OfExpected = '''OF'' expected'; + RPS_CloseBlockExpected = 'Closing square bracket ('']'') expected'; + RPS_VariableExpected = 'Variable Expected'; + RPS_StringExpected = 'String Expected'; + RPS_EndExpected = '''END'' expected'; + RPS_UnSetLabel = 'Label ''%s'' not set'; + RPS_NotInLoop = 'Not in a loop'; + RPS_InvalidJump = 'Invalid jump'; + RPS_OpenBlockExpected = 'Opening square brackets (''['') expected'; + RPS_WriteOnlyProperty = 'Write-only property'; + RPS_ReadOnlyProperty = 'Read-only property'; + RPS_ClassTypeExpected = 'Class type expected'; + RPS_DivideByZero = 'Divide by Zero'; + RPS_MathError = 'Math Error'; + RPS_UnsatisfiedForward = 'Unsatisfied Forward %s'; + RPS_ForwardParameterMismatch = 'Forward Parameter Mismatch'; + RPS_InvalidNumberOfParameter = 'Invalid number of parameters'; + RPS_UnknownError = 'Unknown error'; + {$IFDEF PS_USESSUPPORT} + RPS_NotAllowed = '%s is not allowed at this position'; + RPS_UnitNotFound = 'Unit ''%s'' not found or contains errors'; + {$ENDIF} + + + RPS_Hint = 'Hint'; + RPS_VariableNotUsed = 'Variable ''%s'' never used'; + RPS_FunctionNotUsed = 'Function ''%s'' never used'; + RPS_UnknownHint = 'Unknown hint'; + + + RPS_Warning = 'Warning'; + RPS_CalculationAlwaysEvaluatesTo = 'Calculation always evaluates to %s'; + RPS_IsNotNeeded = '%s is not needed'; + RPS_AbstractClass = 'Abstract Class Construction'; + RPS_UnknownWarning = 'Unknown warning'; + + + {$IFDEF DEBUG } + RPS_UnableToRegister = 'Unable to register %s'; + {$ENDIF} + + RPS_NotArrayProperty = 'Not an array property'; + RPS_NotProperty = 'Not a property'; + RPS_UnknownProperty = 'Unknown Property'; + +function DeclToBits(const Decl: TPSParametersDecl): tbtString; +var + i: longint; +begin + Result := ''; + if Decl.Result = nil then + begin + Result := Result + #0; + end else + Result := Result + #1; + for i := 0 to Decl.ParamCount -1 do + begin + if Decl.Params[i].Mode <> pmIn then + Result := Result + #1 + else + Result := Result + #0; + end; +end; + + +procedure BlockWriteByte(BlockInfo: TPSBlockInfo; b: Byte); +begin + BlockInfo.Proc.Data := BlockInfo.Proc.Data + tbtChar(b); +end; + +procedure BlockWriteData(BlockInfo: TPSBlockInfo; const Data; Len: Longint); +begin + SetLength(BlockInfo.Proc.FData, Length(BlockInfo.Proc.FData) + Len); + Move(Data, BlockInfo.Proc.FData[Length(BlockInfo.Proc.FData) - Len + 1], Len); +end; + +procedure BlockWriteLong(BlockInfo: TPSBlockInfo; l: Cardinal); +begin + BlockWriteData(BlockInfo, l, 4); +end; + +procedure BlockWriteVariant(BlockInfo: TPSBlockInfo; p: PIfRVariant); +var + du8: tbtu8; + du16: tbtu16; +begin + BlockWriteLong(BlockInfo, p^.FType.FinalTypeNo); + case p.FType.BaseType of + btType: BlockWriteData(BlockInfo, p^.ttype.FinalTypeno, 4); + {$IFNDEF PS_NOWIDESTRING} + btWideString: + begin + BlockWriteLong(BlockInfo, Length(tbtWideString(p^.twidestring))); + BlockWriteData(BlockInfo, tbtwidestring(p^.twidestring)[1], 2*Length(tbtWideString(p^.twidestring))); + end; + btUnicodeString: + begin + BlockWriteLong(BlockInfo, Length(tbtUnicodeString(p^.twidestring))); + BlockWriteData(BlockInfo, tbtUnicodeString(p^.twidestring)[1], 2*Length(tbtUnicodeString(p^.twidestring))); + end; + btWideChar: BlockWriteData(BlockInfo, p^.twidechar, 2); + {$ENDIF} + btSingle: BlockWriteData(BlockInfo, p^.tsingle, sizeof(tbtSingle)); + btDouble: BlockWriteData(BlockInfo, p^.tdouble, sizeof(tbtDouble)); + btExtended: BlockWriteData(BlockInfo, p^.textended, sizeof(tbtExtended)); + btCurrency: BlockWriteData(BlockInfo, p^.tcurrency, sizeof(tbtCurrency)); + btChar: BlockWriteData(BlockInfo, p^.tchar, 1); + btSet: + begin + BlockWriteData(BlockInfo, tbtString(p^.tstring)[1], Length(tbtString(p^.tstring))); + end; + btString: + begin + BlockWriteLong(BlockInfo, Length(tbtString(p^.tstring))); + BlockWriteData(BlockInfo, tbtString(p^.tstring)[1], Length(tbtString(p^.tstring))); + end; + btenum: + begin + if TPSEnumType(p^.FType).HighValue <=256 then + begin + du8 := tbtu8(p^.tu32); + BlockWriteData(BlockInfo, du8, 1) + end + else if TPSEnumType(p^.FType).HighValue <=65536 then + begin + du16 := tbtu16(p^.tu32); + BlockWriteData(BlockInfo, du16, 2) + end; + end; + + bts8,btu8: BlockWriteData(BlockInfo, p^.tu8, 1); + bts16,btu16: BlockWriteData(BlockInfo, p^.tu16, 2); + bts32,btu32: BlockWriteData(BlockInfo, p^.tu32, 4); + {$IFNDEF PS_NOINT64} + bts64: BlockWriteData(BlockInfo, p^.ts64, 8); + {$ENDIF} + btProcPtr: BlockWriteData(BlockInfo, p^.tu32, 4); + {$IFDEF DEBUG} + {$IFNDEF FPC} + else + asm int 3; end; + {$ENDIF} + {$ENDIF} + end; +end; + + + +function ExportCheck(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure; Types: array of TPSBaseType; Modes: array of TPSParameterMode): Boolean; +var + i: Longint; + ttype: TPSType; +begin + if High(Types) <> High(Modes)+1 then + begin + Result := False; + exit; + end; + if High(Types) <> Proc.Decl.ParamCount then + begin + Result := False; + exit; + end; + TType := Proc.Decl.Result; + if TType = nil then + begin + if Types[0] <> btReturnAddress then + begin + Result := False; + exit; + end; + end else + begin + if TType.BaseType <> Types[0] then + begin + Result := False; + exit; + end; + end; + for i := 0 to High(Modes) do + begin + TType := Proc.Decl.Params[i].aType; + if Modes[i] <> Proc.Decl.Params[i].Mode then + begin + Result := False; + exit; + end; + if TType.BaseType <> Types[i+1] then + begin + Result := False; + exit; + end; + end; + Result := True; +end; + +procedure SetVarExportName(P: TPSVar; const ExpName: tbtString); +begin + if p <> nil then + p.exportname := ExpName; +end; + +function FindAndAddType(Owner: TPSPascalCompiler; const Name, Decl: tbtString): TPSType; +var + tt: TPSType; +begin + Result := Owner.FindType(Name); + if Result = nil then + begin + tt := Owner.AddTypeS(Name, Decl); + tt.ExportName := True; + Result := tt; + end; +end; + + +function ParseMethod(Owner: TPSPascalCompiler; const FClassName: tbtString; Decl: tbtString; var OrgName: tbtString; DestDecl: TPSParametersDecl; var Func: TPMFuncType): Boolean; +var + Parser: TPSPascalParser; + FuncType: Byte; + VNames: tbtString; + modifier: TPSParameterMode; + VCType: TPSType; + ERow, EPos, ECol: Integer; + +begin + Parser := TPSPascalParser.Create; + Parser.SetText(Decl); + if Parser.CurrTokenId = CSTII_Function then + FuncType:= 0 + else if Parser.CurrTokenId = CSTII_Procedure then + FuncType := 1 + else if (Parser.CurrTokenId = CSTII_Constructor) and (FClassName <> '') then + FuncType := 2 + else + begin + Parser.Free; + Result := False; + exit; + end; + Parser.Next; + if Parser.CurrTokenId <> CSTI_Identifier then + begin + Parser.Free; + Result := False; + exit; + end; {if} + OrgName := Parser.OriginalToken; + Parser.Next; + if Parser.CurrTokenId = CSTI_OpenRound then + begin + Parser.Next; + if Parser.CurrTokenId <> CSTI_CloseRound then + begin + while True do + begin + if Parser.CurrTokenId = CSTII_Const then + begin + modifier := pmIn; + Parser.Next; + end + else + if Parser.CurrTokenId = CSTII_Var then + begin + modifier := pmInOut; + Parser.Next; + end + else + if Parser.CurrTokenId = CSTII_Out then + begin + modifier := pmOut; + Parser.Next; + end + else + modifier := pmIn; + if Parser.CurrTokenId <> CSTI_Identifier then + begin + Parser.Free; + Result := False; + exit; + end; + EPos:=Parser.CurrTokenPos; + ERow:=Parser.Row; + ECol:=Parser.Col; + + VNames := Parser.OriginalToken + '|'; + Parser.Next; + while Parser.CurrTokenId = CSTI_Comma do + begin + Parser.Next; + if Parser.CurrTokenId <> CSTI_Identifier then + begin + Parser.Free; + Result := False; + exit; + end; + VNames := VNames + Parser.OriginalToken + '|'; + Parser.Next; + end; + if Parser.CurrTokenId <> CSTI_Colon then + begin + Parser.Free; + Result := False; + exit; + end; + Parser.Next; + if Parser.CurrTokenID = CSTII_Array then + begin + Parser.nExt; + if Parser.CurrTokenId <> CSTII_Of then + begin + Parser.Free; + Result := False; + exit; + end; + Parser.Next; + if Parser.CurrTokenId = CSTII_Const then + begin + VCType := FindAndAddType(Owner, '!OPENARRAYOFCONST', 'array of ___Pointer') + end + else begin + VCType := Owner.GetTypeCopyLink(Owner.FindType(Parser.GetToken)); + if VCType = nil then + begin + Parser.Free; + Result := False; + exit; + end; + case VCType.BaseType of + btU8: VCType := FindAndAddType(Owner, '!OPENARRAYOFU8', 'array of byte'); + btS8: VCType := FindAndAddType(Owner, '!OPENARRAYOFS8', 'array of ShortInt'); + btU16: VCType := FindAndAddType(Owner, '!OPENARRAYOFU16', 'array of SmallInt'); + btS16: VCType := FindAndAddType(Owner, '!OPENARRAYOFS16', 'array of Word'); + btU32: VCType := FindAndAddType(Owner, '!OPENARRAYOFU32', 'array of Cardinal'); + btS32: VCType := FindAndAddType(Owner, '!OPENARRAYOFS32', 'array of Longint'); + btSingle: VCType := FindAndAddType(Owner, '!OPENARRAYOFSINGLE', 'array of Single'); + btDouble: VCType := FindAndAddType(Owner, '!OPENARRAYOFDOUBLE', 'array of Double'); + btExtended: VCType := FindAndAddType(Owner, '!OPENARRAYOFEXTENDED', 'array of Extended'); + btString: VCType := FindAndAddType(Owner, '!OPENARRAYOFSTRING', 'array of String'); + btPChar: VCType := FindAndAddType(Owner, '!OPENARRAYOFPCHAR', {$IFDEF PS_PANSICHAR}'array of PAnsiChar'{$ELSE}'array of PChar'{$ENDIF}); + btNotificationVariant, btVariant: VCType := FindAndAddType(Owner, '!OPENARRAYOFVARIANT', 'array of variant'); + {$IFNDEF PS_NOINT64}btS64: VCType := FindAndAddType(Owner, '!OPENARRAYOFS64', 'array of Int64');{$ENDIF} + btChar: VCType := FindAndAddType(Owner, '!OPENARRAYOFCHAR', 'array of Char'); + {$IFNDEF PS_NOWIDESTRING} + btWideString: VCType := FindAndAddType(Owner, '!OPENARRAYOFWIDESTRING', 'array of WideString'); + btUnicodeString: VCType := FindAndAddType(Owner, '!OPENARRAYOFUNICODESTRING', 'array of UnicodeString'); + btWideChar: VCType := FindAndAddType(Owner, '!OPENARRAYOFWIDECHAR', 'array of WideChar'); + {$ENDIF} + btClass: VCType := FindAndAddType(Owner, '!OPENARRAYOFTOBJECT', 'array of TObject'); + btRecord: VCType := FindAndAddType(Owner, '!OPENARRAYOFRECORD_'+FastUpperCase(Parser.OriginalToken), 'array of ' +FastUpperCase(Parser.OriginalToken)); + else + begin + Parser.Free; + Result := False; + exit; + end; + end; + end; + end else if Parser.CurrTokenID = CSTII_Const then + VCType := nil // any type + else begin + VCType := Owner.FindType(Parser.GetToken); + if VCType = nil then + begin + Parser.Free; + Result := False; + exit; + end; + end; + while Pos(tbtchar('|'), VNames) > 0 do + begin + with DestDecl.AddParam do + begin + {$IFDEF PS_USESSUPPORT} + DeclareUnit:=Owner.fModule; + {$ENDIF} + DeclarePos := EPos; + DeclareRow := ERow; + DeclareCol := ECol; + Mode := modifier; + OrgName := copy(VNames, 1, Pos(tbtchar('|'), VNames) - 1); + aType := VCType; + end; + Delete(VNames, 1, Pos(tbtchar('|'), VNames)); + end; + Parser.Next; + if Parser.CurrTokenId = CSTI_CloseRound then + break; + if Parser.CurrTokenId <> CSTI_Semicolon then + begin + Parser.Free; + Result := False; + exit; + end; + Parser.Next; + end; {while} + end; {if} + Parser.Next; + end; {if} + if FuncType = 0 then + begin + if Parser.CurrTokenId <> CSTI_Colon then + begin + Parser.Free; + Result := False; + exit; + end; + + Parser.Next; + VCType := Owner.FindType(Parser.GetToken); + if VCType = nil then + begin + Parser.Free; + Result := False; + exit; + end; + end + else if FuncType = 2 then {constructor} + begin + VCType := Owner.FindType(FClassName) + end else + VCType := nil; + DestDecl.Result := VCType; + Parser.Free; + if FuncType = 2 then + Func := mftConstructor + else + Func := mftProc; + Result := True; +end; + + + +function TPSPascalCompiler.FindProc(const aName: tbtString): Cardinal; +var + l, h: Longint; + x: TPSProcedure; + xr: TPSRegProc; + name: tbtString; + +begin + name := FastUpperCase(aName); + h := MakeHash(Name); + if FProcs = nil then + begin + result := InvalidVal; + Exit; + end; + + for l := FProcs.Count - 1 downto 0 do + begin + x := FProcs.Data^[l]; + if x.ClassType = TPSInternalProcedure then + begin + if (TPSInternalProcedure(x).NameHash = h) and + (TPSInternalProcedure(x).Name = Name) then + begin + Result := l; + exit; + end; + end + else + begin + if (TPSExternalProcedure(x).RegProc.NameHash = h) and + (TPSExternalProcedure(x).RegProc.Name = Name) then + begin + Result := l; + exit; + end; + end; + end; + for l := FRegProcs.Count - 1 downto 0 do + begin + xr := FRegProcs[l]; + if (xr.NameHash = h) and (xr.Name = Name) then + begin + x := TPSExternalProcedure.Create; + TPSExternalProcedure(x).RegProc := xr; + FProcs.Add(x); + Result := FProcs.Count - 1; + exit; + end; + end; + Result := InvalidVal; +end; {findfunc} + +function TPSPascalCompiler.UseExternalProc(const Name: tbtString): TPSParametersDecl; +var + ProcNo: cardinal; + proc: TPSProcedure; +begin + ProcNo := FindProc(FastUppercase(Name)); + if ProcNo = InvalidVal then Result := nil + else + begin + proc := TPSProcedure(FProcs[ProcNo]); + if Proc is TPSExternalProcedure then + begin + Result := TPSExternalProcedure(Proc).RegProc.Decl; + end else result := nil; + end; +end; + + + +function TPSPascalCompiler.FindBaseType(BaseType: TPSBaseType): TPSType; +var + l: Longint; + x: TPSType; +begin + for l := 0 to FTypes.Count -1 do + begin + X := FTypes[l]; + if (x.BaseType = BaseType) and (x.ClassType = TPSType) then + begin + Result := at2ut(x); + exit; + end; + end; + X := TPSType.Create; + x.Name := ''; + x.BaseType := BaseType; + {$IFDEF PS_USESSUPPORT} + x.DeclareUnit:=fModule; + {$ENDIF} + x.DeclarePos := InvalidVal; + x.DeclareCol := 0; + x.DeclareRow := 0; + FTypes.Add(x); + Result := at2ut(x); +end; + +function TPSPascalCompiler.MakeDecl(decl: TPSParametersDecl): tbtString; +var + i: Longint; +begin + if Decl.Result = nil then result := '0' else + result := Decl.Result.Name; + + for i := 0 to decl.ParamCount -1 do + begin + if decl.GetParam(i).Mode = pmIn then + Result := Result + ' @' + else + Result := Result + ' !'; + Result := Result + decl.GetParam(i).aType.Name; + end; +end; + + +{ TPSPascalCompiler } + +const + BtTypeCopy = 255; + + +type + TFuncType = (ftProc, ftFunc); + +function PS_mi2s(i: Cardinal): tbtString; +begin + SetLength(Result, 4); + Cardinal((@Result[1])^) := i; +end; + + + + +function TPSPascalCompiler.AddType(const Name: tbtString; const BaseType: TPSBaseType): TPSType; +begin + if FProcs = nil then + begin + raise EPSCompilerException.Create(RPS_OnUseEventOnly); + end; + + case BaseType of + btProcPtr: Result := TPSProceduralType.Create; + BtTypeCopy: Result := TPSTypeLink.Create; + btRecord: Result := TPSRecordType.Create; + btArray: Result := TPSArrayType.Create; + btStaticArray: Result := TPSStaticArrayType.Create; + btEnum: Result := TPSEnumType.Create; + btClass: Result := TPSClassType.Create; + btExtClass: REsult := TPSUndefinedClassType.Create; + btNotificationVariant, btVariant: Result := TPSVariantType.Create; +{$IFNDEF PS_NOINTERFACES} + btInterface: Result := TPSInterfaceType.Create; +{$ENDIF} + else + Result := TPSType.Create; + end; + Result.Name := FastUppercase(Name); + Result.OriginalName := Name; + Result.BaseType := BaseType; + {$IFDEF PS_USESSUPPORT} + Result.DeclareUnit:=fModule; + {$ENDIF} + Result.DeclarePos := InvalidVal; + Result.DeclareCol := 0; + Result.DeclareRow := 0; + FTypes.Add(Result); +end; + + +function TPSPascalCompiler.AddFunction(const Header: tbtString): TPSRegProc; +var + Parser: TPSPascalParser; + i: Integer; + IsFunction: Boolean; + VNames, Name: tbtString; + Decl: TPSParametersDecl; + modifier: TPSParameterMode; + VCType: TPSType; + x: TPSRegProc; +begin + if FProcs = nil then + raise EPSCompilerException.Create(RPS_OnUseEventOnly); + + Parser := TPSPascalParser.Create; + Parser.SetText(Header); + Decl := TPSParametersDecl.Create; + x := nil; + try + if Parser.CurrTokenId = CSTII_Function then + IsFunction := True + else if Parser.CurrTokenId = CSTII_Procedure then + IsFunction := False + else + Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, ['']); + Parser.Next; + if Parser.CurrTokenId <> CSTI_Identifier then + Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, ['']); + Name := Parser.OriginalToken; + Parser.Next; + if Parser.CurrTokenId = CSTI_OpenRound then + begin + Parser.Next; + if Parser.CurrTokenId <> CSTI_CloseRound then + begin + while True do + begin + if Parser.CurrTokenId = CSTII_Out then + begin + Modifier := pmOut; + Parser.Next; + end else + if Parser.CurrTokenId = CSTII_Const then + begin + Modifier := pmIn; + Parser.Next; + end else + if Parser.CurrTokenId = CSTII_Var then + begin + modifier := pmInOut; + Parser.Next; + end + else + modifier := pmIn; + if Parser.CurrTokenId <> CSTI_Identifier then + raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]); + VNames := Parser.OriginalToken + '|'; + Parser.Next; + while Parser.CurrTokenId = CSTI_Comma do + begin + Parser.Next; + if Parser.CurrTokenId <> CSTI_Identifier then + Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]); + VNames := VNames + Parser.OriginalToken + '|'; + Parser.Next; + end; + if Parser.CurrTokenId <> CSTI_Colon then + begin + Parser.Free; + Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]); + end; + Parser.Next; + VCType := FindType(Parser.GetToken); + if VCType = nil then + Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]); + while Pos(tbtchar('|'), VNames) > 0 do + begin + with Decl.AddParam do + begin + Mode := modifier; + OrgName := copy(VNames, 1, Pos(tbtchar('|'), VNames) - 1); + aType := VCType; + end; + Delete(VNames, 1, Pos(tbtchar('|'), VNames)); + end; + Parser.Next; + if Parser.CurrTokenId = CSTI_CloseRound then + break; + if Parser.CurrTokenId <> CSTI_Semicolon then + Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]); + Parser.Next; + end; {while} + end; {if} + Parser.Next; + end; {if} + if IsFunction then + begin + if Parser.CurrTokenId <> CSTI_Colon then + Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]); + + Parser.Next; + VCType := FindType(Parser.GetToken); + if VCType = nil then + Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]); + end + else + VCType := nil; + Decl.Result := VCType; + X := TPSRegProc.Create; + x.OrgName := Name; + x.Name := FastUpperCase(Name); + x.ExportName := True; + x.Decl.Assign(decl); + if Decl.Result = nil then + begin + x.ImportDecl := x.ImportDecl + #0; + end else + x.ImportDecl := x.ImportDecl + #1; + for i := 0 to Decl.ParamCount -1 do + begin + if Decl.Params[i].Mode <> pmIn then + x.ImportDecl := x.ImportDecl + #1 + else + x.ImportDecl := x.ImportDecl + #0; + end; + + FRegProcs.Add(x); + finally + Decl.Free; + Parser.Free; + end; + Result := x; +end; + +function TPSPascalCompiler.MakeHint(const Module: tbtString; E: TPSPascalCompilerHintType; const Param: tbtString): TPSPascalCompilerMessage; +var + n: TPSPascalCompilerHint; +begin + N := TPSPascalCompilerHint.Create; + n.FHint := e; + n.SetParserPos(FParser); + n.FModuleName := Module; + n.FParam := Param; + FMessages.Add(n); + Result := n; +end; + +function TPSPascalCompiler.MakeError(const Module: tbtString; E: + TPSPascalCompilerErrorType; const Param: tbtString): TPSPascalCompilerMessage; +var + n: TPSPascalCompilerError; +begin + N := TPSPascalCompilerError.Create; + n.FError := e; + n.SetParserPos(FParser); + {$IFNDEF PS_USESSUPPORT} + n.FModuleName := Module; + {$ELSE} + if Module <> '' then + n.FModuleName := Module + else + n.FModuleName := fModule; + {$ENDIF} + n.FParam := Param; + FMessages.Add(n); + Result := n; +end; + +function TPSPascalCompiler.MakeWarning(const Module: tbtString; E: + TPSPascalCompilerWarningType; const Param: tbtString): TPSPascalCompilerMessage; +var + n: TPSPascalCompilerWarning; +begin + N := TPSPascalCompilerWarning.Create; + n.FWarning := e; + n.SetParserPos(FParser); + n.FModuleName := Module; + n.FParam := Param; + FMessages.Add(n); + Result := n; +end; + +procedure TPSPascalCompiler.Clear; +var + l: Longint; +begin + FDebugOutput := ''; + FOutput := ''; + for l := 0 to FMessages.Count - 1 do + TPSPascalCompilerMessage(FMessages[l]).Free; + FMessages.Clear; + for L := FAutoFreeList.Count -1 downto 0 do + begin + TObject(FAutoFreeList[l]).Free; + end; + FAutoFreeList.Clear; +end; + +procedure CopyVariantContents(Src, Dest: PIfRVariant); +begin + case src.FType.BaseType of + btu8, bts8: dest^.tu8 := src^.tu8; + btu16, bts16: dest^.tu16 := src^.tu16; + btenum, btu32, bts32: dest^.tu32 := src^.tu32; + btsingle: Dest^.tsingle := src^.tsingle; + btdouble: Dest^.tdouble := src^.tdouble; + btextended: Dest^.textended := src^.textended; + btCurrency: Dest^.tcurrency := Src^.tcurrency; + btchar: Dest^.tchar := src^.tchar; + {$IFNDEF PS_NOINT64}bts64: dest^.ts64 := src^.ts64;{$ENDIF} + btset, btstring: tbtstring(dest^.tstring) := tbtstring(src^.tstring); + {$IFNDEF PS_NOWIDESTRING} + btunicodestring: tbtunicodestring(dest^.tunistring) := tbtunicodestring(src^.tunistring); + btwidestring: tbtwidestring(dest^.twidestring) := tbtwidestring(src^.twidestring); + btwidechar: Dest^.tchar := src^.tchar; + {$ENDIF} + end; +end; + +function DuplicateVariant(Src: PIfRVariant): PIfRVariant; +begin + New(Result); + FillChar(Result^, SizeOf(TIfRVariant), 0); + CopyVariantContents(Src, Result); +end; + + +procedure InitializeVariant(Vari: PIfRVariant; FType: TPSType); +begin + FillChar(vari^, SizeOf(TIfRVariant), 0); + if FType.BaseType = btSet then + begin + SetLength(tbtstring(vari^.tstring), TPSSetType(FType).ByteSize); + fillchar(tbtstring(vari^.tstring)[1], length(tbtstring(vari^.tstring)), 0); + end; + vari^.FType := FType; +end; + +function NewVariant(FType: TPSType): PIfRVariant; +begin + New(Result); + InitializeVariant(Result, FType); +end; + +procedure FinalizeA(var s: tbtString); overload; begin s := ''; end; +procedure FinalizeW(var s: tbtwidestring); overload; begin s := ''; end; +procedure FinalizeU(var s: tbtunicodestring); overload; begin s := ''; end; + +procedure FinalizeVariant(var p: TIfRVariant); +begin + if (p.FType.BaseType = btString) or (p.FType.basetype = btSet) then + finalizeA(tbtstring(p.tstring)) + {$IFNDEF PS_NOWIDESTRING} + else if p.FType.BaseType = btWideString then + finalizeW(tbtWideString(p.twidestring)) // tbtwidestring + else if p.FType.BaseType = btUnicodeString then + finalizeU(tbtUnicodeString(p.tunistring)); // tbtwidestring + {$ENDIF} +end; + +procedure DisposeVariant(p: PIfRVariant); +begin + if p <> nil then + begin + FinalizeVariant(p^); + Dispose(p); + end; +end; + + + +function TPSPascalCompiler.GetTypeCopyLink(p: TPSType): TPSType; +begin + if p = nil then + Result := nil + else + if p.BaseType = BtTypeCopy then + begin + Result := TPSTypeLink(p).LinkTypeNo; + end else Result := p; +end; + +function IsIntType(b: TPSBaseType): Boolean; +begin + case b of + btU8, btS8, btU16, btS16, btU32, btS32{$IFNDEF PS_NOINT64}, btS64{$ENDIF}: Result := True; + else + Result := False; + end; +end; + +function IsRealType(b: TPSBaseType): Boolean; +begin + case b of + btSingle, btDouble, btCurrency, btExtended: Result := True; + else + Result := False; + end; +end; + +function IsIntRealType(b: TPSBaseType): Boolean; +begin + case b of + btSingle, btDouble, btCurrency, btExtended, btU8, btS8, btU16, btS16, btU32, btS32{$IFNDEF PS_NOINT64}, btS64{$ENDIF}: + Result := True; + else + Result := False; + end; + +end; + +function DiffRec(p1, p2: TPSSubItem): Boolean; +begin + if p1.ClassType = p2.ClassType then + begin + if P1.ClassType = TPSSubNumber then + Result := TPSSubNumber(p1).SubNo <> TPSSubNumber(p2).SubNo + else if P1.ClassType = TPSSubValue then + Result := TPSSubValue(p1).SubNo <> TPSSubValue(p2).SubNo + else + Result := False; + end else Result := True; +end; + +function SameReg(x1, x2: TPSValue): Boolean; +var + I: Longint; +begin + if (x1.ClassType = x2.ClassType) and (X1 is TPSValueVar) then + begin + if + ((x1.ClassType = TPSValueGlobalVar) and (TPSValueGlobalVar(x1).GlobalVarNo = TPSValueGlobalVar(x2).GlobalVarNo)) or + ((x1.ClassType = TPSValueLocalVar) and (TPSValueLocalVar(x1).LocalVarNo = TPSValueLocalVar(x2).LocalVarNo)) or + ((x1.ClassType = TPSValueParamVar) and (TPSValueParamVar(x1).ParamNo = TPSValueParamVar(x2).ParamNo)) or + ((x1.ClassType = TPSValueAllocatedStackVar) and (TPSValueAllocatedStackVar(x1).LocalVarNo = TPSValueAllocatedStackVar(x2).LocalVarNo)) then + begin + if TPSValueVar(x1).GetRecCount <> TPSValueVar(x2).GetRecCount then + begin + Result := False; + exit; + end; + for i := 0 to TPSValueVar(x1).GetRecCount -1 do + begin + if DiffRec(TPSValueVar(x1).RecItem[i], TPSValueVar(x2).RecItem[i]) then + begin + Result := False; + exit; + end; + end; + Result := True; + end else Result := False; + end + else + Result := False; +end; + +function GetUInt(Src: PIfRVariant; var s: Boolean): Cardinal; +begin + case Src.FType.BaseType of + btU8: Result := Src^.tu8; + btS8: Result := Src^.ts8; + btU16: Result := Src^.tu16; + btS16: Result := Src^.ts16; + btU32: Result := Src^.tu32; + btS32: Result := Src^.ts32; + {$IFNDEF PS_NOINT64} + bts64: Result := src^.ts64; + {$ENDIF} + btChar: Result := ord(Src^.tchar); + {$IFNDEF PS_NOWIDESTRING} + btWideChar: Result := ord(tbtwidechar(src^.twidechar)); + {$ENDIF} + btEnum: Result := src^.tu32; + else + begin + s := False; + Result := 0; + end; + end; +end; + +function GetInt(Src: PIfRVariant; var s: Boolean): Longint; +begin + case Src.FType.BaseType of + btU8: Result := Src^.tu8; + btS8: Result := Src^.ts8; + btU16: Result := Src^.tu16; + btS16: Result := Src^.ts16; + btU32: Result := Src^.tu32; + btS32: Result := Src^.ts32; + {$IFNDEF PS_NOINT64} + bts64: Result := src^.ts64; + {$ENDIF} + btChar: Result := ord(Src^.tchar); + {$IFNDEF PS_NOWIDESTRING} + btWideChar: Result := ord(tbtwidechar(src^.twidechar)); + {$ENDIF} + btEnum: Result := src^.tu32; + else + begin + s := False; + Result := 0; + end; + end; +end; +{$IFNDEF PS_NOINT64} +function GetInt64(Src: PIfRVariant; var s: Boolean): Int64; +begin + case Src.FType.BaseType of + btU8: Result := Src^.tu8; + btS8: Result := Src^.ts8; + btU16: Result := Src^.tu16; + btS16: Result := Src^.ts16; + btU32: Result := Src^.tu32; + btS32: Result := Src^.ts32; + bts64: Result := src^.ts64; + btChar: Result := ord(Src^.tchar); + {$IFNDEF PS_NOWIDESTRING} + btWideChar: Result := ord(tbtwidechar(src^.twidechar)); + {$ENDIF} + btEnum: Result := src^.tu32; + else + begin + s := False; + Result := 0; + end; + end; +end; +{$ENDIF} + +function GetReal(Src: PIfRVariant; var s: Boolean): Extended; +begin + case Src.FType.BaseType of + btU8: Result := Src^.tu8; + btS8: Result := Src^.ts8; + btU16: Result := Src^.tu16; + btS16: Result := Src^.ts16; + btU32: Result := Src^.tu32; + btS32: Result := Src^.ts32; + {$IFNDEF PS_NOINT64} + bts64: Result := src^.ts64; + {$ENDIF} + btChar: Result := ord(Src^.tchar); + {$IFNDEF PS_NOWIDESTRING} + btWideChar: Result := ord(tbtwidechar(src^.twidechar)); + {$ENDIF} + btSingle: Result := Src^.tsingle; + btDouble: Result := Src^.tdouble; + btCurrency: Result := SRc^.tcurrency; + btExtended: Result := Src^.textended; + else + begin + s := False; + Result := 0; + end; + end; +end; + +function GetString(Src: PIfRVariant; var s: Boolean): tbtString; +begin + case Src.FType.BaseType of + btChar: Result := Src^.tchar; + btString: Result := tbtstring(src^.tstring); + {$IFNDEF PS_NOWIDESTRING} + btWideChar: Result := tbtstring(src^.twidechar); + btWideString: Result := tbtstring(tbtWideString(src^.twidestring)); + btUnicodeString: Result := tbtstring(tbtUnicodeString(src^.tunistring)); + {$ENDIF} + else + begin + s := False; + Result := ''; + end; + end; +end; + +{$IFNDEF PS_NOWIDESTRING} +function TPSPascalCompiler.GetWideString(Src: PIfRVariant; var s: Boolean): tbtwidestring; +begin + case Src.FType.BaseType of + btChar: Result := tbtWidestring(Src^.tchar); + btString: Result := tbtWidestring(tbtstring(src^.tstring)); + btWideChar: Result := src^.twidechar; + btWideString: Result := tbtWideString(src^.twidestring); + btUnicodeString: result := tbtUnicodeString(src^.tunistring); + else + begin + s := False; + Result := ''; + end; + end; +end; +function TPSPascalCompiler.GetUnicodeString(Src: PIfRVariant; var s: Boolean): tbtunicodestring; +begin + case Src.FType.BaseType of + btChar: Result := tbtWidestring(Src^.tchar); + btString: Result := tbtWidestring(tbtstring(src^.tstring)); + btWideChar: Result := src^.twidechar; + btWideString: Result := tbtWideString(src^.twidestring); + btUnicodeString: result := tbtUnicodeString(src^.tunistring); + else + begin + s := False; + Result := ''; + end; + end; +end; +{$ENDIF} + +function ab(b: Longint): Longint; +begin + ab := Longint(b = 0); +end; + +procedure Set_Union(Dest, Src: PByteArray; ByteSize: Integer); +var + i: Longint; +begin + for i := ByteSize -1 downto 0 do + Dest^[i] := Dest^[i] or Src^[i]; +end; + +procedure Set_Diff(Dest, Src: PByteArray; ByteSize: Integer); +var + i: Longint; +begin + for i := ByteSize -1 downto 0 do + Dest^[i] := Dest^[i] and not Src^[i]; +end; + +procedure Set_Intersect(Dest, Src: PByteArray; ByteSize: Integer); +var + i: Longint; +begin + for i := ByteSize -1 downto 0 do + Dest^[i] := Dest^[i] and Src^[i]; +end; + +procedure Set_Subset(Dest, Src: PByteArray; ByteSize: Integer; var Val: Boolean); +var + i: Integer; +begin + for i := ByteSize -1 downto 0 do + begin + if not (Src^[i] and Dest^[i] = Dest^[i]) then + begin + Val := False; + exit; + end; + end; + Val := True; +end; + +procedure Set_Equal(Dest, Src: PByteArray; ByteSize: Integer; var Val: Boolean); +var + i: Longint; +begin + for i := ByteSize -1 downto 0 do + begin + if Dest^[i] <> Src^[i] then + begin + Val := False; + exit; + end; + end; + val := True; +end; + +procedure Set_membership(Item: Longint; Src: PByteArray; var Val: Boolean); +begin + Val := (Src^[Item shr 3] and (1 shl (Item and 7))) <> 0; +end; + +procedure Set_MakeMember(Item: Longint; Src: PByteArray); +begin + Src^[Item shr 3] := Src^[Item shr 3] or (1 shl (Item and 7)); +end; + +procedure ConvertToBoolean(SE: TPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIFRVariant; b: Boolean); +begin + FinalizeVariant(var1^); + if FUseUsedTypes then + Var1^.FType := se.at2ut(se.FDefaultBoolType) + else + Var1^.FType := Se.FDefaultBoolType; + var1^.tu32 := Ord(b); +end; + +procedure ConvertToString(SE: TPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIFRVariant; const s: tbtString); +var + atype: TPSType; +begin + FinalizeVariant(var1^); + atype := se.FindBaseType(btString); + if FUseUsedTypes then + InitializeVariant(var1, se.at2ut(atype)) + else + InitializeVariant(var1, atype); + tbtstring(var1^.tstring) := s; +end; +{$IFNDEF PS_NOWIDESTRING} +procedure ConvertToUnicodeString(SE: TPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIFRVariant; const s: tbtunicodestring); +var + atype: TPSType; +begin + FinalizeVariant(var1^); + atype := se.FindBaseType(btUnicodeString); + if FUseUsedTypes then + InitializeVariant(var1, se.at2ut(atype)) + else + InitializeVariant(var1, atype); + tbtunicodestring(var1^.tunistring) := s; +end; +{$ENDIF} +procedure ConvertToFloat(SE: TPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIfRVariant; NewType: TPSType); +var + vartemp: PIfRVariant; + b: Boolean; +begin + New(vartemp); + b := false; + if FUseUsedTypes then + NewType := se.at2ut(NewType); + InitializeVariant(vartemp, var1.FType); + CopyVariantContents(var1, vartemp); + FinalizeVariant(var1^); + InitializeVariant(var1, newtype); + case var1.ftype.basetype of + btSingle: + begin + if (vartemp.ftype.BaseType = btu8) or (vartemp.ftype.BaseType = btu16) or (vartemp.ftype.BaseType = btu32) then + var1^.tsingle := GetUInt(vartemp, b) + else + var1^.tsingle := GetInt(vartemp, b) + end; + btDouble: + begin + if (vartemp.ftype.BaseType = btu8) or (vartemp.ftype.BaseType = btu16) or (vartemp.ftype.BaseType = btu32) then + var1^.tdouble := GetUInt(vartemp, b) + else + var1^.tdouble := GetInt(vartemp, b) + end; + btExtended: + begin + if (vartemp.ftype.BaseType = btu8) or (vartemp.ftype.BaseType = btu16) or (vartemp.ftype.BaseType = btu32) then + var1^.textended:= GetUInt(vartemp, b) + else + var1^.textended:= GetInt(vartemp, b) + end; + btCurrency: + begin + if (vartemp.ftype.BaseType = btu8) or (vartemp.ftype.BaseType = btu16) or (vartemp.ftype.BaseType = btu32) then + var1^.tcurrency:= GetUInt(vartemp, b) + else + var1^.tcurrency:= GetInt(vartemp, b) + end; + end; + DisposeVariant(vartemp); +end; + + +function TPSPascalCompiler.IsCompatibleType(p1, p2: TPSType; Cast: Boolean): Boolean; +begin + if + ((p1.BaseType = btProcPtr) and (p2 = p1)) or + (p1.BaseType = btPointer) or + (p2.BaseType = btPointer) or + ((p1.BaseType = btNotificationVariant) or (p1.BaseType = btVariant)) or + ((p2.BaseType = btNotificationVariant) or (p2.BaseType = btVariant)) or + (IsIntType(p1.BaseType) and IsIntType(p2.BaseType)) or + (IsRealType(p1.BaseType) and IsIntRealType(p2.BaseType)) or + (((p1.basetype = btPchar) or (p1.BaseType = btString)) and ((p2.BaseType = btString) or (p2.BaseType = btPchar))) or + (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btChar)) or + (((p1.BaseType = btArray) or (p1.BaseType = btStaticArray)) and ( + (p2.BaseType = btArray) or (p2.BaseType = btStaticArray)) and IsCompatibleType(TPSArrayType(p1).ArrayTypeNo, TPSArrayType(p2).ArrayTypeNo, False)) or + ((p1.BaseType = btChar) and (p2.BaseType = btChar)) or + ((p1.BaseType = btSet) and (p2.BaseType = btSet)) or + {$IFNDEF PS_NOWIDESTRING} + ((p1.BaseType = btWideChar) and (p2.BaseType = btChar)) or + ((p1.BaseType = btWideChar) and (p2.BaseType = btWideChar)) or + ((p1.BaseType = btWidestring) and (p2.BaseType = btChar)) or + ((p1.BaseType = btWidestring) and (p2.BaseType = btWideChar)) or + ((p1.BaseType = btWidestring) and ((p2.BaseType = btString) or (p2.BaseType = btPchar) or (p2.BaseType = btUnicodeString))) or + ((p1.BaseType = btWidestring) and ((p2.BaseType = btWidestring))) or + ((p1.BaseType = btUnicodeString) and (p2.BaseType = btChar)) or + ((p1.BaseType = btUnicodeString) and (p2.BaseType = btWideChar)) or + ((p1.BaseType = btUnicodeString) and ((p2.BaseType = btString) or (p2.BaseType = btPchar) or (p2.BaseType = btUnicodeString))) or + ((p1.BaseType = btUnicodeString) and (p2.BaseType = btWidestring)) or + (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btWideString)or (p2.BaseType = btUnicodeString)) or + (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btWidechar)) or + (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btchar)) or + {$ENDIF} + ((p1.BaseType = btRecord) and (p2.BaseType = btrecord) and (not IsVarInCompatible(p1, p2))) or + ((p1.BaseType = btEnum) and (p2.BaseType = btEnum)) or + (Cast and IsIntType(P1.BaseType) and (p2.baseType = btEnum)) or + (Cast and (p1.baseType = btEnum) and IsIntType(P2.BaseType)) + then + Result := True + // nx change start - allow casting class -> integer and vice versa + else if p1.BaseType = btclass then + Result := TPSClassType(p1).cl.IsCompatibleWith(p2) or (p2.BaseType in [btU32, btS32]) + else if (p1.BaseType in [btU32, btS32]) then + Result := (p2.BaseType = btClass) + // nx change end +{$IFNDEF PS_NOINTERFACES} + else if p1.BaseType = btInterface then + Result := TPSInterfaceType(p1).Intf.IsCompatibleWith(p2) +{$ENDIF} + else if ((p1.BaseType = btExtClass) and (p2.BaseType = btExtClass)) then + begin + Result := TPSUndefinedClassType(p1).ExtClass.IsCompatibleWith(TPSUndefinedClassType(p2).ExtClass); + end + else + Result := False; +end; + + +function TPSPascalCompiler.PreCalc(FUseUsedTypes: Boolean; Var1Mod: Byte; var1: PIFRVariant; Var2Mod: Byte; Var2: PIfRVariant; Cmd: TPSBinOperatorType; Pos, Row, Col: Cardinal): Boolean; + { var1=dest, var2=src } +var + b: Boolean; + +begin + Result := True; + try + if (IsRealType(var2.FType.BaseType) and IsIntType(var1.FType.BaseType)) then + ConvertToFloat(Self, FUseUsedTypes, var1, var2^.FType); + case Cmd of + otAdd: + begin { + } + case var1.FType.BaseType of + btU8: var1^.tu8 := var1^.tu8 + GetUint(Var2, Result); + btS8: var1^.ts8 := var1^.ts8 + GetInt(Var2, Result); + btU16: var1^.tu16 := var1^.tu16 + GetUint(Var2, Result); + btS16: var1^.ts16 := var1^.ts16 + Getint(Var2, Result); + btEnum, btU32: var1^.tu32 := var1^.tu32 + GetUint(Var2, Result); + btS32: var1^.ts32 := var1^.ts32 + Getint(Var2, Result); + {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 + GetInt64(Var2, Result); {$ENDIF} + btSingle: var1^.tsingle := var1^.tsingle + GetReal( Var2, Result); + btDouble: var1^.tdouble := var1^.tdouble + GetReal( Var2, Result); + btExtended: var1^.textended := var1^.textended + GetReal( Var2, Result); + btCurrency: var1^.tcurrency := var1^.tcurrency + GetReal( Var2, Result); + btSet: + begin + if (var1.FType = var2.FType) then + begin + Set_Union(var1.tstring, var2.tstring, TPSSetType(var1.FType).ByteSize); + end else Result := False; + end; + btChar: + begin + ConvertToString(Self, FUseUsedTypes, var1, getstring(Var1, b)+getstring(Var2, b)); + end; + btString: tbtstring(var1^.tstring) := tbtstring(var1^.tstring) + GetString(Var2, Result); + {$IFNDEF PS_NOWIDESTRING} + btwideString: tbtwidestring(var1^.twidestring) := tbtwidestring(var1^.twidestring) + GetWideString(Var2, Result); + btUnicodeString: tbtunicodestring(var1^.tunistring) := tbtunicodestring(var1^.tunistring) + GetUnicodeString(Var2, Result); + btWidechar: + begin + ConvertToUnicodeString(Self, FUseUsedTypes, var1, GetUnicodeString(Var1, b)+GetUnicodeString(Var2, b)); + end; + {$ENDIF} + else Result := False; + end; + end; + otSub: + begin { - } + case Var1.FType.BaseType of + btU8: var1^.tu8 := var1^.tu8 - GetUint(Var2, Result); + btS8: var1^.ts8 := var1^.ts8 - Getint(Var2, Result); + btU16: var1^.tu16 := var1^.tu16 - GetUint(Var2, Result); + btS16: var1^.ts16 := var1^.ts16 - Getint(Var2, Result); + btEnum, btU32: var1^.tu32 := var1^.tu32 - GetUint(Var2, Result); + btS32: var1^.ts32 := var1^.ts32 - Getint(Var2, Result); + {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 - GetInt64(Var2, Result); {$ENDIF} + btSingle: var1^.tsingle := var1^.tsingle - GetReal( Var2, Result); + btDouble: var1^.tdouble := var1^.tdouble - GetReal(Var2, Result); + btExtended: var1^.textended := var1^.textended - GetReal(Var2, Result); + btCurrency: var1^.tcurrency := var1^.tcurrency - GetReal( Var2, Result); + btSet: + begin + if (var1.FType = var2.FType) then + begin + Set_Diff(var1.tstring, var2.tstring, TPSSetType(var1.FType).ByteSize); + end else Result := False; + end; + else Result := False; + end; + end; + otMul: + begin { * } + case Var1.FType.BaseType of + btU8: var1^.tu8 := var1^.tu8 * GetUint(Var2, Result); + btS8: var1^.ts8 := var1^.ts8 * Getint(Var2, Result); + btU16: var1^.tu16 := var1^.tu16 * GetUint(Var2, Result); + btS16: var1^.ts16 := var1^.ts16 * Getint(Var2, Result); + btU32: var1^.tu32 := var1^.tu32 * GetUint(Var2, Result); + btS32: var1^.ts32 := var1^.ts32 * Getint(Var2, Result); + {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 * GetInt64(Var2, Result); {$ENDIF} + btSingle: var1^.tsingle := var1^.tsingle * GetReal(Var2, Result); + btDouble: var1^.tdouble := var1^.tdouble * GetReal(Var2, Result); + btExtended: var1^.textended := var1^.textended * GetReal( Var2, Result); + btCurrency: var1^.tcurrency := var1^.tcurrency * GetReal( Var2, Result); + btSet: + begin + if (var1.FType = var2.FType) then + begin + Set_Intersect(var1.tstring, var2.tstring, TPSSetType(var1.FType).ByteSize); + end else Result := False; + end; + else Result := False; + end; + end; + otDiv: + begin { / } + case Var1.FType.BaseType of + btU8: var1^.tu8 := var1^.tu8 div GetUint(Var2, Result); + btS8: var1^.ts8 := var1^.ts8 div Getint(Var2, Result); + btU16: var1^.tu16 := var1^.tu16 div GetUint(Var2, Result); + btS16: var1^.ts16 := var1^.ts16 div Getint(Var2, Result); + btU32: var1^.tu32 := var1^.tu32 div GetUint(Var2, Result); + btS32: var1^.ts32 := var1^.ts32 div Getint(Var2, Result); + {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 div GetInt64(Var2, Result); {$ENDIF} + btSingle: var1^.tsingle := var1^.tsingle / GetReal( Var2, Result); + btDouble: var1^.tdouble := var1^.tdouble / GetReal( Var2, Result); + btExtended: var1^.textended := var1^.textended / GetReal( Var2, Result); + btCurrency: var1^.tcurrency := var1^.tcurrency / GetReal( Var2, Result); + else Result := False; + end; + end; + otMod: + begin { MOD } + case Var1.FType.BaseType of + btU8: var1^.tu8 := var1^.tu8 mod GetUint(Var2, Result); + btS8: var1^.ts8 := var1^.ts8 mod Getint(Var2, Result); + btU16: var1^.tu16 := var1^.tu16 mod GetUint(Var2, Result); + btS16: var1^.ts16 := var1^.ts16 mod Getint(Var2, Result); + btU32: var1^.tu32 := var1^.tu32 mod GetUint(Var2, Result); + btS32: var1^.ts32 := var1^.ts32 mod Getint(Var2, Result); + {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 mod GetInt64(Var2, Result); {$ENDIF} + else Result := False; + end; + end; + otshl: + begin { SHL } + case Var1.FType.BaseType of + btU8: var1^.tu8 := var1^.tu8 shl GetUint(Var2, Result); + btS8: var1^.ts8 := var1^.ts8 shl Getint(Var2, Result); + btU16: var1^.tu16 := var1^.tu16 shl GetUint(Var2, Result); + btS16: var1^.ts16 := var1^.ts16 shl Getint(Var2, Result); + btU32: var1^.tu32 := var1^.tu32 shl GetUint(Var2, Result); + btS32: var1^.ts32 := var1^.ts32 shl Getint(Var2, Result); + {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 shl GetInt64(Var2, Result); {$ENDIF} + else Result := False; + end; + end; + otshr: + begin { SHR } + case Var1.FType.BaseType of + btU8: var1^.tu8 := var1^.tu8 shr GetUint(Var2, Result); + btS8: var1^.ts8 := var1^.ts8 shr Getint(Var2, Result); + btU16: var1^.tu16 := var1^.tu16 shr GetUint(Var2, Result); + btS16: var1^.ts16 := var1^.ts16 shr Getint(Var2, Result); + btU32: var1^.tu32 := var1^.tu32 shr GetUint(Var2, Result); + btS32: var1^.ts32 := var1^.ts32 shr Getint(Var2, Result); + {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 shr GetInt64( Var2, Result); {$ENDIF} + else Result := False; + end; + end; + otAnd: + begin { AND } + case Var1.FType.BaseType of + btU8: var1^.tu8 := var1^.tu8 and GetUint(Var2, Result); + btS8: var1^.ts8 := var1^.ts8 and Getint(Var2, Result); + btU16: var1^.tu16 := var1^.tu16 and GetUint(Var2, Result); + btS16: var1^.ts16 := var1^.ts16 and Getint(Var2, Result); + btU32: var1^.tu32 := var1^.tu32 and GetUint(Var2, Result); + btS32: var1^.ts32 := var1^.ts32 and Getint(Var2, Result); + btEnum: var1^.ts32 := var1^.ts32 and Getint(Var2, Result); + {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 and GetInt64(Var2, Result); {$ENDIF} + else Result := False; + end; + end; + otor: + begin { OR } + case Var1.FType.BaseType of + btU8: var1^.tu8 := var1^.tu8 or GetUint(Var2, Result); + btS8: var1^.ts8 := var1^.ts8 or Getint(Var2, Result); + btU16: var1^.tu16 := var1^.tu16 or GetUint(Var2, Result); + btS16: var1^.ts16 := var1^.ts16 or Getint(Var2, Result); + btU32: var1^.tu32 := var1^.tu32 or GetUint(Var2, Result); + btS32: var1^.ts32 := var1^.ts32 or Getint(Var2, Result); + {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 or GetInt64(Var2, Result); {$ENDIF} + btEnum: var1^.ts32 := var1^.ts32 or Getint(Var2, Result); + else Result := False; + end; + end; + otxor: + begin { XOR } + case Var1.FType.BaseType of + btU8: var1^.tu8 := var1^.tu8 xor GetUint(Var2, Result); + btS8: var1^.ts8 := var1^.ts8 xor Getint(Var2, Result); + btU16: var1^.tu16 := var1^.tu16 xor GetUint(Var2, Result); + btS16: var1^.ts16 := var1^.ts16 xor Getint(Var2, Result); + btU32: var1^.tu32 := var1^.tu32 xor GetUint(Var2, Result); + btS32: var1^.ts32 := var1^.ts32 xor Getint(Var2, Result); + {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 xor GetInt64(Var2, Result); {$ENDIF} + btEnum: var1^.ts32 := var1^.ts32 xor Getint(Var2, Result); + else Result := False; + end; + end; + otGreaterEqual: + begin { >= } + case Var1.FType.BaseType of + btU8: b := var1^.tu8 >= GetUint(Var2, Result); + btS8: b := var1^.ts8 >= Getint(Var2, Result); + btU16: b := var1^.tu16 >= GetUint(Var2, Result); + btS16: b := var1^.ts16 >= Getint(Var2, Result); + btU32: b := var1^.tu32 >= GetUint(Var2, Result); + btS32: b := var1^.ts32 >= Getint(Var2, Result); + {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 >= GetInt64(Var2, Result); {$ENDIF} + btSingle: b := var1^.tsingle >= GetReal( Var2, Result); + btDouble: b := var1^.tdouble >= GetReal( Var2, Result); + btExtended: b := var1^.textended >= GetReal( Var2, Result); + btCurrency: b := var1^.tcurrency >= GetReal( Var2, Result); + btSet: + begin + if (var1.FType = var2.FType) then + begin + Set_Subset(var2.tstring, var1.tstring, TPSSetType(var1.FType).ByteSize, b); + end else Result := False; + end; + else + Result := False; + end; + ConvertToBoolean(Self, FUseUsedTypes, Var1, b); + end; + otLessEqual: + begin { <= } + case Var1.FType.BaseType of + btU8: b := var1^.tu8 <= GetUint(Var2, Result); + btS8: b := var1^.ts8 <= Getint(Var2, Result); + btU16: b := var1^.tu16 <= GetUint(Var2, Result); + btS16: b := var1^.ts16 <= Getint(Var2, Result); + btU32: b := var1^.tu32 <= GetUint(Var2, Result); + btS32: b := var1^.ts32 <= Getint(Var2, Result); + {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 <= GetInt64(Var2, Result); {$ENDIF} + btSingle: b := var1^.tsingle <= GetReal( Var2, Result); + btDouble: b := var1^.tdouble <= GetReal( Var2, Result); + btExtended: b := var1^.textended <= GetReal( Var2, Result); + btCurrency: b := var1^.tcurrency <= GetReal( Var2, Result); + btSet: + begin + if (var1.FType = var2.FType) then + begin + Set_Subset(var1.tstring, var2.tstring, TPSSetType(var1.FType).ByteSize, b); + end else Result := False; + end; + else + Result := False; + end; + ConvertToBoolean(Self, FUseUsedTypes, Var1, b); + end; + otGreater: + begin { > } + case Var1.FType.BaseType of + btU8: b := var1^.tu8 > GetUint(Var2, Result); + btS8: b := var1^.ts8 > Getint(Var2, Result); + btU16: b := var1^.tu16 > GetUint(Var2, Result); + btS16: b := var1^.ts16 > Getint(Var2, Result); + btU32: b := var1^.tu32 > GetUint(Var2, Result); + btS32: b := var1^.ts32 > Getint(Var2, Result); + {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 > GetInt64(Var2, Result); {$ENDIF} + btSingle: b := var1^.tsingle > GetReal( Var2, Result); + btDouble: b := var1^.tdouble > GetReal( Var2, Result); + btExtended: b := var1^.textended > GetReal( Var2, Result); + btCurrency: b := var1^.tcurrency > GetReal( Var2, Result); + else + Result := False; + end; + ConvertToBoolean(Self, FUseUsedTypes, Var1, b); + end; + otLess: + begin { < } + case Var1.FType.BaseType of + btU8: b := var1^.tu8 < GetUint(Var2, Result); + btS8: b := var1^.ts8 < Getint(Var2, Result); + btU16: b := var1^.tu16 < GetUint(Var2, Result); + btS16: b := var1^.ts16 < Getint(Var2, Result); + btU32: b := var1^.tu32 < GetUint(Var2, Result); + btS32: b := var1^.ts32 < Getint(Var2, Result); + {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 < GetInt64(Var2, Result); {$ENDIF} + btSingle: b := var1^.tsingle < GetReal( Var2, Result); + btDouble: b := var1^.tdouble < GetReal( Var2, Result); + btExtended: b := var1^.textended < GetReal( Var2, Result); + btCurrency: b := var1^.tcurrency < GetReal( Var2, Result); + else + Result := False; + end; + ConvertToBoolean(Self, FUseUsedTypes, Var1, b); + end; + otNotEqual: + begin { <> } + case Var1.FType.BaseType of + btU8: b := var1^.tu8 <> GetUint(Var2, Result); + btS8: b := var1^.ts8 <> Getint(Var2, Result); + btU16: b := var1^.tu16 <> GetUint(Var2, Result); + btS16: b := var1^.ts16 <> Getint(Var2, Result); + btU32: b := var1^.tu32 <> GetUint(Var2, Result); + {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 <> GetInt64(Var2, Result); {$ENDIF} + btS32: b := var1^.ts32 <> Getint(Var2, Result); + btSingle: b := var1^.tsingle <> GetReal( Var2, Result); + btDouble: b := var1^.tdouble <> GetReal( Var2, Result); + btExtended: b := var1^.textended <> GetReal( Var2, Result); + btCurrency: b := var1^.tcurrency <> GetReal( Var2, Result); + btEnum: b := var1^.ts32 <> Getint(Var2, Result); + btString: b := tbtstring(var1^.tstring) <> GetString(var2, Result); + btChar: b := var1^.tchar <> GetString(var2, Result); + {$IFNDEF PS_NOWIDESTRING} + btWideString: b := tbtWideString(var1^.twidestring) <> GetWideString(var2, Result); + btUnicodeString: b := tbtUnicodeString(var1^.tunistring) <> GetUnicodeString(var2, Result); + btWideChar: b := var1^.twidechar <> GetUnicodeString(var2, Result); + {$ENDIF} + btSet: + begin + if (var1.FType = var2.FType) then + begin + Set_Equal(var1.tstring, var2.tstring, TPSSetType(var1.FType).GetByteSize, b); + b := not b; + end else Result := False; + end; + else + Result := False; + end; + ConvertToBoolean(Self, FUseUsedTypes, Var1, b); + end; + otEqual: + begin { = } + case Var1.FType.BaseType of + btU8: b := var1^.tu8 = GetUint(Var2, Result); + btS8: b := var1^.ts8 = Getint(Var2, Result); + btU16: b := var1^.tu16 = GetUint(Var2, Result); + btS16: b := var1^.ts16 = Getint(Var2, Result); + btU32: b := var1^.tu32 = GetUint(Var2, Result); + btS32: b := var1^.ts32 = Getint(Var2, Result); + {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 = GetInt64(Var2, Result); {$ENDIF} + btSingle: b := var1^.tsingle = GetReal( Var2, Result); + btDouble: b := var1^.tdouble = GetReal( Var2, Result); + btExtended: b := var1^.textended = GetReal( Var2, Result); + btCurrency: b := var1^.tcurrency = GetReal( Var2, Result); + btEnum: b := var1^.ts32 = Getint(Var2, Result); + btString: b := tbtstring(var1^.tstring) = GetString(var2, Result); + btChar: b := var1^.tchar = GetString(var2, Result); + {$IFNDEF PS_NOWIDESTRING} + btWideString: b := tbtWideString(var1^.twidestring) = GetWideString(var2, Result); + btUnicodeString: b := tbtUnicodeString(var1^.twidestring) = GetUnicodeString(var2, Result); + btWideChar: b := var1^.twidechar = GetUnicodeString(var2, Result); + {$ENDIF} + btSet: + begin + if (var1.FType = var2.FType) then + begin + Set_Equal(var1.tstring, var2.tstring, TPSSetType(var1.FType).ByteSize, b); + end else Result := False; + end; + else + Result := False; + end; + ConvertToBoolean(Self, FUseUsedTypes, Var1, b); + end; + otIn: + begin + if (var2.Ftype.BaseType = btset) and (TPSSetType(var2).SetType = Var1.FType) then + begin + Set_membership(GetUint(var1, result), var2.tstring, b); + end else Result := False; + end; + else + Result := False; + end; + except + on E: EDivByZero do + begin + Result := False; + MakeError('', ecDivideByZero, ''); + Exit; + end; + on E: EZeroDivide do + begin + Result := False; + MakeError('', ecDivideByZero, ''); + Exit; + end; + on E: EMathError do + begin + Result := False; + MakeError('', ecMathError, tbtstring(e.Message)); + Exit; + end; + on E: Exception do + begin + Result := False; + MakeError('', ecInternalError, tbtstring(E.Message)); + Exit; + end; + end; + if not Result then + begin + with MakeError('', ecTypeMismatch, '') do + begin + FPosition := Pos; + FRow := Row; + FCol := Col; + end; + end; +end; + +function TPSPascalCompiler.IsDuplicate(const s: tbtString; const check: TPSDuplicCheck): Boolean; +var + h, l: Longint; + x: TPSProcedure; +begin + h := MakeHash(s); + if (s = 'RESULT') then + begin + Result := True; + exit; + end; + if dcTypes in Check then + for l := FTypes.Count - 1 downto 0 do + begin + if (TPSType(FTypes.Data[l]).NameHash = h) and + (TPSType(FTypes.Data[l]).Name = s) then + begin + Result := True; + exit; + end; + end; + + if dcProcs in Check then + for l := FProcs.Count - 1 downto 0 do + begin + x := FProcs.Data[l]; + if x.ClassType = TPSInternalProcedure then + begin + if (h = TPSInternalProcedure(x).NameHash) and (s = TPSInternalProcedure(x).Name) then + begin + Result := True; + exit; + end; + end + else + begin + if (TPSExternalProcedure(x).RegProc.NameHash = h) and + (TPSExternalProcedure(x).RegProc.Name = s) then + begin + Result := True; + exit; + end; + end; + end; + if dcVars in Check then + for l := FVars.Count - 1 downto 0 do + begin + if (TPSVar(FVars.Data[l]).NameHash = h) and + (TPSVar(FVars.Data[l]).Name = s) then + begin + Result := True; + exit; + end; + end; + if dcConsts in Check then + for l := FConstants.Count -1 downto 0 do + begin + if (TPSConstant(FConstants.Data[l]).NameHash = h) and + (TPSConstant(FConstants.Data[l]).Name = s) then + begin + Result := TRue; + exit; + end; + end; + Result := False; +end; + +procedure ClearRecSubVals(RecSubVals: TPSList); +var + I: Longint; +begin + for I := 0 to RecSubVals.Count - 1 do + TPSRecordFieldTypeDef(RecSubVals[I]).Free; + RecSubVals.Free; +end; + +function TPSPascalCompiler.ReadTypeAddProcedure(const Name: tbtString; FParser: TPSPascalParser): TPSType; +var + IsFunction: Boolean; + VNames: tbtString; + modifier: TPSParameterMode; + Decl: TPSParametersDecl; + VCType: TPSType; +begin + if FParser.CurrTokenId = CSTII_Function then + IsFunction := True + else + IsFunction := False; + Decl := TPSParametersDecl.Create; + try + FParser.Next; + if FParser.CurrTokenId = CSTI_OpenRound then + begin + FParser.Next; + if FParser.CurrTokenId <> CSTI_CloseRound then + begin + while True do + begin + if FParser.CurrTokenId = CSTII_Const then + begin + Modifier := pmIn; + FParser.Next; + end else + if FParser.CurrTokenId = CSTII_Out then + begin + Modifier := pmOut; + FParser.Next; + end else + if FParser.CurrTokenId = CSTII_Var then + begin + modifier := pmInOut; + FParser.Next; + end + else + modifier := pmIn; + if FParser.CurrTokenId <> CSTI_Identifier then + begin + Result := nil; + if FParser = Self.FParser then + MakeError('', ecIdentifierExpected, ''); + exit; + end; + VNames := FParser.OriginalToken + '|'; + FParser.Next; + while FParser.CurrTokenId = CSTI_Comma do + begin + FParser.Next; + if FParser.CurrTokenId <> CSTI_Identifier then + begin + Result := nil; + if FParser = Self.FParser then + MakeError('', ecIdentifierExpected, ''); + exit; + end; + VNames := VNames + FParser.GetToken + '|'; + FParser.Next; + end; + if FParser.CurrTokenId <> CSTI_Colon then + begin + Result := nil; + if FParser = Self.FParser then + MakeError('', ecColonExpected, ''); + exit; + end; + FParser.Next; + if FParser.CurrTokenId <> CSTI_Identifier then + begin + Result := nil; + if FParser = self.FParser then + MakeError('', ecIdentifierExpected, ''); + exit; + end; + VCType := FindType(FParser.GetToken); + if VCType = nil then + begin + if FParser = self.FParser then + MakeError('', ecUnknownIdentifier, FParser.OriginalToken); + Result := nil; + exit; + end; + while Pos(tbtchar('|'), VNames) > 0 do + begin + with Decl.AddParam do + begin + Mode := modifier; + OrgName := copy(VNames, 1, Pos(tbtchar('|'), VNames) - 1); + FType := VCType; + end; + Delete(VNames, 1, Pos(tbtchar('|'), VNames)); + end; + FParser.Next; + if FParser.CurrTokenId = CSTI_CloseRound then + break; + if FParser.CurrTokenId <> CSTI_Semicolon then + begin + if FParser = Self.FParser then + MakeError('', ecSemicolonExpected, ''); + Result := nil; + exit; + end; + FParser.Next; + end; {while} + end; {if} + FParser.Next; + end; {if} + if IsFunction then + begin + if FParser.CurrTokenId <> CSTI_Colon then + begin + if FParser = Self.FParser then + MakeError('', ecColonExpected, ''); + Result := nil; + exit; + end; + FParser.Next; + if FParser.CurrTokenId <> CSTI_Identifier then + begin + Result := nil; + if FParser = Self.FParser then + MakeError('', ecIdentifierExpected, ''); + exit; + end; + VCType := self.FindType(FParser.GetToken); + if VCType = nil then + begin + if FParser = self.FParser then + MakeError('', ecUnknownIdentifier, FParser.OriginalToken); + Result := nil; + exit; + end; + FParser.Next; + end + else + VCType := nil; + Decl.Result := VcType; + VCType := TPSProceduralType.Create; + VCType.Name := FastUppercase(Name); + VCType.OriginalName := Name; + VCType.BaseType := btProcPtr; + {$IFDEF PS_USESSUPPORT} + VCType.DeclareUnit:=fModule; + {$ENDIF} + VCType.DeclarePos := FParser.CurrTokenPos; + VCType.DeclareRow := FParser.Row; + VCType.DeclareCol := FParser.Col; + TPSProceduralType(VCType).ProcDef.Assign(Decl); + FTypes.Add(VCType); + Result := VCType; + finally + Decl.Free; + end; +end; {ReadTypeAddProcedure} + + +function TPSPascalCompiler.ReadType(const Name: tbtString; FParser: TPSPascalParser): TPSType; // InvalidVal = Invalid +var + TypeNo: TPSType; + h, l: Longint; + FieldName,fieldorgname,s: tbtString; + RecSubVals: TPSList; + FArrayStart, FArrayLength: Longint; + rvv: PIFPSRecordFieldTypeDef; + p, p2: TPSType; + tempf: PIfRVariant; + +begin + if (FParser.CurrTokenID = CSTII_Function) or (FParser.CurrTokenID = CSTII_Procedure) then + begin + Result := ReadTypeAddProcedure(Name, FParser); + Exit; + end else if FParser.CurrTokenId = CSTII_Set then + begin + FParser.Next; + if FParser.CurrTokenId <> CSTII_Of then + begin + MakeError('', ecOfExpected, ''); + Result := nil; + Exit; + end; + FParser.Next; + if FParser.CurrTokenID <> CSTI_Identifier then + begin + MakeError('', ecIdentifierExpected, ''); + Result := nil; + exit; + end; + TypeNo := FindType(FParser.GetToken); + if TypeNo = nil then + begin + MakeError('', ecUnknownIdentifier, ''); + Result := nil; + exit; + end; + if (TypeNo.BaseType = btEnum) or (TypeNo.BaseType = btChar) or (TypeNo.BaseType = btU8) then + begin + FParser.Next; + p2 := TPSSetType.Create; + p2.Name := FastUppercase(Name); + p2.OriginalName := Name; + p2.BaseType := btSet; + {$IFDEF PS_USESSUPPORT} + p2.DeclareUnit:=fModule; + {$ENDIF} + p2.DeclarePos := FParser.CurrTokenPos; + p2.DeclareRow := FParser.Row; + p2.DeclareCol := FParser.Col; + TPSSetType(p2).SetType := TypeNo; + FTypes.Add(p2); + Result := p2; + end else + begin + MakeError('', ecTypeMismatch, ''); + Result := nil; + end; + exit; + end else if FParser.CurrTokenId = CSTI_OpenRound then + begin + FParser.Next; + L := 0; + P2 := TPSEnumType.Create; + P2.Name := FastUppercase(Name); + p2.OriginalName := Name; + p2.BaseType := btEnum; + {$IFDEF PS_USESSUPPORT} + p2.DeclareUnit:=fModule; + {$ENDIF} + p2.DeclarePos := FParser.CurrTokenPos; + p2.DeclareRow := FParser.Row; + p2.DeclareCol := FParser.Col; + FTypes.Add(p2); + + repeat + if FParser.CurrTokenId <> CSTI_Identifier then + begin + if FParser = Self.FParser then + MakeError('', ecIdentifierExpected, ''); + Result := nil; + exit; + end; + s := FParser.OriginalToken; + if IsDuplicate(FastUppercase(s), [dcTypes]) then + begin + if FParser = Self.FParser then + MakeError('', ecDuplicateIdentifier, s); + Result := nil; + Exit; + end; + with AddConstant(s, p2) do + begin + FValue.tu32 := L; + {$IFDEF PS_USESSUPPORT} + DeclareUnit:=fModule; + {$ENDIF} + DeclarePos:=FParser.CurrTokenPos; + DeclareRow:=FParser.Row; + DeclareCol:=FParser.Col; + end; + Inc(L); + FParser.Next; + if FParser.CurrTokenId = CSTI_CloseRound then + Break + else if FParser.CurrTokenId <> CSTI_Comma then + begin + if FParser = Self.FParser then + MakeError('', ecCloseRoundExpected, ''); + Result := nil; + Exit; + end; + FParser.Next; + until False; + FParser.Next; + TPSEnumType(p2).HighValue := L-1; + Result := p2; + exit; + end else + if FParser.CurrTokenId = CSTII_Array then + begin + FParser.Next; + if FParser.CurrTokenID = CSTI_OpenBlock then + begin + FParser.Next; + tempf := ReadConstant(FParser, CSTI_TwoDots); + if tempf = nil then + begin + Result := nil; + exit; + end; + case tempf.FType.BaseType of + btU8: FArrayStart := tempf.tu8; + btS8: FArrayStart := tempf.ts8; + btU16: FArrayStart := tempf.tu16; + btS16: FArrayStart := tempf.ts16; + btU32: FArrayStart := tempf.tu32; + btS32: FArrayStart := tempf.ts32; + {$IFNDEF PS_NOINT64} + bts64: FArrayStart := tempf.ts64; + {$ENDIF} + else + begin + DisposeVariant(tempf); + MakeError('', ecTypeMismatch, ''); + Result := nil; + exit; + end; + end; + DisposeVariant(tempf); + if FParser.CurrTokenID <> CSTI_TwoDots then + begin + MakeError('', ecPeriodExpected, ''); + Result := nil; + exit; + end; + FParser.Next; + tempf := ReadConstant(FParser, CSTI_CloseBlock); + if tempf = nil then + begin + Result := nil; + exit; + end; + case tempf.FType.BaseType of + btU8: FArrayLength := tempf.tu8; + btS8: FArrayLength := tempf.ts8; + btU16: FArrayLength := tempf.tu16; + btS16: FArrayLength := tempf.ts16; + btU32: FArrayLength := tempf.tu32; + btS32: FArrayLength := tempf.ts32; + {$IFNDEF PS_NOINT64} + bts64: FArrayLength := tempf.ts64; + {$ENDIF} + else + DisposeVariant(tempf); + MakeError('', ecTypeMismatch, ''); + Result := nil; + exit; + end; + DisposeVariant(tempf); + FArrayLength := FArrayLength - FArrayStart + 1; + if (FArrayLength < 0) or (FArrayLength > MaxInt div 4) then + begin + MakeError('', ecTypeMismatch, ''); + Result := nil; + exit; + end; + if FParser.CurrTokenID <> CSTI_CloseBlock then + begin + MakeError('', ecCloseBlockExpected, ''); + Result := nil; + exit; + end; + FParser.Next; + end else + begin + FArrayStart := 0; + FArrayLength := -1; + end; + if FParser.CurrTokenId <> CSTII_Of then + begin + if FParser = Self.FParser then + MakeError('', ecOfExpected, ''); + Result := nil; + exit; + end; + FParser.Next; + TypeNo := ReadType('', FParser); + if TypeNo = nil then + begin + if FParser = Self.FParser then + MakeError('', ecUnknownIdentifier, ''); + Result := nil; + exit; + end; + if (Name = '') and (FArrayLength = -1) then + begin + if TypeNo.Used then + begin + for h := 0 to FTypes.Count -1 do + begin + p := FTypes[H]; + if (p.BaseType = btArray) and (TPSArrayType(p).ArrayTypeNo = TypeNo) and (Copy(p.Name, 1, 1) <> '!') then + begin + Result := p; + exit; + end; + end; + end; + end; + if FArrayLength <> -1 then + begin + p := TPSStaticArrayType.Create; + TPSStaticArrayType(p).StartOffset := FArrayStart; + TPSStaticArrayType(p).Length := FArrayLength; + p.BaseType := btStaticArray; + end else + begin + p := TPSArrayType.Create; + p.BaseType := btArray; + end; + p.Name := FastUppercase(Name); + p.OriginalName := Name; + {$IFDEF PS_USESSUPPORT} + p.DeclareUnit:=fModule; + {$ENDIF} + p.DeclarePos := FParser.CurrTokenPos; + p.DeclareRow := FParser.Row; + p.DeclareCol := FParser.Col; + TPSArrayType(p).ArrayTypeNo := TypeNo; + FTypes.Add(p); + Result := p; + Exit; + end + else if FParser.CurrTokenId = CSTII_Record then + begin + FParser.Next; + RecSubVals := TPSList.Create; + repeat + repeat + if FParser.CurrTokenId <> CSTI_Identifier then + begin + ClearRecSubVals(RecSubVals); + if FParser = Self.FParser then + MakeError('', ecIdentifierExpected, ''); + Result := nil; + exit; + end; + FieldName := FParser.GetToken; + s := S+FParser.OriginalToken+'|'; + FParser.Next; + h := MakeHash(FieldName); + for l := 0 to RecSubVals.Count - 1 do + begin + if (PIFPSRecordFieldTypeDef(RecSubVals[l]).FieldNameHash = h) and + (PIFPSRecordFieldTypeDef(RecSubVals[l]).FieldName = FieldName) then + begin + if FParser = Self.FParser then + MakeError('', ecDuplicateIdentifier, FParser.OriginalToken); + ClearRecSubVals(RecSubVals); + Result := nil; + exit; + end; + end; + if FParser.CurrTokenID = CSTI_Colon then Break else + if FParser.CurrTokenID <> CSTI_Comma then + begin + if FParser = Self.FParser then + MakeError('', ecColonExpected, ''); + ClearRecSubVals(RecSubVals); + Result := nil; + exit; + end; + FParser.Next; + until False; + FParser.Next; + p := ReadType('', FParser); + if p = nil then + begin + ClearRecSubVals(RecSubVals); + Result := nil; + exit; + end; + p := GetTypeCopyLink(p); + if FParser.CurrTokenId <> CSTI_Semicolon then + begin + ClearRecSubVals(RecSubVals); + if FParser = Self.FParser then + MakeError('', ecSemicolonExpected, ''); + Result := nil; + exit; + end; {if} + FParser.Next; + while Pos(tbtchar('|'), s) > 0 do + begin + fieldorgname := copy(s, 1, Pos(tbtchar('|'), s)-1); + Delete(s, 1, length(FieldOrgName)+1); + rvv := TPSRecordFieldTypeDef.Create; + rvv.FieldOrgName := fieldorgname; + rvv.FType := p; + RecSubVals.Add(rvv); + end; + until FParser.CurrTokenId = CSTII_End; + FParser.Next; // skip CSTII_End + P := TPSRecordType.Create; + p.Name := FastUppercase(Name); + p.OriginalName := Name; + p.BaseType := btRecord; + {$IFDEF PS_USESSUPPORT} + p.DeclareUnit:=fModule; + {$ENDIF} + p.DeclarePos := FParser.CurrTokenPos; + p.DeclareRow := FParser.Row; + p.DeclareCol := FParser.Col; + for l := 0 to RecSubVals.Count -1 do + begin + rvv := RecSubVals[l]; + with TPSRecordType(p).AddRecVal do + begin + FieldOrgName := rvv.FieldOrgName; + FType := rvv.FType; + end; + rvv.Free; + end; + RecSubVals.Free; + FTypes.Add(p); + Result := p; + Exit; + end else if FParser.CurrTokenId = CSTI_Identifier then + begin + s := FParser.GetToken; + h := MakeHash(s); + Typeno := nil; + for l := 0 to FTypes.Count - 1 do + begin + p2 := FTypes[l]; + if (p2.NameHash = h) and (p2.Name = s) then + begin + FParser.Next; + Typeno := GetTypeCopyLink(p2); + Break; + end; + end; + if Typeno = nil then + begin + Result := nil; + if FParser = Self.FParser then + MakeError('', ecUnknownType, FParser.OriginalToken); + exit; + end; + if Name <> '' then + begin + p := TPSTypeLink.Create; + p.Name := FastUppercase(Name); + p.OriginalName := Name; + p.BaseType := BtTypeCopy; + {$IFDEF PS_USESSUPPORT} + p.DeclareUnit:=fModule; + {$ENDIF} + p.DeclarePos := FParser.CurrTokenPos; + p.DeclareRow := FParser.Row; + p.DeclareCol := FParser.Col; + TPSTypeLink(p).LinkTypeNo := TypeNo; + FTypes.Add(p); + Result := p; + Exit; + end else + begin + Result := TypeNo; + exit; + end; + end; + Result := nil; + if FParser = Self.FParser then + MakeError('', ecIdentifierExpected, ''); + Exit; +end; + +function TPSPascalCompiler.VarIsDuplicate(Proc: TPSInternalProcedure; const Varnames, s: tbtString): Boolean; +var + h, l: Longint; + x: TPSProcedure; + v: tbtString; +begin + h := MakeHash(s); + if (s = 'RESULT') then + begin + Result := True; + exit; + end; + + for l := FProcs.Count - 1 downto 0 do + begin + x := FProcs.Data[l]; + if x.ClassType = TPSInternalProcedure then + begin + if (h = TPSInternalProcedure(x).NameHash) and (s = TPSInternalProcedure(x).Name) then + begin + Result := True; + exit; + end; + end + else + begin + if (TPSExternalProcedure(x).RegProc.NameHash = h) and (TPSExternalProcedure(x).RegProc.Name = s) then + begin + Result := True; + exit; + end; + end; + end; + if proc <> nil then + begin + for l := proc.ProcVars.Count - 1 downto 0 do + begin + if (PIFPSProcVar(proc.ProcVars.Data[l]).NameHash = h) and + (PIFPSProcVar(proc.ProcVars.Data[l]).Name = s) then + begin + Result := True; + exit; + end; + end; + for l := Proc.FDecl.ParamCount -1 downto 0 do + begin + if (Proc.FDecl.Params[l].Name = s) then + begin + Result := True; + exit; + end; + end; + end + else + begin + for l := FVars.Count - 1 downto 0 do + begin + if (TPSVar(FVars.Data[l]).NameHash = h) and + (TPSVar(FVars.Data[l]).Name = s) then + begin + Result := True; + exit; + end; + end; + end; + v := VarNames; + while Pos(tbtchar('|'), v) > 0 do + begin + if FastUppercase(copy(v, 1, Pos(tbtchar('|'), v) - 1)) = s then + begin + Result := True; + exit; + end; + Delete(v, 1, Pos(tbtchar('|'), v)); + end; + for l := FConstants.Count -1 downto 0 do + begin + if (TPSConstant(FConstants.Data[l]).NameHash = h) and + (TPSConstant(FConstants.Data[l]).Name = s) then + begin + Result := True; + exit; + end; + end; + Result := False; +end; + + +function TPSPascalCompiler.DoVarBlock(proc: TPSInternalProcedure): Boolean; +var + VarName, s: tbtString; + VarType: TPSType; + VarNo: Cardinal; + v: TPSVar; + vp: PIFPSProcVar; + EPos, ERow, ECol: Integer; +begin + Result := False; + FParser.Next; // skip CSTII_Var + if FParser.CurrTokenId <> CSTI_Identifier then + begin + MakeError('', ecIdentifierExpected, ''); + exit; + end; + repeat + VarNAme := ''; + if VarIsDuplicate(proc, VarName, FParser.GetToken) then + begin + MakeError('', ecDuplicateIdentifier, FParser.OriginalToken); + exit; + end; + VarName := FParser.OriginalToken + '|'; + Varno := 0; + if @FOnUseVariable <> nil then + begin + if Proc <> nil then + FOnUseVariable(Self, ivtVariable, Proc.ProcVars.Count + VarNo, FProcs.Count -1, FParser.CurrTokenPos, '') + else + FOnUseVariable(Self, ivtGlobal, FVars.Count + VarNo, InvalidVal, FParser.CurrTokenPos, '') + end; + EPos:=FParser.CurrTokenPos; + ERow:=FParser.Row; + ECol:=FParser.Col; + FParser.Next; + while FParser.CurrTokenId = CSTI_Comma do + begin + FParser.Next; + if FParser.CurrTokenId <> CSTI_Identifier then + begin + MakeError('', ecIdentifierExpected, ''); + end; + if VarIsDuplicate(proc, VarName, FParser.GetToken) then + begin + MakeError('', ecDuplicateIdentifier, FParser.OriginalToken); + exit; + end; + VarName := VarName + FParser.OriginalToken + '|'; + Inc(varno); + if @FOnUseVariable <> nil then + begin + if Proc <> nil then + FOnUseVariable(Self, ivtVariable, Proc.ProcVars.Count + VarNo, FProcs.Count -1, FParser.CurrTokenPos, '') + else + FOnUseVariable(Self, ivtGlobal, FVars.Count + VarNo, InvalidVal, FParser.CurrTokenPos, '') + end; + FParser.Next; + end; + if FParser.CurrTokenId <> CSTI_Colon then + begin + MakeError('', ecColonExpected, ''); + exit; + end; + FParser.Next; + VarType := at2ut(ReadType('', FParser)); + if VarType = nil then + begin + exit; + end; + while Pos(tbtchar('|'), VarName) > 0 do + begin + s := copy(VarName, 1, Pos(tbtchar('|'), VarName) - 1); + Delete(VarName, 1, Pos(tbtchar('|'), VarName)); + if proc = nil then + begin + v := TPSVar.Create; + v.OrgName := s; + v.Name := FastUppercase(s); + {$IFDEF PS_USESSUPPORT} + v.DeclareUnit:=fModule; + {$ENDIF} + v.DeclarePos := EPos; + v.DeclareRow := ERow; + v.DeclareCol := ECol; + v.FType := VarType; + FVars.Add(v); + end + else + begin + vp := TPSProcVar.Create; + vp.OrgName := s; + vp.Name := FastUppercase(s); + vp.aType := VarType; + {$IFDEF PS_USESSUPPORT} + vp.DeclareUnit:=fModule; + {$ENDIF} + vp.DeclarePos := EPos; + vp.DeclareRow := ERow; + vp.DeclareCol := ECol; + proc.ProcVars.Add(vp); + end; + end; + if FParser.CurrTokenId <> CSTI_Semicolon then + begin + MakeError('', ecSemicolonExpected, ''); + exit; + end; + FParser.Next; + until FParser.CurrTokenId <> CSTI_Identifier; + Result := True; +end; + +function TPSPascalCompiler.NewProc(const OriginalName, Name: tbtString): TPSInternalProcedure; +begin + Result := TPSInternalProcedure.Create; + Result.OriginalName := OriginalName; + Result.Name := Name; + {$IFDEF PS_USESSUPPORT} + Result.DeclareUnit:=fModule; + {$ENDIF} + Result.DeclarePos := FParser.CurrTokenPos; + Result.DeclareRow := FParser.Row; + Result.DeclareCol := FParser.Col; + FProcs.Add(Result); +end; + +function TPSPascalCompiler.IsProcDuplicLabel(Proc: TPSInternalProcedure; const s: tbtString): Boolean; +var + i: Longint; + h: Longint; + u: tbtString; +begin + h := MakeHash(s); + if s = 'RESULT' then + Result := True + else if Proc.Name = s then + Result := True + else if IsDuplicate(s, [dcVars, dcConsts, dcProcs]) then + Result := True + else + begin + for i := 0 to Proc.Decl.ParamCount -1 do + begin + if Proc.Decl.Params[i].Name = s then + begin + Result := True; + exit; + end; + end; + for i := 0 to Proc.ProcVars.Count -1 do + begin + if (PIFPSProcVar(Proc.ProcVars[I]).NameHash = h) and (PIFPSProcVar(Proc.ProcVars[I]).Name = s) then + begin + Result := True; + exit; + end; + end; + for i := 0 to Proc.FLabels.Count -1 do + begin + u := Proc.FLabels[I]; + delete(u, 1, 4); + if Longint((@u[1])^) = h then + begin + delete(u, 1, 4); + if u = s then + begin + Result := True; + exit; + end; + end; + end; + Result := False; + end; +end; + + +function TPSPascalCompiler.ProcessLabel(Proc: TPSInternalProcedure): Boolean; +var + CurrLabel: tbtString; +begin + FParser.Next; + while true do + begin + if FParser.CurrTokenId <> CSTI_Identifier then + begin + MakeError('', ecIdentifierExpected, ''); + Result := False; + exit; + end; + CurrLabel := FParser.GetToken; + if IsProcDuplicLabel(Proc, CurrLabel) then + begin + MakeError('', ecDuplicateIdentifier, CurrLabel); + Result := False; + exit; + end; + FParser.Next; + Proc.FLabels.Add(#$FF#$FF#$FF#$FF+PS_mi2s(MakeHash(CurrLabel))+CurrLabel); + if FParser.CurrTokenId = CSTI_Semicolon then + begin + FParser.Next; + Break; + end; + if FParser.CurrTokenId <> CSTI_Comma then + begin + MakeError('', ecCommaExpected, ''); + Result := False; + exit; + end; + FParser.Next; + end; + Result := True; +end; + +procedure TPSPascalCompiler.Debug_SavePosition(ProcNo: Cardinal; Proc: TPSInternalProcedure); +var + Row, + Col, + Pos: Cardinal; + s: tbtString; +begin + Row := FParser.Row; + Col := FParser.Col; + Pos := FParser.CurrTokenPos; + {$IFNDEF PS_USESSUPPORT} + s := ''; + {$ELSE} + s := fModule; + {$ENDIF} + if @FOnTranslateLineInfo <> nil then + FOnTranslateLineInfo(Self, Pos, Row, Col, S); + {$IFDEF FPC} + WriteDebugData(#4 + s + #1); + WriteDebugData(Ps_mi2s(ProcNo)); + WriteDebugData(Ps_mi2s(Length(Proc.Data))); + WriteDebugData(Ps_mi2s(Pos)); + WriteDebugData(Ps_mi2s(Row)); + WriteDebugData(Ps_mi2s(Col)); + {$ELSE} + WriteDebugData(#4 + s + #1 + PS_mi2s(ProcNo) + PS_mi2s(Length(Proc.Data)) + PS_mi2s(Pos) + PS_mi2s(Row)+ PS_mi2s(Col)); + {$ENDIF} +end; + +procedure TPSPascalCompiler.Debug_WriteParams(ProcNo: Cardinal; Proc: TPSInternalProcedure); +var + I: Longint; + s: tbtString; +begin + s := #2 + PS_mi2s(ProcNo); + if Proc.Decl.Result <> nil then + begin + s := s + 'Result' + #1; + end; + for i := 0 to Proc.Decl.ParamCount -1 do + s := s + Proc.Decl.Params[i].OrgName + #1; + s := s + #0#3 + PS_mi2s(ProcNo); + for I := 0 to Proc.ProcVars.Count - 1 do + begin + s := s + PIFPSProcVar(Proc.ProcVars[I]).OrgName + #1; + end; + s := s + #0; + WriteDebugData(s); +end; + +procedure TPSPascalCompiler.CheckForUnusedVars(Func: TPSInternalProcedure); +var + i: Integer; + p: PIFPSProcVar; +begin + for i := 0 to Func.ProcVars.Count -1 do + begin + p := Func.ProcVars[I]; + if not p.Used then + begin + with MakeHint({$IFDEF PS_USESSUPPORT}p.DeclareUnit{$ELSE}''{$ENDIF}, ehVariableNotUsed, p.Name) do + begin + FRow := p.DeclareRow; + FCol := p.DeclareCol; + FPosition := p.DeclarePos; + end; + end; + end; + if (not Func.ResultUsed) and (Func.Decl.Result <> nil) then + begin + with MakeHint({$IFDEF PS_USESSUPPORT}Func.DeclareUnit{$ELSE}''{$ENDIF}, ehVariableNotUsed, 'Result') do + begin + FRow := Func.DeclareRow; + FCol := Func.DeclareCol; + FPosition := Func.DeclarePos; + end; + end; +end; + +function TPSPascalCompiler.ProcIsDuplic(Decl: TPSParametersDecl; const FunctionName, FunctionParamNames: tbtString; const s: tbtString; Func: TPSInternalProcedure): Boolean; +var + i: Longint; + u: tbtString; +begin + if s = 'RESULT' then + Result := True + else if FunctionName = s then + Result := True + else + begin + for i := 0 to Decl.ParamCount -1 do + begin + if Decl.Params[i].Name = s then + begin + Result := True; + exit; + end; + GRFW(u); + end; + u := FunctionParamNames; + while Pos(tbtchar('|'), u) > 0 do + begin + if copy(u, 1, Pos(tbtchar('|'), u) - 1) = s then + begin + Result := True; + exit; + end; + Delete(u, 1, Pos(tbtchar('|'), u)); + end; + if Func = nil then + begin + result := False; + exit; + end; + for i := 0 to Func.ProcVars.Count -1 do + begin + if s = PIFPSProcVar(Func.ProcVars[I]).Name then + begin + Result := True; + exit; + end; + end; + for i := 0 to Func.FLabels.Count -1 do + begin + u := Func.FLabels[I]; + delete(u, 1, 4); + if u = s then + begin + Result := True; + exit; + end; + end; + Result := False; + end; +end; +procedure WriteProcVars(Func:TPSInternalProcedure; t: TPSList); +var + l: Longint; + v: PIFPSProcVar; +begin + for l := 0 to t.Count - 1 do + begin + v := t[l]; + Func.Data := Func.Data + chr(cm_pt)+ PS_mi2s(v.AType.FinalTypeNo); + end; +end; + + +function TPSPascalCompiler.ApplyAttribsToFunction(func: TPSProcedure): boolean; +var + i: Longint; +begin + for i := 0 to Func.Attributes.Count -1 do + begin + if @Func.Attributes.Items[i].AType.OnApplyAttributeToProc <> nil then + begin + if not Func.Attributes.Items[i].AType.OnApplyAttributeToProc(Self, Func, Func.Attributes.Items[i]) then + begin + Result := false; + exit; + end; + end; + end; + result := true; +end; + + +function TPSPascalCompiler.ProcessFunction(AlwaysForward: Boolean; Att: TPSAttributes): Boolean; +var + FunctionType: TFuncType; + OriginalName, FunctionName: tbtString; + FunctionParamNames: tbtString; + FunctionTempType: TPSType; + ParamNo: Cardinal; + FunctionDecl: TPSParametersDecl; + modifier: TPSParameterMode; + Func: TPSInternalProcedure; + F2: TPSProcedure; + EPos, ECol, ERow: Cardinal; + E2Pos, E2Col, E2Row: Cardinal; + pp: TPSRegProc; + pp2: TPSExternalProcedure; + FuncNo, I: Longint; + Block: TPSBlockInfo; +begin + if att = nil then + begin + Att := TPSAttributes.Create; + if not ReadAttributes(Att) then + begin + att.free; + Result := false; + exit; + end; + end; + + if FParser.CurrTokenId = CSTII_Procedure then + FunctionType := ftProc + else + FunctionType := ftFunc; + Func := nil; + EPos := FParser.CurrTokenPos; + ERow := FParser.Row; + ECol := FParser.Col; + FParser.Next; + Result := False; + if FParser.CurrTokenId <> CSTI_Identifier then + begin + MakeError('', ecIdentifierExpected, ''); + att.free; + exit; + end; + if assigned(FOnFunctionStart) then + {$IFDEF PS_USESSUPPORT} + FOnFunctionStart(fModule + '.' + FParser.OriginalToken, EPos, ERow, ECol); + {$ELSE} + FOnFunctionStart(FParser.OriginalToken, EPos, ERow, ECol); + {$ENDIF} + EPos := FParser.CurrTokenPos; + ERow := FParser.Row; + ECol := FParser.Col; + OriginalName := FParser.OriginalToken; + FunctionName := FParser.GetToken; + FuncNo := -1; + for i := 0 to FProcs.Count -1 do + begin + f2 := FProcs[I]; + if (f2.ClassType = TPSInternalProcedure) and (TPSInternalProcedure(f2).Name = FunctionName) and (TPSInternalProcedure(f2).Forwarded) then + begin + Func := FProcs[I]; + FuncNo := i; + Break; + end; + end; + if (Func = nil) and IsDuplicate(FunctionName, [dcTypes, dcProcs, dcVars, dcConsts]) then + begin + att.free; + MakeError('', ecDuplicateIdentifier, FunctionName); + exit; + end; + FParser.Next; + FunctionDecl := TPSParametersDecl.Create; + try + if FParser.CurrTokenId = CSTI_OpenRound then + begin + FParser.Next; + if FParser.CurrTokenId = CSTI_CloseRound then + begin + FParser.Next; + end + else + begin + if FunctionType = ftFunc then + ParamNo := 1 + else + ParamNo := 0; + while True do + begin + if FParser.CurrTokenId = CSTII_Const then + begin + modifier := pmIn; + FParser.Next; + end + else + if FParser.CurrTokenId = CSTII_Out then + begin + modifier := pmOut; + FParser.Next; + end + else + if FParser.CurrTokenId = CSTII_Var then + begin + modifier := pmInOut; + FParser.Next; + end + else + modifier := pmIn; + if FParser.CurrTokenId <> CSTI_Identifier then + begin + MakeError('', ecIdentifierExpected, ''); + exit; + end; + E2Pos := FParser.CurrTokenPos; + E2Row := FParser.Row; + E2Col := FParser.Col; + FunctionParamNames := ''; + if ProcIsDuplic(FunctionDecl, FunctionName, FunctionParamNames, FParser.GetToken, Func) then + begin + MakeError('', ecDuplicateIdentifier, FParser.OriginalToken); + exit; + end; + FunctionParamNames := FParser.OriginalToken + '|'; + if @FOnUseVariable <> nil then + begin + FOnUseVariable(Self, ivtParam, ParamNo, FProcs.Count, FParser.CurrTokenPos, ''); + end; + inc(ParamNo); + FParser.Next; + while FParser.CurrTokenId = CSTI_Comma do + begin + FParser.Next; + if FParser.CurrTokenId <> CSTI_Identifier then + begin + MakeError('', ecIdentifierExpected, ''); + exit; + end; + if ProcIsDuplic(FunctionDecl, FunctionName, FunctionParamNames, FParser.GetToken, Func) then + begin + MakeError('', ecDuplicateIdentifier, ''); + exit; + end; + if @FOnUseVariable <> nil then + begin + FOnUseVariable(Self, ivtParam, ParamNo, FProcs.Count, FParser.CurrTokenPos, ''); + end; + inc(ParamNo); + FunctionParamNames := FunctionParamNames + FParser.OriginalToken + + '|'; + FParser.Next; + end; + if FParser.CurrTokenId <> CSTI_Colon then + begin + MakeError('', ecColonExpected, ''); + exit; + end; + FParser.Next; + FunctionTempType := at2ut(ReadType('', FParser)); + if FunctionTempType = nil then + begin + exit; + end; + while Pos(tbtchar('|'), FunctionParamNames) > 0 do + begin + with FunctionDecl.AddParam do + begin + OrgName := copy(FunctionParamNames, 1, Pos(tbtchar('|'), FunctionParamNames) - 1); + Mode := modifier; + aType := FunctionTempType; + {$IFDEF PS_USESSUPPORT} + DeclareUnit:=fModule; + {$ENDIF} + DeclarePos:=E2Pos; + DeclareRow:=E2Row; + DeclareCol:=E2Col; + end; + Delete(FunctionParamNames, 1, Pos(tbtchar('|'), FunctionParamNames)); + end; + if FParser.CurrTokenId = CSTI_CloseRound then + break; + if FParser.CurrTokenId <> CSTI_Semicolon then + begin + MakeError('', ecSemicolonExpected, ''); + exit; + end; + FParser.Next; + end; + FParser.Next; + end; + end; + if FunctionType = ftFunc then + begin + if FParser.CurrTokenId <> CSTI_Colon then + begin + MakeError('', ecColonExpected, ''); + exit; + end; + FParser.Next; + FunctionTempType := at2ut(ReadType('', FParser)); + if FunctionTempType = nil then + exit; + FunctionDecl.Result := FunctionTempType; + end; + if FParser.CurrTokenId <> CSTI_Semicolon then + begin + MakeError('', ecSemicolonExpected, ''); + exit; + end; + FParser.Next; + if (Func = nil) and (FParser.CurrTokenID = CSTII_External) then + begin + FParser.Next; + if FParser.CurrTokenID <> CSTI_String then + begin + MakeError('', ecStringExpected, ''); + exit; + end; + FunctionParamNames := FParser.GetToken; + FunctionParamNames := copy(FunctionParamNames, 2, length(FunctionParamNames) - 2); + FParser.Next; + if FParser.CurrTokenID <> CSTI_Semicolon then + begin + MakeError('', ecSemicolonExpected, ''); + exit; + end; + FParser.Next; + if @FOnExternalProc = nil then + begin + MakeError('', ecSemicolonExpected, ''); + exit; + end; + pp := FOnExternalProc(Self, FunctionDecl, OriginalName, FunctionParamNames); + if pp = nil then + begin + MakeError('', ecCustomError, ''); + exit; + end; + pp2 := TPSExternalProcedure.Create; + pp2.Attributes.Assign(att, true); + pp2.RegProc := pp; + FProcs.Add(pp2); + FRegProcs.Add(pp); + Result := ApplyAttribsToFunction(pp2); + Exit; + end else if (FParser.CurrTokenID = CSTII_Forward) or AlwaysForward then + begin + if Func <> nil then + begin + MakeError('', ecBeginExpected, ''); + exit; + end; + if not AlwaysForward then + begin + FParser.Next; + if FParser.CurrTokenID <> CSTI_Semicolon then + begin + MakeError('', ecSemicolonExpected, ''); + Exit; + end; + FParser.Next; + end; + Func := NewProc(OriginalName, FunctionName); + Func.Attributes.Assign(Att, True); + Func.Forwarded := True; + {$IFDEF PS_USESSUPPORT} + Func.FDeclareUnit := fModule; + {$ENDIF} + Func.FDeclarePos := EPos; + Func.FDeclareRow := ERow; + Func.FDeclarePos := ECol; + Func.Decl.Assign(FunctionDecl); + Result := ApplyAttribsToFunction(Func); + exit; + end; + if (Func = nil) then + begin + Func := NewProc(OriginalName, FunctionName); + Func.Attributes.Assign(att, True); + Func.Decl.Assign(FunctionDecl); + {$IFDEF PS_USESSUPPORT} + Func.FDeclareUnit := fModule; + {$ENDIF} + Func.FDeclarePos := EPos; + Func.FDeclareRow := ERow; + Func.FDeclareCol := ECol; + FuncNo := FProcs.Count -1; + if not ApplyAttribsToFunction(Func) then + begin + result := false; + exit; + end; + end else begin + if not FunctionDecl.Same(Func.Decl) then + begin + MakeError('', ecForwardParameterMismatch, ''); + Result := false; + exit; + end; + Func.Forwarded := False; + end; + if FParser.CurrTokenID = CSTII_Export then + begin + FParser.Next; + if FParser.CurrTokenID <> CSTI_Semicolon then + begin + MakeError('', ecSemicolonExpected, ''); + exit; + end; + FParser.Next; + end; + while FParser.CurrTokenId <> CSTII_Begin do + begin + if FParser.CurrTokenId = CSTII_Var then + begin + if not DoVarBlock(Func) then + exit; + end else if FParser.CurrTokenId = CSTII_Label then + begin + if not ProcessLabel(Func) then + Exit; + end else + begin + MakeError('', ecBeginExpected, ''); + exit; + end; + end; + Debug_WriteParams(FuncNo, Func); + WriteProcVars(Func, Func.ProcVars); + Block := TPSBlockInfo.Create(FGlobalBlock); + Block.SubType := tProcBegin; + Block.ProcNo := FuncNo; + Block.Proc := Func; + if not ProcessSub(Block) then + begin + Block.Free; + exit; + end; + Block.Free; + CheckForUnusedVars(Func); + Result := ProcessLabelForwards(Func); + if assigned(FOnFunctionEnd) then + {$IFDEF PS_USESSUPPORT} + OnFunctionEnd(fModule + '.' + OriginalName, FParser.CurrTokenPos, FParser.Row, FParser.Col); + {$ELSE} + OnFunctionEnd(OriginalName, FParser.CurrTokenPos, FParser.Row, FParser.Col); + {$ENDIF} + finally + FunctionDecl.Free; + att.Free; + end; +end; + +function GetParamType(BlockInfo: TPSBlockInfo; I: Longint): TPSType; +begin + if BlockInfo.Proc.Decl.Result <> nil then dec(i); + if i = -1 then + Result := BlockInfo.Proc.Decl.Result + else + begin + Result := BlockInfo.Proc.Decl.Params[i].aType; + end; +end; + +function TPSPascalCompiler.GetTypeNo(BlockInfo: TPSBlockInfo; p: TPSValue): TPSType; +begin + if p.ClassType = TPSUnValueOp then + Result := TPSUnValueOp(p).aType + else if p.ClassType = TPSBinValueOp then + Result := TPSBinValueOp(p).aType + else if p.ClassType = TPSValueArray then + Result := at2ut(FindType('TVariantArray')) + else if p.ClassType = TPSValueData then + Result := TPSValueData(p).Data.FType + else if p is TPSValueProc then + Result := TPSValueProc(p).ResultType + else if (p is TPSValueVar) and (TPSValueVar(p).RecCount > 0) then + Result := TPSValueVar(p).RecItem[TPSValueVar(p).RecCount - 1].aType + else if p.ClassType = TPSValueGlobalVar then + Result := TPSVar(FVars[TPSValueGlobalVar(p).GlobalVarNo]).FType + else if p.ClassType = TPSValueParamVar then + Result := GetParamType(BlockInfo, TPSValueParamVar(p).ParamNo) + else if p is TPSValueLocalVar then + Result := TPSProcVar(BlockInfo.Proc.ProcVars[TPSValueLocalVar(p).LocalVarNo]).AType + else if p.classtype = TPSValueReplace then + Result := GetTypeNo(BlockInfo, TPSValueReplace(p).NewValue) + else + Result := nil; +end; + +function TPSPascalCompiler.IsVarInCompatible(ft1, ft2: TPSType): Boolean; +begin + ft1 := GetTypeCopyLink(ft1); + ft2 := GetTypeCopyLink(ft2); + Result := (ft1 <> ft2) and (ft2 <> nil); +end; + +function TPSPascalCompiler.ValidateParameters(BlockInfo: TPSBlockInfo; Params: TPSParameters; ParamTypes: TPSParametersDecl): boolean; +var + i, c: Longint; + pType: TPSType; + +begin + UseProc(ParamTypes); + c := 0; + for i := 0 to ParamTypes.ParamCount -1 do + begin + while (c < Longint(Params.Count)) and (Params[c].Val = nil) do + Inc(c); + if c >= Longint(Params.Count) then + begin + MakeError('', ecInvalidnumberOfParameters, ''); + Result := False; + exit; + end; + Params[c].ExpectedType := ParamTypes.Params[i].aType; + Params[c].ParamMode := ParamTypes.Params[i].Mode; + if ParamTypes.Params[i].Mode <> pmIn then + begin + if not (Params[c].Val is TPSValueVar) then + begin + with MakeError('', ecVariableExpected, '') do + begin + Row := Params[c].Val.Row; + Col := Params[c].Val.Col; + Pos := Params[c].Val.Pos; + end; + result := false; + exit; + end; + PType := Params[c].ExpectedType; + if (PType = nil) or ((PType.BaseType = btArray) and (TPSArrayType(PType).ArrayTypeNo = nil) and (GetTypeNo(BlockInfo, Params[c].Val).BaseType = btArray)) or + (PType = FAnyString) then + begin + Params[c].ExpectedType := GetTypeNo(BlockInfo, Params[c].Val); + if PType <> nil then + if (Params[c].ExpectedType = nil) or not (Params[c].ExpectedType.BaseType in [btString, btWideString, btUnicodeString, btChar, btWideChar]) then begin + MakeError('', ecTypeMismatch, ''); + Result := False; + exit; + end; + if Params[c].ExpectedType.BaseType = btChar then + Params[c].ExpectedType := FindBaseType(btString) else + if Params[c].ExpectedType.BaseType = btWideChar then + Params[c].ExpectedType := FindBaseType(btUnicodeString); + end else if (PType.BaseType = btArray) and (GetTypeNo(BlockInfo, Params[c].Val).BaseType = btArray) then + begin + if TPSArrayType(GetTypeNo(BlockInfo, Params[c].Val)).ArrayTypeNo <> TPSArrayType(PType).ArrayTypeNo then + begin + MakeError('', ecTypeMismatch, ''); + Result := False; + exit; + end; + end else if IsVarInCompatible(PType, GetTypeNo(BlockInfo, Params[c].Val)) then + begin + MakeError('', ecTypeMismatch, ''); + Result := False; + exit; + end; + end; + Inc(c); + end; + for i := c to Params.Count -1 do + begin + if Params[i].Val <> nil then + begin + MakeError('', ecInvalidnumberOfParameters, ''); + Result := False; + exit; + end; + end; + Result := true; +end; + +function TPSPascalCompiler.DoTypeBlock(FParser: TPSPascalParser): Boolean; +var + VOrg,VName: tbtString; + Attr: TPSAttributes; + FType: TPSType; + i: Longint; +begin + Result := False; + FParser.Next; + repeat + Attr := TPSAttributes.Create; + if not ReadAttributes(Attr) then + begin + Attr.Free; + exit; + end; + if (FParser.CurrTokenID = CSTII_Procedure) or (FParser.CurrTokenID = CSTII_Function) then + begin + Result := ProcessFunction(false, Attr); + exit; + end; + if FParser.CurrTokenId <> CSTI_Identifier then + begin + MakeError('', ecIdentifierExpected, ''); + Attr.Free; + exit; + end; + + VName := FParser.GetToken; + VOrg := FParser.OriginalToken; + if IsDuplicate(VName, [dcTypes, dcProcs, dcVars]) then + begin + MakeError('', ecDuplicateIdentifier, FParser.OriginalToken); + Attr.Free; + exit; + end; + + FParser.Next; + if FParser.CurrTokenId <> CSTI_Equal then + begin + MakeError('', ecIsExpected, ''); + Attr.Free; + exit; + end; + FParser.Next; + FType := ReadType(VOrg, FParser); + if Ftype = nil then + begin + Attr.Free; + Exit; + end; + FType.Attributes.Assign(Attr, True); + for i := 0 to FType.Attributes.Count -1 do + begin + if @FType.Attributes[i].FAttribType.FAAType <> nil then + FType.Attributes[i].FAttribType.FAAType(Self, FType, Attr[i]); + end; + Attr.Free; + if FParser.CurrTokenID <> CSTI_Semicolon then + begin + MakeError('', ecSemicolonExpected, ''); + Exit; + end; + FParser.Next; + until (FParser.CurrTokenId <> CSTI_Identifier) and (FParser.CurrTokenID <> CSTI_OpenBlock); + Result := True; +end; + +procedure TPSPascalCompiler.Debug_WriteLine(BlockInfo: TPSBlockInfo); +var + b: Boolean; +begin + if @FOnWriteLine <> nil then begin + {$IFNDEF PS_USESSUPPORT} + b := FOnWriteLine(Self, FParser.CurrTokenPos); + {$ELSE} + b := FOnWriteLine(Self, FModule, FParser.CurrTokenPos); + {$ENDIF} + end else + b := true; + if b then Debug_SavePosition(BlockInfo.ProcNo, BlockInfo.Proc); +end; + + +function TPSPascalCompiler.ReadReal(const s: tbtString): PIfRVariant; +var + C: Integer; +begin + New(Result); + InitializeVariant(Result, FindBaseType(btExtended)); + Val(string(s), Result^.textended, C); +end; + +function TPSPascalCompiler.ReadString: PIfRVariant; +{$IFNDEF PS_NOWIDESTRING}var wchar: Boolean;{$ENDIF} + + function ParseString({$IFNDEF PS_NOWIDESTRING}var res: tbtunicodestring{$ELSE}var res: tbtString{$ENDIF}): Boolean; + var + temp3: {$IFNDEF PS_NOWIDESTRING}tbtunicodestring{$ELSE}tbtString{$ENDIF}; + + function ChrToStr(s: tbtString): {$IFNDEF PS_NOWIDESTRING}widechar{$ELSE}tbtchar{$ENDIF}; + var + w: Longint; + begin + Delete(s, 1, 1); {First char : #} + w := StrToInt(s); + Result := {$IFNDEF PS_NOWIDESTRING}widechar{$ELSE}tbtchar{$ENDIF}(w); + {$IFNDEF PS_NOWIDESTRING}if w > $FF then wchar := true;{$ENDIF} + end; + + function PString(s: tbtString): tbtString; + var + i: Longint; + begin + s := copy(s, 2, Length(s) - 2); + i := length(s); + while i > 0 do + begin + if (i < length(s)) and (s[i] = #39) and (s[i + 1] = #39) then + begin + Delete(s, i, 1); + dec(i); + end; + dec(i); + end; + PString := s; + end; + var + lastwasstring: Boolean; + begin + temp3 := ''; + while (FParser.CurrTokenId = CSTI_String) or (FParser.CurrTokenId = CSTI_Char) do + begin + lastwasstring := FParser.CurrTokenId = CSTI_String; + if FParser.CurrTokenId = CSTI_String then + begin + if UTF8Decode then + begin + temp3 := temp3 + {$IFNDEF PS_NOWIDESTRING}{$IFDEF DELPHI6UP}System.{$IFDEF DELPHI2009UP}UTF8ToWidestring{$ELSE}UTF8Decode{$ENDIF}{$ENDIF}{$ENDIF}(PString(FParser.GetToken)); + {$IFNDEF PS_NOWIDESTRING}wchar:=true;{$ENDIF} + end else + temp3 := temp3 + tbtUnicodestring(PString(FParser.GetToken)); + + FParser.Next; + if FParser.CurrTokenId = CSTI_String then + temp3 := temp3 + #39; + end {if} + else + begin + temp3 := temp3 + ChrToStr(FParser.GetToken); + FParser.Next; + end; {else if} + if lastwasstring and (FParser.CurrTokenId = CSTI_String) then + begin + MakeError('', ecSyntaxError, ''); + result := false; + exit; + end; + end; {while} + res := temp3; + result := true; + end; +var +{$IFNDEF PS_NOWIDESTRING} + w: tbtunicodestring; +{$ENDIF} + s: tbtString; +begin + {$IFNDEF PS_NOWIDESTRING}wchar:=false;{$ENDIF} + if not ParseString({$IFDEF PS_NOWIDESTRING} s {$ELSE} w {$ENDIF}) then + begin + result := nil; + exit; + end; +{$IFNDEF PS_NOWIDESTRING} + if wchar then + begin + New(Result); + if Length(w) = 1 then + begin + InitializeVariant(Result, at2ut(FindBaseType(btwidechar))); + Result^.twidechar := w[1]; + end else begin + InitializeVariant(Result, at2ut(FindBaseType(btUnicodeString))); + tbtunicodestring(Result^.tunistring) := w; + end; + end else begin + s := tbtstring(w); +{$ENDIF} + New(Result); + if Length(s) = 1 then + begin + InitializeVariant(Result, at2ut(FindBaseType(btchar))); + Result^.tchar := s[1]; + end else begin + InitializeVariant(Result, at2ut(FindBaseType(btstring))); + tbtstring(Result^.tstring) := s; + end; +{$IFNDEF PS_NOWIDESTRING} + end; +{$ENDIF} +end; + + +function TPSPascalCompiler.ReadInteger(const s: tbtString): PIfRVariant; +var + R: {$IFNDEF PS_NOINT64}Int64;{$ELSE}Longint;{$ENDIF} +begin + New(Result); +{$IFNDEF PS_NOINT64} + r := StrToInt64Def(string(s), 0); + if (r >= Low(Integer)) and (r <= High(Integer)) then + begin + InitializeVariant(Result, at2ut(FindBaseType(bts32))); + Result^.ts32 := r; + end else if (r <= $FFFFFFFF) then + begin + InitializeVariant(Result, at2ut(FindBaseType(btu32))); + Result^.tu32 := r; + end else + begin + InitializeVariant(Result, at2ut(FindBaseType(bts64))); + Result^.ts64 := r; + end; +{$ELSE} + r := StrToIntDef(s, 0); + InitializeVariant(Result, at2ut(FindBaseType(bts32))); + Result^.ts32 := r; +{$ENDIF} +end; + +function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean; + + function AllocStackReg2(MType: TPSType): TPSValue; + var + x: TPSProcVar; + begin +{$IFDEF DEBUG} + if (mtype = nil) or (not mtype.Used) then asm int 3; end; +{$ENDIF} + x := TPSProcVar.Create; + {$IFDEF PS_USESSUPPORT} + x.DeclareUnit:=fModule; + {$ENDIF} + x.DeclarePos := FParser.CurrTokenPos; + x.DeclareRow := FParser.Row; + x.DeclareCol := FParser.Col; + x.Name := ''; + x.AType := MType; + x.Use; + BlockInfo.Proc.ProcVars.Add(x); + Result := TPSValueAllocatedStackVar.Create; + Result.SetParserPos(FParser); + TPSValueAllocatedStackVar(Result).Proc := BlockInfo.Proc; + with TPSValueAllocatedStackVar(Result) do + begin + LocalVarNo := proc.ProcVars.Count -1; + end; + end; + + function AllocStackReg(MType: TPSType): TPSValue; + begin + Result := AllocStackReg2(MType); + BlockWriteByte(BlockInfo, Cm_Pt); + BlockWriteLong(BlockInfo, MType.FinalTypeNo); + end; + + function AllocPointer(MDestType: TPSType): TPSValue; + begin + Result := AllocStackReg(at2ut(FindBaseType(btPointer))); + TPSProcVar(BlockInfo.Proc.ProcVars[TPSValueAllocatedStackVar(Result).LocalVarNo]).AType := MDestType; + end; + + function WriteCalculation(InData, OutReg: TPSValue): Boolean; forward; + function PreWriteOutRec(var X: TPSValue; FArrType: TPSType): Boolean; forward; + function WriteOutRec(x: TPSValue; AllowData: Boolean): Boolean; forward; + procedure AfterWriteOutRec(var x: TPSValue); forward; + + function CheckCompatType(V1, v2: TPSValue): Boolean; + var + p1, P2: TPSType; + begin + p1 := GetTypeNo(BlockInfo, V1); + P2 := GetTypeNo(BlockInfo, v2); + if (p1 = nil) or (p2 = nil) then + begin + if ((p1 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p1.ClassType = TPSInterfaceType) or {$ENDIF}(p1.BaseType = btProcPtr)) and (v2.ClassType = TPSValueNil)) or + ((p2 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p2.ClassType = TPSInterfaceType) or {$ENDIF}(p2.BaseType = btProcPtr)) and (v1.ClassType = TPSValueNil)) then + begin + Result := True; + exit; + end else + if ((p1 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p1.ClassType = TPSInterfaceType) or {$ENDIF}(p1.ClassType = TPSClassType)) and (v2.ClassType = TPSValueNil)) or + ((p2 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p2.ClassType = TPSInterfaceType) or {$ENDIF}(p2.ClassType = TPSClassType)) and (v1.ClassType = TPSValueNil)) then + begin + Result := True; + exit; + end else + if ((p1 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p1.ClassType = TPSInterfaceType) or {$ENDIF}(p1.ClassType = TPSUndefinedClassType)) and (v2.ClassType = TPSValueNil)) or + ((p2 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p2.ClassType = TPSInterfaceType) or {$ENDIF}(p2.ClassType = TPSUndefinedClassType)) and (v1.ClassType = TPSValueNil)) then + begin + Result := True; + exit; + end else + if (v1.ClassType = TPSValueProcPtr) and (p2 <> nil) and (p2.BaseType = btProcPtr) then + begin + Result := CheckCompatProc(p2, TPSValueProcPtr(v1).ProcPtr); + exit; + end else if (v2.ClassType = TPSValueProcPtr) and (p1 <> nil) and (p1.BaseType = btProcPtr) then + begin + Result := CheckCompatProc(p1, TPSValueProcPtr(v2).ProcPtr); + exit; + end; + Result := False; + end else + if (p1 <> nil) and (p1.BaseType = btSet) and (v2 is TPSValueArray) then + begin + Result := True; + end else + Result := IsCompatibleType(p1, p2, False); + end; + + function _ProcessFunction(ProcCall: TPSValueProc; ResultRegister: TPSValue): Boolean; forward; + function ProcessFunction2(ProcNo: Cardinal; Par: TPSParameters; ResultReg: TPSValue): Boolean; + var + Temp: TPSValueProcNo; + i: Integer; + begin + Temp := TPSValueProcNo.Create; + Temp.Parameters := Par; + Temp.ProcNo := ProcNo; + if TObject(FProcs[ProcNo]).ClassType = TPSInternalProcedure then + Temp.ResultType := TPSInternalProcedure(FProcs[ProcNo]).Decl.Result + else + Temp.ResultType := TPSExternalProcedure(FProcs[ProcNo]).RegProc.Decl.Result; + if (Temp.ResultType <> nil) and (Temp.ResultType = FAnyString) then begin // workaround to make the result type match + for i := 0 to Par.Count -1 do begin + if Par[i].ExpectedType.BaseType in [btString, btWideString] then + Temp.ResultType := Par[i].ExpectedType; + end; + end; + Result := _ProcessFunction(Temp, ResultReg); + Temp.Parameters := nil; + Temp.Free; + end; + + function MakeNil(NilPos, NilRow, nilCol: Cardinal;ivar: TPSValue): Boolean; + var + Procno: Cardinal; + PF: TPSType; + Par: TPSParameters; + begin + Pf := GetTypeNo(BlockInfo, IVar); + if not (Ivar is TPSValueVar) then + begin + with MakeError('', ecTypeMismatch, '') do + begin + FPosition := nilPos; + FRow := NilRow; + FCol := nilCol; + end; + Result := False; + exit; + end; + if (pf.BaseType = btProcPtr) then + begin + Result := True; + end else + if (pf.BaseType = btString) or (pf.BaseType = btPChar) then + begin + if not PreWriteOutRec(iVar, nil) then + begin + Result := false; + exit; + end; + BlockWriteByte(BlockInfo, CM_A); + WriteOutRec(ivar, False); + BlockWriteByte(BlockInfo, 1); + BlockWriteLong(BlockInfo, GetTypeNo(BlockInfo, IVar).FinalTypeNo); + BlockWriteLong(BlockInfo, 0); //empty tbtString + AfterWriteOutRec(ivar); + Result := True; + end else if (pf.BaseType = btClass) {$IFNDEF PS_NOINTERFACES}or (pf.BaseType = btInterface){$ENDIF} then + begin +{$IFNDEF PS_NOINTERFACES} + if (pf.BaseType = btClass) then + begin +{$ENDIF} + if not TPSClassType(pf).Cl.SetNil(ProcNo) then + begin + with MakeError('', ecTypeMismatch, '') do + begin + FPosition := nilPos; + FRow := NilRow; + FCol := nilCol; + end; + Result := False; + exit; + end; +{$IFNDEF PS_NOINTERFACES} + end else + begin + if not TPSInterfaceType(pf).Intf.SetNil(ProcNo) then + begin + with MakeError('', ecTypeMismatch, '') do + begin + FPosition := nilPos; + FRow := NilRow; + FCol := nilCol; + end; + Result := False; + exit; + end; + end; +{$ENDIF} + Par := TPSParameters.Create; + with par.Add do + begin + Val := IVar; + ExpectedType := GetTypeNo(BlockInfo, ivar); +{$IFDEF DEBUG} + if not ExpectedType.Used then asm int 3; end; +{$ENDIF} + ParamMode := pmInOut; + end; + Result := ProcessFunction2(ProcNo, Par, nil); + + Par[0].Val := nil; // don't free IVAR + + Par.Free; + end else if pf.BaseType = btExtClass then + begin + if not TPSUndefinedClassType(pf).ExtClass.SetNil(ProcNo) then + begin + with MakeError('', ecTypeMismatch, '') do + begin + FPosition := nilPos; + FRow := NilRow; + FCol := nilCol; + end; + Result := False; + exit; + end; + Par := TPSParameters.Create; + with par.Add do + begin + Val := IVar; + ExpectedType := GetTypeNo(BlockInfo, ivar); + ParamMode := pmInOut; + end; + Result := ProcessFunction2(ProcNo, Par, nil); + + Par[0].Val := nil; // don't free IVAR + + Par.Free; + end else begin + with MakeError('', ecTypeMismatch, '') do + begin + FPosition := nilPos; + FRow := NilRow; + FCol := nilCol; + end; + Result := False; + end; + end; + function DoBinCalc(BVal: TPSBinValueOp; Output: TPSValue): Boolean; + var + tmpp, tmpc: TPSValue; + jend, jover: Cardinal; + procno: Cardinal; + + begin + if BVal.Operator >= otGreaterEqual then + begin + if BVal.FVal1.ClassType = TPSValueNil then + begin + tmpp := AllocStackReg(GetTypeNo(BlockInfo, BVal.FVal2)); + if not MakeNil(BVal.FVal1.Pos, BVal.FVal1.Row, BVal.FVal1.Col, tmpp) then + begin + tmpp.Free; + Result := False; + exit; + end; + tmpc := TPSValueReplace.Create; + with TPSValueReplace(tmpc) do + begin + OldValue := BVal.FVal1; + NewValue := tmpp; + end; + BVal.FVal1 := tmpc; + end; + if BVal.FVal2.ClassType = TPSValueNil then + begin + tmpp := AllocStackReg(GetTypeNo(BlockInfo, BVal.FVal1)); + if not MakeNil(BVal.FVal2.Pos, BVal.FVal2.Row, BVal.FVal2.Col, tmpp) then + begin + tmpp.Free;; + Result := False; + exit; + end; + tmpc := TPSValueReplace.Create; + with TPSValueReplace(tmpc) do + begin + OldValue := BVal.FVal2; + NewValue := tmpp; + end; + BVal.FVal2 := tmpc; + end; + if GetTypeNo(BlockInfo, BVal.FVal1).BaseType = btExtClass then + begin + if not TPSUndefinedClassType(GetTypeNo(BlockInfo, BVal.FVal1)).ExtClass.CompareClass(GetTypeNo(BlockInfo, Bval.FVal2), ProcNo) then + begin + Result := False; + exit; + end; + tmpp := TPSValueProcNo.Create; + with TPSValueProcNo(tmpp) do + begin + ResultType := at2ut(FDefaultBoolType); + Parameters := TPSParameters.Create; + ProcNo := procno; + Pos := BVal.Pos; + Col := BVal.Col; + Row := BVal.Row; + with parameters.Add do + begin + Val := BVal.FVal1; + ExpectedType := GetTypeNo(BlockInfo, Val); + end; + with parameters.Add do + begin + Val := BVal.FVal2; + ExpectedType := GetTypeNo(BlockInfo, Val); + end; + end; + if Bval.Operator = otNotEqual then + begin + tmpc := TPSUnValueOp.Create; + TPSUnValueOp(tmpc).Operator := otNot; + TPSUnValueOp(tmpc).Val1 := tmpp; + TPSUnValueOp(tmpc).aType := GetTypeNo(BlockInfo, tmpp); + end else tmpc := tmpp; + Result := WriteCalculation(tmpc, Output); + with TPSValueProcNo(tmpp) do + begin + Parameters[0].Val := nil; + Parameters[1].Val := nil; + end; + tmpc.Free; + if BVal.Val1.ClassType = TPSValueReplace then + begin + tmpp := TPSValueReplace(BVal.Val1).OldValue; + BVal.Val1.Free; + BVal.Val1 := tmpp; + end; + if BVal.Val2.ClassType = TPSValueReplace then + begin + tmpp := TPSValueReplace(BVal.Val2).OldValue; + BVal.Val2.Free; + BVal.Val2 := tmpp; + end; + exit; + end; + if not (PreWriteOutRec(Output, nil) and PreWriteOutRec(BVal.FVal1, GetTypeNo(BlockInfo, BVal.FVal2)) and PreWriteOutRec(BVal.FVal2, GetTypeNo(BlockInfo, BVal.FVal1))) then + begin + Result := False; + exit; + end; + BlockWriteByte(BlockInfo, CM_CO); + case BVal.Operator of + otGreaterEqual: BlockWriteByte(BlockInfo, 0); + otLessEqual: BlockWriteByte(BlockInfo, 1); + otGreater: BlockWriteByte(BlockInfo, 2); + otLess: BlockWriteByte(BlockInfo, 3); + otEqual: BlockWriteByte(BlockInfo, 5); + otNotEqual: BlockWriteByte(BlockInfo, 4); + otIn: BlockWriteByte(BlockInfo, 6); + otIs: BlockWriteByte(BlockInfo, 7); + end; + + if not (WriteOutRec(Output, False) and writeOutRec(BVal.FVal1, True) and writeOutRec(BVal.FVal2, True)) then + begin + Result := False; + exit; + end; + AfterWriteOutrec(BVal.FVal1); + AfterWriteOutrec(BVal.FVal2); + AfterWriteOutrec(Output); + if BVal.Val1.ClassType = TPSValueReplace then + begin + tmpp := TPSValueReplace(BVal.Val1).OldValue; + BVal.Val1.Free; + BVal.Val1 := tmpp; + end; + if BVal.Val2.ClassType = TPSValueReplace then + begin + tmpp := TPSValueReplace(BVal.Val2).OldValue; + BVal.Val2.Free; + BVal.Val2 := tmpp; + end; + end else begin + if not PreWriteOutRec(Output, nil) then + begin + Result := False; + exit; + end; + if not SameReg(Output, BVal.Val1) then + begin + if not WriteCalculation(BVal.FVal1, Output) then + begin + Result := False; + exit; + end; + end; + if (FBooleanShortCircuit) and (IsBoolean(BVal.aType)) then + begin + if BVal.Operator = otAnd then + begin + BlockWriteByte(BlockInfo, Cm_CNG); + jover := Length(BlockInfo.Proc.FData); + BlockWriteLong(BlockInfo, 0); + WriteOutRec(Output, True); + jend := Length(BlockInfo.Proc.FData); + end else if BVal.Operator = otOr then + begin + BlockWriteByte(BlockInfo, Cm_CG); + jover := Length(BlockInfo.Proc.FData); + BlockWriteLong(BlockInfo, 0); + WriteOutRec(Output, True); + jend := Length(BlockInfo.Proc.FData); + end else + begin + jover := 0; + jend := 0; + end; + end else + begin + jover := 0; + jend := 0; + end; + if not PreWriteOutrec(BVal.FVal2, GetTypeNo(BlockInfo, Output)) then + begin + Result := False; + exit; + end; + BlockWriteByte(BlockInfo, Cm_CA); + BlockWriteByte(BlockInfo, Ord(BVal.Operator)); + if not (WriteOutRec(Output, False) and WriteOutRec(BVal.FVal2, True)) then + begin + Result := False; + exit; + end; + AfterWriteOutRec(BVal.FVal2); + if FBooleanShortCircuit and (IsBoolean(BVal.aType)) and (JOver <> JEnd) then + begin + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + unaligned(Cardinal((@BlockInfo.Proc.FData[jover+1])^)) := Cardinal(Length(BlockInfo.Proc.FData)) - jend; + {$else} + Cardinal((@BlockInfo.Proc.FData[jover+1])^) := Cardinal(Length(BlockInfo.Proc.FData)) - jend; + {$endif} + end; + AfterWriteOutRec(Output); + end; + Result := True; + end; + + function DoUnCalc(Val: TPSUnValueOp; Output: TPSValue): Boolean; + var + Tmp: TPSValue; + begin + if not PreWriteOutRec(Output, nil) then + begin + Result := False; + exit; + end; + case Val.Operator of + otNot: + begin + if not SameReg(Val.FVal1, Output) then + begin + if not WriteCalculation(Val.FVal1, Output) then + begin + Result := False; + exit; + end; + end; + if IsBoolean(GetTypeNo(BlockInfo, Val)) then + BlockWriteByte(BlockInfo, cm_bn) + else + BlockWriteByte(BlockInfo, cm_in); + if not WriteOutRec(Output, True) then + begin + Result := False; + exit; + end; + end; + otMinus: + begin + if not SameReg(Val.FVal1, Output) then + begin + if not WriteCalculation(Val.FVal1, Output) then + begin + Result := False; + exit; + end; + end; + BlockWriteByte(BlockInfo, cm_vm); + if not WriteOutRec(Output, True) then + begin + Result := False; + exit; + end; + end; + otCast: + begin + if ((Val.aType.BaseType = btChar) and (Val.aType.BaseType <> btU8)) {$IFNDEF PS_NOWIDESTRING}or + ((Val.aType.BaseType = btWideChar) and (Val.aType.BaseType <> btU16)){$ENDIF} then + begin + Tmp := AllocStackReg(Val.aType); + end else + Tmp := Output; + if not (PreWriteOutRec(Val.FVal1, GetTypeNo(BlockInfo, Tmp)) and PreWriteOutRec(Tmp, GetTypeNo(BlockInfo, Tmp))) then + begin + Result := False; + if tmp <> Output then Tmp.Free; + exit; + end; + BlockWriteByte(BlockInfo, CM_A); + if not (WriteOutRec(Tmp, False) and WriteOutRec(Val.FVal1, True)) then + begin + Result := false; + if tmp <> Output then Tmp.Free; + exit; + end; + AfterWriteOutRec(val.Fval1); + if Tmp <> Output then + begin + if not WriteCalculation(Tmp, Output) then + begin + Result := false; + Tmp.Free; + exit; + end; + end; + AfterWriteOutRec(Tmp); + if Tmp <> Output then + Tmp.Free; + end; + {else donothing} + end; + AfterWriteOutRec(Output); + Result := True; + end; + + + function GetAddress(Val: TPSValue): Cardinal; + begin + if Val.ClassType = TPSValueGlobalVar then + Result := TPSValueGlobalVar(val).GlobalVarNo + else if Val.ClassType = TPSValueLocalVar then + Result := PSAddrStackStart + TPSValueLocalVar(val).LocalVarNo + 1 + else if Val.ClassType = TPSValueParamVar then + Result := PSAddrStackStart - TPSValueParamVar(val).ParamNo -1 + else if Val.ClassType = TPSValueAllocatedStackVar then + Result := PSAddrStackStart + TPSValueAllocatedStackVar(val).LocalVarNo + 1 + else + Result := InvalidVal; + end; + + + function PreWriteOutRec(var X: TPSValue; FArrType: TPSType): Boolean; + var + rr: TPSSubItem; + tmpp, + tmpc: TPSValue; + i: Longint; + function MakeSet(SetType: TPSSetType; arr: TPSValueArray): Boolean; + var + c, i: Longint; + dataval: TPSValueData; + mType: TPSType; + begin + Result := True; + dataval := TPSValueData.Create; + dataval.Data := NewVariant(FarrType); + for i := 0 to arr.count -1 do + begin + mType := GetTypeNo(BlockInfo, arr.Item[i]); + if mType <> SetType.SetType then + begin + with MakeError('', ecTypeMismatch, '') do + begin + FCol := arr.item[i].Col; + FRow := arr.item[i].Row; + FPosition := arr.item[i].Pos; + end; + DataVal.Free; + Result := False; + exit; + end; + if arr.Item[i] is TPSValueData then + begin + c := GetInt(TPSValueData(arr.Item[i]).Data, Result); + if not Result then + begin + dataval.Free; + exit; + end; + Set_MakeMember(c, dataval.Data.tstring); + end else + begin + DataVal.Free; + MakeError('', ecTypeMismatch, ''); + Result := False; + exit; + end; + end; + tmpc := TPSValueReplace.Create; + with TPSValueReplace(tmpc) do + begin + OldValue := x; + NewValue := dataval; + PreWriteAllocated := True; + end; + x := tmpc; + end; + begin + Result := True; + if x.ClassType = TPSValueReplace then + begin + if TPSValueReplace(x).PreWriteAllocated then + begin + inc(TPSValueReplace(x).FReplaceTimes); + end; + end else + if x.ClassType = TPSValueProcPtr then + begin + if FArrType = nil then + begin + MakeError('', ecTypeMismatch, ''); + Result := False; + Exit; + end; + tmpp := TPSValueData.Create; + TPSValueData(tmpp).Data := NewVariant(FArrType); + TPSValueData(tmpp).Data.tu32 := TPSValueProcPtr(x).ProcPtr; + tmpc := TPSValueReplace.Create; + with TPSValueReplace(tmpc) do + begin + PreWriteAllocated := True; + OldValue := x; + NewValue := tmpp; + end; + x := tmpc; + end else + if x.ClassType = TPSValueNil then + begin + if FArrType = nil then + begin + MakeError('', ecTypeMismatch, ''); + Result := False; + Exit; + end; + tmpp := AllocStackReg(FArrType); + if not MakeNil(x.Pos, x.Row, x.Col, tmpp) then + begin + tmpp.Free; + Result := False; + exit; + end; + tmpc := TPSValueReplace.Create; + with TPSValueReplace(tmpc) do + begin + PreWriteAllocated := True; + OldValue := x; + NewValue := tmpp; + end; + x := tmpc; + end else + if x.ClassType = TPSValueArray then + begin + if FArrType = nil then + begin + MakeError('', ecTypeMismatch, ''); + Result := False; + Exit; + end; + if TPSType(FArrType).BaseType = btSet then + begin + Result := MakeSet(TPSSetType(FArrType), TPSValueArray(x)); + exit; + end; + if TPSType(FarrType).BaseType = btVariant then + FArrType := FindAndAddType(self, '', 'array of variant'); + if TPSType(FarrType).BaseType <> btArray then + FArrType := FindAndAddType(self, '', 'array of variant'); + + tmpp := AllocStackReg(FArrType); + tmpc := AllocStackReg(FindBaseType(bts32)); + BlockWriteByte(BlockInfo, CM_A); + WriteOutrec(tmpc, False); + BlockWriteByte(BlockInfo, 1); + BlockWriteLong(BlockInfo, FindBaseType(bts32).FinalTypeNo); + BlockWriteLong(BlockInfo, TPSValueArray(x).Count); + BlockWriteByte(BlockInfo, CM_PV); + WriteOutrec(tmpp, False); + BlockWriteByte(BlockInfo, CM_C); + BlockWriteLong(BlockInfo, FindProc('SETARRAYLENGTH')); + BlockWriteByte(BlockInfo, CM_PO); + tmpc.Free; + rr := TPSSubNumber.Create; + rr.aType := TPSArrayType(FArrType).ArrayTypeNo; + TPSValueVar(tmpp).RecAdd(rr); + for i := 0 to TPSValueArray(x).Count -1 do + begin + TPSSubNumber(rr).SubNo := i; + tmpc := TPSValueArray(x).Item[i]; + if not PreWriteOutRec(tmpc, GetTypeNo(BlockInfo, tmpc)) then + begin + tmpp.Free; + Result := false; + exit; + end; + if TPSArrayType(FArrType).ArrayTypeNo.BaseType = btPointer then + BlockWriteByte(BlockInfo, cm_spc) + else + BlockWriteByte(BlockInfo, cm_a); + if not (WriteOutrec(tmpp, False) and WriteOutRec(tmpc, True)) then + begin + Tmpp.Free; + Result := false; + exit; + end; + AfterWriteOutRec(tmpc); + end; + TPSValueVar(tmpp).RecDelete(0); + tmpc := TPSValueReplace.Create; + with TPSValueReplace(tmpc) do + begin + PreWriteAllocated := True; + OldValue := x; + NewValue := tmpp; + end; + x := tmpc; + end else if (x.ClassType = TPSUnValueOp) then + begin + tmpp := AllocStackReg(GetTypeNo(BlockInfo, x)); + if not DoUnCalc(TPSUnValueOp(x), tmpp) then + begin + Result := False; + exit; + end; + tmpc := TPSValueReplace.Create; + with TPSValueReplace(tmpc) do + begin + PreWriteAllocated := True; + OldValue := x; + NewValue := tmpp; + end; + x := tmpc; + end else if (x.ClassType = TPSBinValueOp) then + begin + tmpp := AllocStackReg(GetTypeNo(BlockInfo, x)); + if not DoBinCalc(TPSBinValueOp(x), tmpp) then + begin + tmpp.Free; + Result := False; + exit; + end; + tmpc := TPSValueReplace.Create; + with TPSValueReplace(tmpc) do + begin + PreWriteAllocated := True; + OldValue := x; + NewValue := tmpp; + end; + x := tmpc; + end else if x is TPSValueProc then + begin + tmpp := AllocStackReg(TPSValueProc(x).ResultType); + if not WriteCalculation(x, tmpp) then + begin + tmpp.Free; + Result := False; + exit; + end; + tmpc := TPSValueReplace.Create; + with TPSValueReplace(tmpc) do + begin + PreWriteAllocated := True; + OldValue := x; + NewValue := tmpp; + end; + x := tmpc; + end else if (x is TPSValueVar) and (TPSValueVar(x).RecCount <> 0) then + begin + if TPSValueVar(x).RecCount = 1 then + begin + rr := TPSValueVar(x).RecItem[0]; + if rr.ClassType <> TPSSubValue then + exit; // there is no need pre-calculate anything + if (TPSSubValue(rr).SubNo is TPSValueVar) and (TPSValueVar(TPSSubValue(rr).SubNo).RecCount = 0) then + exit; + end; //if + tmpp := AllocPointer(GetTypeNo(BlockInfo, x)); + BlockWriteByte(BlockInfo, cm_sp); + WriteOutRec(tmpp, True); + BlockWriteByte(BlockInfo, 0); + BlockWriteLong(BlockInfo, GetAddress(x)); + for i := 0 to TPSValueVar(x).RecCount - 1 do + begin + rr := TPSValueVar(x).RecItem[I]; + if rr.ClassType = TPSSubNumber then + begin + BlockWriteByte(BlockInfo, cm_sp); + WriteOutRec(tmpp, false); + BlockWriteByte(BlockInfo, 2); + BlockWriteLong(BlockInfo, GetAddress(tmpp)); + BlockWriteLong(BlockInfo, TPSSubNumber(rr).SubNo); + end else begin // if rr.classtype = TPSSubValue then begin + tmpc := AllocStackReg(FindBaseType(btU32)); + if not WriteCalculation(TPSSubValue(rr).SubNo, tmpc) then + begin + tmpc.Free; + tmpp.Free; + Result := False; + exit; + end; //if + BlockWriteByte(BlockInfo, cm_sp); + WriteOutRec(tmpp, false); + BlockWriteByte(BlockInfo, 3); + BlockWriteLong(BlockInfo, GetAddress(tmpp)); + BlockWriteLong(BlockInfo, GetAddress(tmpc)); + tmpc.Free; + end; + end; // for + tmpc := TPSValueReplace.Create; + with TPSValueReplace(tmpc) do + begin + OldValue := x; + NewValue := tmpp; + PreWriteAllocated := True; + end; + x := tmpc; + end; + + end; + + procedure AfterWriteOutRec(var x: TPSValue); + var + tmp: TPSValue; + begin + if (x.ClassType = TPSValueReplace) and (TPSValueReplace(x).PreWriteAllocated) then + begin + Dec(TPSValueReplace(x).FReplaceTimes); + if TPSValueReplace(x).ReplaceTimes = 0 then + begin + tmp := TPSValueReplace(x).OldValue; + x.Free; + x := tmp; + end; + end; + end; //afterwriteoutrec + + function WriteOutRec(x: TPSValue; AllowData: Boolean): Boolean; + var + rr: TPSSubItem; + begin + Result := True; + if x.ClassType = TPSValueReplace then + Result := WriteOutRec(TPSValueReplace(x).NewValue, AllowData) + else if x is TPSValueVar then + begin + if TPSValueVar(x).RecCount = 0 then + begin + BlockWriteByte(BlockInfo, 0); + BlockWriteLong(BlockInfo, GetAddress(x)); + end + else + begin + rr := TPSValueVar(x).RecItem[0]; + if rr.ClassType = TPSSubNumber then + begin + BlockWriteByte(BlockInfo, 2); + BlockWriteLong(BlockInfo, GetAddress(x)); + BlockWriteLong(BlockInfo, TPSSubNumber(rr).SubNo); + end + else + begin + BlockWriteByte(BlockInfo, 3); + BlockWriteLong(BlockInfo, GetAddress(x)); + BlockWriteLong(BlockInfo, GetAddress(TPSSubValue(rr).SubNo)); + end; + end; + end else if x.ClassType = TPSValueData then + begin + if AllowData then + begin + BlockWriteByte(BlockInfo, 1); + BlockWriteVariant(BlockInfo, TPSValueData(x).Data) + end + else + begin + Result := False; + exit; + end; + end else + Result := False; + end; + + function ReadParameters(IsProperty: Boolean; Dest: TPSParameters): Boolean; forward; +{$IFNDEF PS_NOIDISPATCH} + function ReadIDispatchParameters(const ProcName: tbtString; aVariantType: TPSVariantType; FSelf: TPSValue): TPSValue; forward; +{$ENDIF} + function ReadProcParameters(ProcNo: Cardinal; FSelf: TPSValue): TPSValue; forward; + function ReadVarParameters(ProcNoVar: TPSValue): TPSValue; forward; + + function calc(endOn: TPSPasToken): TPSValue; forward; + procedure CheckNotificationVariant(var Val: TPSValue); + var + aType: TPSType; + Call: TPSValueProcNo; + tmp: TPSValue; + begin + if not (Val is TPSValueGlobalVar) then exit; + aType := GetTypeNo(BlockInfo, Val); + if (AType = nil) or (AType.BaseType <> btNotificationVariant) then exit; + if FParser.CurrTokenId = CSTI_Assignment then + begin + Call := TPSValueProcNo.Create; + Call.ResultType := nil; + Call.SetParserPos(FParser); + Call.ProcNo := FindProc('!NOTIFICATIONVARIANTSET');; + Call.SetParserPos(FParser); + Call.Parameters := TPSParameters.Create; + Tmp := TPSValueData.Create; + TPSVAlueData(tmp).Data := NewVariant(at2ut(FindBaseType(btString))); + tbtString(TPSValueData(tmp).Data.tstring) := TPSVar(FVars[TPSValueGlobalVar(Val).GlobalVarNo]).OrgName; + with call.Parameters.Add do + begin + Val := tmp; + ExpectedType := TPSValueData(tmp).Data.FType; + end; + FParser.Next; + tmp := Calc(CSTI_SemiColon); + if tmp = nil then + begin + Val.Free; + Val := nil; + exit; + end; + with Call.Parameters.Add do + begin + Val := tmp; + ExpectedType := at2ut(FindBaseType(btVariant)); + end; + Val.Free; + Val := Call; + end else begin + Call := TPSValueProcNo.Create; + Call.ResultType := AT2UT(FindBaseType(btVariant)); + Call.SetParserPos(FParser); + Call.ProcNo := FindProc('!NOTIFICATIONVARIANTGET'); + Call.SetParserPos(FParser); + Call.Parameters := TPSParameters.Create; + Tmp := TPSValueData.Create; + TPSVAlueData(tmp).Data := NewVariant(at2ut(FindBaseType(btString))); + tbtString(TPSValueData(tmp).Data.tstring) := TPSVar(FVars[TPSValueGlobalVar(Val).GlobalVarNo]).OrgName; + with call.Parameters.Add do + begin + Val := tmp; + ExpectedType := TPSValueData(tmp).Data.FType; + end; + Val.Free; + Val := Call; + end; + end; + + + function GetIdentifier(const FType: Byte): TPSValue; + { + FType: + 0 = Anything + 1 = Only variables + 2 = Not constants + } + + procedure CheckProcCall(var x: TPSValue); + var + aType: TPSType; + begin + if FParser.CurrTokenId in [CSTI_Dereference, CSTI_OpenRound] then + begin + aType := GetTypeNo(BlockInfo, x); + if (aType = nil) or (aType.BaseType <> btProcPtr) then + begin + MakeError('', ecTypeMismatch, ''); + x.Free; + x := nil; + Exit; + end; + if FParser.CurrTokenId = CSTI_Dereference then + FParser.Next; + x := ReadVarParameters(x); + end; + end; + + procedure CheckFurther(var x: TPSValue; ImplicitPeriod: Boolean); + var + t: Cardinal; + rr: TPSSubItem; + L: Longint; + u: TPSType; + Param: TPSParameter; + tmp, tmpn: TPSValue; + tmp3: TPSValueProcNo; + tmp2: Boolean; + + function FindSubR(const n: tbtString; FType: TPSType): Cardinal; + var + h, I: Longint; + rvv: PIFPSRecordFieldTypeDef; + begin + h := MakeHash(n); + for I := 0 to TPSRecordType(FType).RecValCount - 1 do + begin + rvv := TPSRecordType(FType).RecVal(I); + if (rvv.FieldNameHash = h) and (rvv.FieldName = n) then + begin + Result := I; + exit; + end; + end; + Result := InvalidVal; + end; + + begin +(* if not (x is TPSValueVar) then + Exit;*) + u := GetTypeNo(BlockInfo, x); + if u = nil then exit; + while True do + begin + if (u.BaseType = btClass) {$IFNDEF PS_NOINTERFACES}or (u.BaseType = btInterface){$ENDIF} + {$IFNDEF PS_NOIDISPATCH}or ((u.BaseType = btVariant) or (u.BaseType = btNotificationVariant)){$ENDIF} or (u.BaseType = btExtClass) then exit; + if FParser.CurrTokenId = CSTI_OpenBlock then + begin + if (u.BaseType = btString) {$IFNDEF PS_NOWIDESTRING} or (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) {$ENDIF} then + begin + FParser.Next; + tmp := Calc(CSTI_CloseBlock); + if tmp = nil then + begin + x.Free; + x := nil; + exit; + end; + if not IsIntType(GetTypeNo(BlockInfo, tmp).BaseType) then + begin + MakeError('', ecTypeMismatch, ''); + tmp.Free; + x.Free; + x := nil; + exit; + end; + FParser.Next; + if FParser.CurrTokenId = CSTI_Assignment then + begin + if not (x is TPSValueVar) then begin + MakeError('', ecVariableExpected, ''); + tmp.Free; + x.Free; + x := nil; + exit; + end; + {$IFNDEF PS_NOWIDESTRING} + if (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) then + l := FindProc('WSTRSET') + else + {$ENDIF} + l := FindProc('STRSET'); + if l = -1 then + begin + MakeError('', ecUnknownIdentifier, 'StrSet'); + tmp.Free; + x.Free; + x := nil; + exit; + end; + tmp3 := TPSValueProcNo.Create; + tmp3.ResultType := nil; + tmp3.SetParserPos(FParser); + tmp3.ProcNo := L; + tmp3.SetParserPos(FParser); + tmp3.Parameters := TPSParameters.Create; + param := tmp3.Parameters.Add; + with tmp3.Parameters.Add do + begin + Val := tmp; + ExpectedType := GetTypeNo(BlockInfo, tmp); +{$IFDEF DEBUG} + if not ExpectedType.Used then asm int 3; end; +{$ENDIF} + end; + with tmp3.Parameters.Add do + begin + Val := x; + ExpectedType := GetTypeNo(BlockInfo, x); +{$IFDEF DEBUG} + if not ExpectedType.Used then asm int 3; end; +{$ENDIF} + ParamMode := pmInOut; + end; + x := tmp3; + FParser.Next; + tmp := Calc(CSTI_SemiColon); + if tmp = nil then + begin + x.Free; + x := nil; + exit; + end; + if (GetTypeNo(BlockInfo, Tmp).BaseType <> btChar) + {$IFNDEF PS_NOWIDESTRING} and (GetTypeno(BlockInfo, Tmp).BaseType <> btWideChar) {$ENDIF} then + begin + x.Free; + x := nil; + Tmp.Free; + MakeError('', ecTypeMismatch, ''); + exit; + + end; + param.Val := tmp; + Param.ExpectedType := GetTypeNo(BlockInfo, tmp); +{$IFDEF DEBUG} + if not Param.ExpectedType.Used then asm int 3; end; +{$ENDIF} + end else begin + {$IFNDEF PS_NOWIDESTRING} + if (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) then + l := FindProc('WSTRGET') + else + {$ENDIF} + l := FindProc('STRGET'); + if l = -1 then + begin + MakeError('', ecUnknownIdentifier, 'StrGet'); + tmp.Free; + x.Free; + x := nil; + exit; + end; + tmp3 := TPSValueProcNo.Create; + {$IFNDEF PS_NOWIDESTRING} + if (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) then + tmp3.ResultType := FindBaseType(btWideChar) + else + {$ENDIF} + tmp3.ResultType := FindBaseType(btChar); + tmp3.ProcNo := L; + tmp3.SetParserPos(FParser); + tmp3.Parameters := TPSParameters.Create; + with tmp3.Parameters.Add do + begin + Val := x; + ExpectedType := GetTypeNo(BlockInfo, x); +{$IFDEF DEBUG} + if not ExpectedType.Used then asm int 3; end; +{$ENDIF} + + if x is TPSValueVar then + ParamMode := pmInOut + else + parammode := pmIn; + end; + with tmp3.Parameters.Add do + begin + Val := tmp; + ExpectedType := GetTypeNo(BlockInfo, tmp); +{$IFDEF DEBUG} + if not ExpectedType.Used then asm int 3; end; +{$ENDIF} + end; + x := tmp3; + end; + Break; + end else if ((u.BaseType = btArray) or (u.BaseType = btStaticArray)) and (x is TPSValueVar) then + begin + FParser.Next; + tmp := calc(CSTI_CloseBlock); + if tmp = nil then + begin + x.Free; + x := nil; + exit; + end; + if not IsIntType(GetTypeNo(BlockInfo, tmp).BaseType) then + begin + MakeError('', ecTypeMismatch, ''); + tmp.Free; + x.Free; + x := nil; + exit; + end; + if (tmp.ClassType = TPSValueData) then + begin + rr := TPSSubNumber.Create; + TPSValueVar(x).RecAdd(rr); + if (u.BaseType = btStaticArray) then + TPSSubNumber(rr).SubNo := Cardinal(GetInt(TPSValueData(tmp).Data, tmp2) - TPSStaticArrayType(u).StartOffset) + else + TPSSubNumber(rr).SubNo := GetUInt(TPSValueData(tmp).Data, tmp2); + tmp.Free; + rr.aType := TPSArrayType(u).ArrayTypeNo; + u := rr.aType; + end + else + begin + if (u.BaseType = btStaticArray) then + begin + tmpn := TPSBinValueOp.Create; + TPSBinValueOp(tmpn).Operator := otSub; + TPSBinValueOp(tmpn).Val1 := tmp; + tmp := TPSValueData.Create; + TPSValueData(tmp).Data := NewVariant(FindBaseType(btS32)); + TPSValueData(tmp).Data.ts32 := TPSStaticArrayType(u).StartOffset; + TPSBinValueOp(tmpn).Val2 := tmp; + TPSBinValueOp(tmpn).aType := FindBaseType(btS32); + tmp := tmpn; + end; + rr := TPSSubValue.Create; + TPSValueVar(x).recAdd(rr); + TPSSubValue(rr).SubNo := tmp; + rr.aType := TPSArrayType(u).ArrayTypeNo; + u := rr.aType; + end; + if FParser.CurrTokenId <> CSTI_CloseBlock then + begin + MakeError('', ecCloseBlockExpected, ''); + x.Free; + x := nil; + exit; + end; + Fparser.Next; + end else begin + MakeError('', ecSemicolonExpected, ''); + x.Free; + x := nil; + exit; + end; + end + else if (FParser.CurrTokenId = CSTI_Period) or (ImplicitPeriod) then + begin + if not ImplicitPeriod then + FParser.Next; + if u.BaseType = btRecord then + begin + t := FindSubR(FParser.GetToken, u); + if t = InvalidVal then + begin + if ImplicitPeriod then exit; + MakeError('', ecUnknownIdentifier, FParser.GetToken); + x.Free; + x := nil; + exit; + end; + if (x is TPSValueProcNo) then + begin + ImplicitPeriod := False; + FParser.Next; + + tmp := AllocStackReg(u); + WriteCalculation(x,tmp); + TPSVar(BlockInfo.Proc.FProcVars[TPSValueAllocatedStackVar(tmp).LocalVarNo]).Use; + + rr := TPSSubNumber.Create; + TPSValueVar(tmp).RecAdd(rr); + TPSSubNumber(rr).SubNo := t; + rr.aType := TPSRecordType(u).RecVal(t).FType; + u := rr.aType; + + tmpn := TPSValueReplace.Create; + with TPSValueReplace(tmpn) do + begin + FreeOldValue := true; + FreeNewValue := true; + OldValue := tmp; + NewValue := AllocStackReg(u); + PreWriteAllocated := true; + end; + + if not WriteCalculation(tmp,TPSValueReplace(tmpn).NewValue) then + begin + {MakeError('',ecInternalError,'');} + x.Free; + x := nil; + exit; + end; + x.Free; + x := tmpn; + end else + begin + if not (x is TPSValueVar) then begin + MakeError('', ecVariableExpected, FParser.GetToken); + x.Free; + x := nil; + exit; + end; + ImplicitPeriod := False; + FParser.Next; + rr := TPSSubNumber.Create; + TPSValueVar(x).RecAdd(rr); + TPSSubNumber(rr).SubNo := t; + rr.aType := TPSRecordType(u).RecVal(t).FType; + u := rr.aType; + end; + end + else + begin + x.Free; + MakeError('', ecSemicolonExpected, ''); + x := nil; + exit; + end; + end + else + break; + end; + end; + + + + procedure CheckClassArrayProperty(var P: TPSValue; const VarType: TPSVariableType; VarNo: Cardinal); + var + Tempp: TPSValue; + aType: TPSClassType; + procno: Cardinal; + Idx: IPointer; + Decl: TPSParametersDecl; + begin + if p = nil then exit; + if (GetTypeNo(BlockInfo, p) = nil) or (GetTypeNo(BlockInfo, p).BaseType <> btClass) then exit; + aType := TPSClassType(GetTypeNo(BlockInfo, p)); + if FParser.CurrTokenID = CSTI_OpenBlock then + begin + if not TPSClassType(aType).Cl.Property_Find('', Idx) then + begin + MakeError('', ecPeriodExpected, ''); + p.Free; + p := nil; + exit; + end; + if VarNo <> InvalidVal then + begin + if @FOnUseVariable <> nil then + FOnUseVariable(Self, VarType, VarNo, BlockInfo.ProcNo, FParser.CurrTokenPos, '[Default]'); + end; + Decl := TPSParametersDecl.Create; + TPSClassType(aType).Cl.Property_GetHeader(Idx, Decl); + tempp := p; + P := TPSValueProcNo.Create; + with TPSValueProcNo(P) do + begin + Parameters := TPSParameters.Create; + Parameters.Add; + end; + if not (ReadParameters(True, TPSValueProc(P).Parameters) and + ValidateParameters(BlockInfo, TPSValueProc(P).Parameters, Decl)) then + begin + tempp.Free; + Decl.Free; + p.Free; + p := nil; + exit; + end; + with TPSValueProcNo(p).Parameters[0] do + begin + Val := tempp; + ExpectedType := GetTypeNo(BlockInfo, tempp); + end; + if FParser.CurrTokenId = CSTI_Assignment then + begin + FParser.Next; + TempP := Calc(CSTI_SemiColon); + if TempP = nil then + begin + Decl.Free; + P.Free; + p := nil; + exit; + end; + with TPSValueProc(p).Parameters.Add do + begin + Val := Tempp; + ExpectedType := at2ut(Decl.Result); + end; + if not TPSClassType(aType).Cl.Property_Set(Idx, procno) then + begin + Decl.Free; + MakeError('', ecReadOnlyProperty, ''); + p.Free; + p := nil; + exit; + end; + TPSValueProcNo(p).ProcNo := procno; + TPSValueProcNo(p).ResultType := nil; + end + else + begin + if not TPSClassType(aType).Cl.Property_Get(Idx, procno) then + begin + Decl.Free; + MakeError('', ecWriteOnlyProperty, ''); + p.Free; + p := nil; + exit; + end; + TPSValueProcNo(p).ProcNo := procno; + TPSValueProcNo(p).ResultType := TPSExternalProcedure(FProcs[procno]).RegProc.Decl.Result; + end; // if FParser.CurrTokenId = CSTI_Assign + Decl.Free; + end; + end; + + procedure CheckExtClass(var P: TPSValue; const VarType: TPSVariableType; VarNo: Cardinal; ImplicitPeriod: Boolean); + var + Temp, Idx: Cardinal; + FType: TPSType; + s: tbtString; + + begin + FType := GetTypeNo(BlockInfo, p); + if FType = nil then Exit; + if FType.BaseType <> btExtClass then Exit; + while (FParser.CurrTokenID = CSTI_Period) or (ImplicitPeriod) do + begin + if not ImplicitPeriod then + FParser.Next; + if FParser.CurrTokenID <> CSTI_Identifier then + begin + if ImplicitPeriod then exit; + MakeError('', ecIdentifierExpected, ''); + p.Free; + P := nil; + Exit; + end; + s := FParser.GetToken; + if TPSUndefinedClassType(FType).ExtClass.Func_Find(s, Idx) then + begin + FParser.Next; + TPSUndefinedClassType(FType).ExtClass.Func_Call(Idx, Temp); + P := ReadProcParameters(Temp, P); + if p = nil then + begin + Exit; + end; + end else + begin + if ImplicitPeriod then exit; + MakeError('', ecUnknownIdentifier, s); + p.Free; + P := nil; + Exit; + end; + ImplicitPeriod := False; + FType := GetTypeNo(BlockInfo, p); + if (FType = nil) or (FType.BaseType <> btExtClass) then Exit; + end; {while} + end; + + procedure CheckClass(var P: TPSValue; const VarType: TPSVariableType; VarNo: Cardinal; ImplicitPeriod: Boolean); + var + Procno: Cardinal; + Idx: IPointer; + FType: TPSType; + TempP: TPSValue; + Decl: TPSParametersDecl; + s: tbtString; + + pinfo, pinfonew: tbtString; + ppos: Cardinal; + + begin + FType := GetTypeNo(BlockInfo, p); + if FType = nil then exit; + pinfo := ''; + if (FType.BaseType <> btClass) then Exit; + while (FParser.CurrTokenID = CSTI_Period) or (ImplicitPeriod) do + begin + if not ImplicitPeriod then + FParser.Next; + if FParser.CurrTokenID <> CSTI_Identifier then + begin + if ImplicitPeriod then exit; + MakeError('', ecIdentifierExpected, ''); + p.Free; + P := nil; + Exit; + end; + s := FParser.GetToken; + if TPSClassType(FType).Cl.Func_Find(s, Idx) then + begin + FParser.Next; + VarNo := InvalidVal; + TPSClassType(FType).cl.Func_Call(Idx, Procno); + P := ReadProcParameters(Procno, P); + if p = nil then + begin + Exit; + end; + end else if TPSClassType(FType).cl.Property_Find(s, Idx) then + begin + ppos := FParser.CurrTokenPos; + pinfonew := FParser.OriginalToken; + FParser.Next; + if VarNo <> InvalidVal then + begin + if pinfo = '' then + pinfo := pinfonew + else + pinfo := pinfo + '.' + pinfonew; + if @FOnUseVariable <> nil then + FOnUseVariable(Self, VarType, VarNo, BlockInfo.ProcNo, ppos, pinfo); + end; + Decl := TPSParametersDecl.Create; + TPSClassType(FType).cl.Property_GetHeader(Idx, Decl); + TempP := P; + p := TPSValueProcNo.Create; + with TPSValueProcNo(p) do + begin + Parameters := TPSParameters.Create; + Parameters.Add; + Pos := FParser.CurrTokenPos; + row := FParser.Row; + Col := FParser.Col; + end; + if Decl.ParamCount <> 0 then + begin + if not (ReadParameters(True, TPSValueProc(P).Parameters) and + ValidateParameters(BlockInfo, TPSValueProc(P).Parameters, Decl)) then + begin + Tempp.Free; + Decl.Free; + p.Free; + P := nil; + exit; + end; + end; // if + with TPSValueProcNo(p).Parameters[0] do + begin + Val := TempP; + ExpectedType := at2ut(GetTypeNo(BlockInfo, TempP)); + end; + if FParser.CurrTokenId = CSTI_Assignment then + begin + FParser.Next; + TempP := Calc(CSTI_SemiColon); + if TempP = nil then + begin + Decl.Free; + P.Free; + p := nil; + exit; + end; + with TPSValueProc(p).Parameters.Add do + begin + Val := Tempp; + ExpectedType := at2ut(Decl.Result); +{$IFDEF DEBUG} + if not ExpectedType.Used then asm int 3; end; +{$ENDIF} + end; + + if not TPSClassType(FType).cl.Property_Set(Idx, Procno) then + begin + MakeError('', ecReadOnlyProperty, ''); + Decl.Free; + p.Free; + p := nil; + exit; + end; + TPSValueProcNo(p).ProcNo := Procno; + TPSValueProcNo(p).ResultType := nil; + Decl.Free; + Exit; + end else begin + if not TPSClassType(FType).cl.Property_Get(Idx, Procno) then + begin + MakeError('', ecWriteOnlyProperty, ''); + Decl.Free; + p.Free; + p := nil; + exit; + end; + TPSValueProcNo(p).ProcNo := ProcNo; + TPSValueProcNo(p).ResultType := TPSExternalProcedure(FProcs[ProcNo]).RegProc.Decl.Result; + end; // if FParser.CurrTokenId = CSTI_Assign + Decl.Free; + end else + begin + if ImplicitPeriod then exit; + MakeError('', ecUnknownIdentifier, s); + p.Free; + P := nil; + Exit; + end; + ImplicitPeriod := False; + FType := GetTypeNo(BlockInfo, p); + if (FType = nil) or (FType.BaseType <> btClass) then Exit; + end; {while} + end; +{$IFNDEF PS_NOIDISPATCH} + procedure CheckIntf(var P: TPSValue; const VarType: TPSVariableType; VarNo: Cardinal; ImplicitPeriod: Boolean); + var + Procno, Idx: Cardinal; + FType: TPSType; + s: tbtString; + + CheckArrayProperty,HasArrayProperty:boolean; + begin + FType := GetTypeNo(BlockInfo, p); + if FType = nil then exit; + if (FType.BaseType <> btInterface) and (Ftype.BaseType <> BtVariant) and (FType.BaseType = btNotificationVariant) then Exit; + + CheckArrayProperty:=(FParser.CurrTokenID=CSTI_OpenBlock)and + (Ftype.BaseType = BtVariant); + while (FParser.CurrTokenID = CSTI_Period) + or (ImplicitPeriod)or (CheckArrayProperty) do begin + + HasArrayProperty:=CheckArrayProperty; + if CheckArrayProperty then begin + CheckArrayProperty:=false; + end else begin + if not ImplicitPeriod then + FParser.Next; + end; + if FParser.CurrTokenID <> CSTI_Identifier then + begin + if ImplicitPeriod then exit; + if not HasArrayProperty then begin + MakeError('', ecIdentifierExpected, ''); + p.Free; + P := nil; + Exit; + end; + end; + if (FType.BaseType = btVariant) or (FType.BaseType = btNotificationVariant) then + begin + if HasArrayProperty then begin + s:=''; + end else begin + s := FParser.OriginalToken; + FParser.Next; + end; + ImplicitPeriod := False; + FType := GetTypeNo(BlockInfo, p); + p := ReadIDispatchParameters(s, TPSVariantType(FType), p); + if (FType = nil) or (FType.BaseType <> btInterface) then Exit; + end else + begin + s := FParser.GetToken; + if (FType is TPSInterfaceType) and (TPSInterfaceType(FType).Intf.Func_Find(s, Idx)) then + begin + FParser.Next; + TPSInterfaceType(FType).Intf.Func_Call(Idx, Procno); + P := ReadProcParameters(Procno, P); + if p = nil then + begin + Exit; + end; + end else + begin + if ImplicitPeriod then exit; + MakeError('', ecUnknownIdentifier, s); + p.Free; + P := nil; + Exit; + end; + ImplicitPeriod := False; + FType := GetTypeNo(BlockInfo, p); + if (FType = nil) or ((FType.BaseType <> btInterface) and (Ftype.BaseType <> btVariant) and (Ftype.BaseType <> btNotificationVariant)) then Exit; + end; + end; {while} + end; + {$ENDIF} + function ExtCheckClassType(FType: TPSType; const ParserPos: Cardinal): TPSValue; + var + FType2: TPSType; + ProcNo, Idx: Cardinal; + Temp, ResV: TPSValue; + begin + if FParser.CurrTokenID = CSTI_OpenRound then + begin + FParser.Next; + Temp := Calc(CSTI_CloseRound); + if Temp = nil then + begin + Result := nil; + exit; + end; + if FParser.CurrTokenID <> CSTI_CloseRound then + begin + temp.Free; + MakeError('', ecCloseRoundExpected, ''); + Result := nil; + exit; + end; + FType2 := GetTypeNo(BlockInfo, Temp); + if (FType.basetype = BtClass) and (ftype2.BaseType = btClass) and (ftype <> ftype2) then + begin + if not TPSUndefinedClassType(FType2).ExtClass.CastToType(AT2UT(FType), ProcNo) then + begin + temp.Free; + MakeError('', ecTypeMismatch, ''); + Result := nil; + exit; + end; + Result := TPSValueProcNo.Create; + TPSValueProcNo(Result).Parameters := TPSParameters.Create; + TPSValueProcNo(Result).ResultType := at2ut(FType); + TPSValueProcNo(Result).ProcNo := ProcNo; + with TPSValueProcNo(Result).Parameters.Add do + begin + Val := Temp; + ExpectedType := GetTypeNo(BlockInfo, temp); + end; + with TPSValueProcNo(Result).Parameters.Add do + begin + ExpectedType := at2ut(FindBaseType(btu32)); + Val := TPSValueData.Create; + with TPSValueData(val) do + begin + SetParserPos(FParser); + Data := NewVariant(ExpectedType); + Data.tu32 := at2ut(FType).FinalTypeNo; + end; + end; + FParser.Next; + Exit; + end; + if not IsCompatibleType(FType, FType2, True) then + begin + temp.Free; + MakeError('', ecTypeMismatch, ''); + Result := nil; + exit; + end; + FParser.Next; + Result := TPSUnValueOp.Create; + with TPSUnValueOp(Result) do + begin + Operator := otCast; + Val1 := Temp; + SetParserPos(FParser); + aType := AT2UT(FType); + end; + exit; + end; + if FParser.CurrTokenId <> CSTI_Period then + begin + Result := nil; + MakeError('', ecPeriodExpected, ''); + Exit; + end; + if FType.BaseType <> btExtClass then + begin + Result := nil; + MakeError('', ecClassTypeExpected, ''); + Exit; + end; + FParser.Next; + if not TPSUndefinedClassType(FType).ExtClass.ClassFunc_Find(FParser.GetToken, Idx) then + begin + Result := nil; + MakeError('', ecUnknownIdentifier, FParser.OriginalToken); + Exit; + end; + FParser.Next; + TPSUndefinedClassType(FType).ExtClass.ClassFunc_Call(Idx, ProcNo); + Temp := TPSValueData.Create; + with TPSValueData(Temp) do + begin + Data := NewVariant(at2ut(FindBaseType(btu32))); + Data.tu32 := at2ut(FType).FinalTypeNo; + end; + ResV := ReadProcParameters(ProcNo, Temp); + if ResV <> nil then + begin + TPSValueProc(Resv).ResultType := at2ut(FType); + Result := Resv; + end else begin + Result := nil; + end; + end; + + function CheckClassType(TypeNo: TPSType; const ParserPos: Cardinal): TPSValue; + var + FType2: TPSType; + ProcNo: Cardinal; + Idx: IPointer; + Temp, ResV: TPSValue; + dta: PIfRVariant; + begin + if typeno.BaseType = btExtClass then + begin + Result := ExtCheckClassType(TypeNo, PArserPos); + exit; + end; + if FParser.CurrTokenID = CSTI_OpenRound then + begin + FParser.Next; + Temp := Calc(CSTI_CloseRound); + if Temp = nil then + begin + Result := nil; + exit; + end; + if FParser.CurrTokenID <> CSTI_CloseRound then + begin + temp.Free; + MakeError('', ecCloseRoundExpected, ''); + Result := nil; + exit; + end; + FType2 := GetTypeNo(BlockInfo, Temp); + if ((typeno.BaseType = btClass){$IFNDEF PS_NOINTERFACES} or (TypeNo.basetype = btInterface){$ENDIF}) and + ((ftype2.BaseType = btClass){$IFNDEF PS_NOINTERFACES} or (ftype2.BaseType = btInterface){$ENDIF}) and (TypeNo <> ftype2) then + begin +{$IFNDEF PS_NOINTERFACES} + if FType2.basetype = btClass then + begin +{$ENDIF} + if not TPSClassType(FType2).Cl.CastToType(AT2UT(TypeNo), ProcNo) then + begin + temp.Free; + MakeError('', ecTypeMismatch, ''); + Result := nil; + exit; + end; +{$IFNDEF PS_NOINTERFACES} + end else begin + if not TPSInterfaceType(FType2).Intf.CastToType(AT2UT(TypeNo), ProcNo) then + begin + temp.Free; + MakeError('', ecTypeMismatch, ''); + Result := nil; + exit; + end; + end; +{$ENDIF} + Result := TPSValueProcNo.Create; + TPSValueProcNo(Result).Parameters := TPSParameters.Create; + TPSValueProcNo(Result).ResultType := at2ut(TypeNo); + TPSValueProcNo(Result).ProcNo := ProcNo; + with TPSValueProcNo(Result).Parameters.Add do + begin + Val := Temp; + ExpectedType := GetTypeNo(BlockInfo, temp); +{$IFDEF DEBUG} + if not ExpectedType.Used then asm int 3; end; +{$ENDIF} + end; + with TPSValueProcNo(Result).Parameters.Add do + begin + ExpectedType := at2ut(FindBaseType(btu32)); +{$IFDEF DEBUG} + if not ExpectedType.Used then asm int 3; end; +{$ENDIF} + Val := TPSValueData.Create; + with TPSValueData(val) do + begin + SetParserPos(FParser); + Data := NewVariant(ExpectedType); + Data.tu32 := at2ut(TypeNo).FinalTypeNo; + end; + end; + FParser.Next; + Exit; + end; + if not IsCompatibleType(TypeNo, FType2, True) then + begin + temp.Free; + MakeError('', ecTypeMismatch, ''); + Result := nil; + exit; + end; + FParser.Next; + Result := TPSUnValueOp.Create; + with TPSUnValueOp(Result) do + begin + Operator := otCast; + Val1 := Temp; + SetParserPos(FParser); + aType := AT2UT(TypeNo); + end; + + exit; + end else + if FParser.CurrTokenId <> CSTI_Period then + begin + Result := TPSValueData.Create; + Result.SetParserPos(FParser); + New(dta); + TPSValueData(Result).Data := dta; + InitializeVariant(dta, at2ut(FindBaseType(btType))); + dta.ttype := at2ut(TypeNo); + Exit; + end; + if TypeNo.BaseType <> btClass then + begin + Result := nil; + MakeError('', ecClassTypeExpected, ''); + Exit; + end; + FParser.Next; + if not TPSClassType(TypeNo).Cl.ClassFunc_Find(FParser.GetToken, Idx) then + begin + Result := nil; + MakeError('', ecUnknownIdentifier, FParser.OriginalToken); + Exit; + end; + FParser.Next; + TPSClassType(TypeNo).Cl.ClassFunc_Call(Idx, ProcNo); + Temp := TPSValueData.Create; + with TPSValueData(Temp) do + begin + Data := NewVariant(at2ut(FindBaseType(btu32))); + Data.tu32 := at2ut(TypeNo).FinalTypeNo; + end; + ResV := ReadProcParameters(ProcNo, Temp); + if ResV <> nil then + begin + TPSValueProc(Resv).ResultType := at2ut(TypeNo); + Result := Resv; + end else begin + Result := nil; + end; + end; + + var + vt: TPSVariableType; + vno: Cardinal; + TWith, Temp: TPSValue; + l, h: Longint; + s, u: tbtString; + t: TPSConstant; + Temp1: TPSType; + temp2: CArdinal; + bi: TPSBlockInfo; + lOldRecCount: Integer; + + begin + s := FParser.GetToken; + + if FType <> 1 then + begin + bi := BlockInfo; + while bi <> nil do + begin + for l := bi.WithList.Count -1 downto 0 do + begin + TWith := TPSValueAllocatedStackVar.Create; + TPSValueAllocatedStackVar(TWith).LocalVarNo := TPSValueAllocatedStackVar(TPSValueReplace(bi.WithList[l]).NewValue).LocalVarNo; + Temp := TWith; + VNo := TPSValueAllocatedStackVar(Temp).LocalVarNo; + lOldRecCount := TPSValueVar(TWith).GetRecCount; + vt := ivtVariable; + if Temp = TWith then CheckFurther(TWith, True); + if Temp = TWith then CheckClass(TWith, vt, vno, True); + if Temp = TWith then CheckExtClass(TWith, vt, vno, True); + if (Temp <> TWith) or (Cardinal(lOldRecCount) <> TPSValueVar(TWith).GetRecCount) then + begin + repeat + Temp := TWith; + if TWith <> nil then CheckFurther(TWith, False); + if TWith <> nil then CheckClass(TWith, vt, vno, False); + if TWith <> nil then CheckExtClass(TWith, vt, vno, False); +{$IFNDEF PS_NOIDISPATCH}if TWith <> nil then CheckIntf(TWith, vt, vno, False);{$ENDIF} + if TWith <> nil then CheckProcCall(TWith); + if TWith <> nil then CheckClassArrayProperty(TWith, vt, vno); + vno := InvalidVal; + until (TWith = nil) or (Temp = TWith); + Result := TWith; + Exit; + end; + TWith.Free; + end; + bi := bi.FOwner; + end; + end; + + if s = 'RESULT' then + begin + if BlockInfo.proc.Decl.Result = nil then + begin + Result := nil; + MakeError('', ecUnknownIdentifier, FParser.OriginalToken); + end + else + begin + BlockInfo.Proc.ResultUse; + Result := TPSValueParamVar.Create; + with TPSValueParamVar(Result) do + begin + SetParserPos(FParser); + ParamNo := 0; + end; + vno := 0; + vt := ivtParam; + if @FOnUseVariable <> nil then + FOnUseVariable(Self, vt, vno, BlockInfo.ProcNo, FParser.CurrTokenPos, ''); + FParser.Next; + repeat + Temp := Result; + if Result <> nil then CheckFurther(Result, False); + if Result <> nil then CheckClass(Result, vt, vno, False); + if Result <> nil then CheckExtClass(Result, vt, vno, False); +{$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF} + if Result <> nil then CheckProcCall(Result); + if Result <> nil then CheckClassArrayProperty(Result, vt, vno); + vno := InvalidVal; + until (Result = nil) or (Temp = Result); + end; + exit; + end; + if BlockInfo.Proc.Decl.Result = nil then + l := 0 + else + l := 1; + for h := 0 to BlockInfo.proc.Decl.ParamCount -1 do + begin + if BlockInfo.proc.Decl.Params[h].Name = s then + begin + Result := TPSValueParamVar.Create; + with TPSValueParamVar(Result) do + begin + SetParserPos(FParser); + ParamNo := l; + end; + vt := ivtParam; + vno := L; + if @FOnUseVariable <> nil then + FOnUseVariable(Self, vt, vno, BlockInfo.ProcNo, FParser.CurrTokenPos, ''); + FParser.Next; + repeat + Temp := Result; + if Result <> nil then CheckFurther(Result, False); + if Result <> nil then CheckClass(Result, vt, vno, False); + if Result <> nil then CheckExtClass(Result, vt, vno, False); +{$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF} + if Result <> nil then CheckProcCall(Result); + if Result <> nil then CheckClassArrayProperty(Result, vt, vno); + vno := InvalidVal; + until (Result = nil) or (Temp = Result); + exit; + end; + Inc(l); + GRFW(u); + end; + + h := MakeHash(s); + + for l := 0 to BlockInfo.Proc.ProcVars.Count - 1 do + begin + if (PIFPSProcVar(BlockInfo.Proc.ProcVars[l]).NameHash = h) and + (PIFPSProcVar(BlockInfo.Proc.ProcVars[l]).Name = s) then + begin + PIFPSProcVar(BlockInfo.Proc.ProcVars[l]).Use; + vno := l; + vt := ivtVariable; + if @FOnUseVariable <> nil then + FOnUseVariable(Self, vt, vno, BlockInfo.ProcNo, FParser.CurrTokenPos, ''); + Result := TPSValueLocalVar.Create; + with TPSValueLocalVar(Result) do + begin + LocalVarNo := l; + SetParserPos(FParser); + end; + FParser.Next; + repeat + Temp := Result; + if Result <> nil then CheckFurther(Result, False); + if Result <> nil then CheckClass(Result, vt, vno, False); + if Result <> nil then CheckExtClass(Result, vt, vno, False); +{$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF} + if Result <> nil then CheckProcCall(Result); + if Result <> nil then CheckClassArrayProperty(Result, vt, vno); + vno := InvalidVal; + until (Result = nil) or (Temp = Result); + + exit; + end; + end; + + for l := 0 to FVars.Count - 1 do + begin + if (TPSVar(FVars[l]).NameHash = h) and + (TPSVar(FVars[l]).Name = s) then + begin + TPSVar(FVars[l]).Use; + Result := TPSValueGlobalVar.Create; + with TPSValueGlobalVar(Result) do + begin + SetParserPos(FParser); + GlobalVarNo := l; + + end; + vt := ivtGlobal; + vno := l; + if @FOnUseVariable <> nil then + FOnUseVariable(Self, vt, vno, BlockInfo.ProcNo, FParser.CurrTokenPos, ''); + FParser.Next; + repeat + Temp := Result; + if Result <> nil then CheckNotificationVariant(Result); + if Result <> nil then CheckFurther(Result, False); + if Result <> nil then CheckClass(Result, vt, vno, False); + if Result <> nil then CheckExtClass(Result, vt, vno, False); +{$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF} + if Result <> nil then CheckProcCall(Result); + if Result <> nil then CheckClassArrayProperty(Result, vt, vno); + vno := InvalidVal; + until (Result = nil) or (Temp = Result); + exit; + end; + end; + Temp1 := FindType(FParser.GetToken); + if Temp1 <> nil then + begin + l := FParser.CurrTokenPos; + if FType = 1 then + begin + Result := nil; + MakeError('', ecVariableExpected, FParser.OriginalToken); + exit; + end; + vt := ivtGlobal; + vno := InvalidVal; + FParser.Next; + Result := CheckClassType(Temp1, l); + repeat + Temp := Result; + if Result <> nil then CheckFurther(Result, False); + if Result <> nil then CheckClass(Result, vt, vno, False); + if Result <> nil then CheckExtClass(Result, vt, vno, False); +{$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF} + if Result <> nil then CheckProcCall(Result); + if Result <> nil then CheckClassArrayProperty(Result, vt, vno); + vno := InvalidVal; + until (Result = nil) or (Temp = Result); + + exit; + end; + Temp2 := FindProc(FParser.GetToken); + if Temp2 <> InvalidVal then + begin + if FType = 1 then + begin + Result := nil; + MakeError('', ecVariableExpected, FParser.OriginalToken); + exit; + end; + FParser.Next; + Result := ReadProcParameters(Temp2, nil); + if Result = nil then + exit; + Result.SetParserPos(FParser); + vt := ivtGlobal; + vno := InvalidVal; + repeat + Temp := Result; + if Result <> nil then CheckFurther(Result, False); + if Result <> nil then CheckClass(Result, vt, vno, False); + if Result <> nil then CheckExtClass(Result, vt, vno, False); +{$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF} + if Result <> nil then CheckProcCall(Result); + if Result <> nil then CheckClassArrayProperty(Result, vt, vno); + vno := InvalidVal; + until (Result = nil) or (Temp = Result); + exit; + end; + for l := 0 to FConstants.Count -1 do + begin + t := TPSConstant(FConstants[l]); + if (t.NameHash = h) and (t.Name = s) then + begin + if FType <> 0 then + begin + Result := nil; + MakeError('', ecVariableExpected, FParser.OriginalToken); + exit; + end; + fparser.next; + Result := TPSValueData.Create; + with TPSValueData(Result) do + begin + SetParserPos(FParser); + Data := NewVariant(at2ut(t.Value.FType)); + CopyVariantContents(t.Value, Data); + end; + vt := ivtGlobal; + vno := InvalidVal; + repeat + Temp := Result; + if Result <> nil then CheckFurther(Result, False); + if Result <> nil then CheckClass(Result, vt, vno, False); + if Result <> nil then CheckExtClass(Result, vt, vno, False); +{$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF} + if Result <> nil then CheckProcCall(Result); + if Result <> nil then CheckClassArrayProperty(Result, vt, vno); + vno := InvalidVal; + until (Result = nil) or (Temp = Result); + exit; + end; + end; + Result := nil; + MakeError('', ecUnknownIdentifier, FParser.OriginalToken); + end; + + function calc(endOn: TPSPasToken): TPSValue; + function TryEvalConst(var P: TPSValue): Boolean; forward; + + + function ReadExpression: TPSValue; forward; + function ReadTerm: TPSValue; forward; + function ReadFactor: TPSValue; + var + NewVar: TPSValue; + NewVarU: TPSUnValueOp; + Proc: TPSProcedure; + function ReadArray: Boolean; + var + tmp: TPSValue; + begin + FParser.Next; + NewVar := TPSValueArray.Create; + NewVar.SetParserPos(FParser); + if FParser.CurrTokenID <> CSTI_CloseBlock then + begin + while True do + begin + tmp := nil; + Tmp := ReadExpression(); + if Tmp = nil then + begin + Result := False; + NewVar.Free; + exit; + end; + if not TryEvalConst(tmp) then + begin + tmp.Free; + NewVar.Free; + Result := False; + exit; + end; + TPSValueArray(NewVar).Add(tmp); + if FParser.CurrTokenID = CSTI_CloseBlock then Break; + if FParser.CurrTokenID <> CSTI_Comma then + begin + MakeError('', ecCloseBlockExpected, ''); + NewVar.Free; + Result := False; + exit; + end; + FParser.Next; + end; + end; + FParser.Next; + Result := True; + end; + + function CallAssigned(P: TPSValue): TPSValue; + var + temp: TPSValueProcNo; + begin + temp := TPSValueProcNo.Create; + temp.ProcNo := FindProc('!ASSIGNED'); + temp.ResultType := at2ut(FDefaultBoolType); + temp.Parameters := TPSParameters.Create; + with Temp.Parameters.Add do + begin + Val := p; + ExpectedType := GetTypeNo(BlockInfo, p); +{$IFDEF DEBUG} + if not ExpectedType.Used then asm int 3; end; +{$ENDIF} + FParamMode := pmIn; + end; + Result := Temp; + end; + + function CallSucc(P: TPSValue): TPSValue; + var + temp: TPSBinValueOp; + begin + temp := TPSBinValueOp.Create; + temp.SetParserPos(FParser); + temp.FOperator := otAdd; + temp.FVal2 := TPSValueData.Create; + TPSValueData(Temp.FVal2).Data := NewVariant(FindBaseType(bts32)); + TPSValueData(Temp.FVal2).Data.ts32 := 1; + temp.FVal1 := p; + Temp.FType := GetTypeNo(BlockInfo, P); + result := temp; + end; + + function CallPred(P: TPSValue): TPSValue; + var + temp: TPSBinValueOp; + begin + temp := TPSBinValueOp.Create; + temp.SetParserPos(FParser); + temp.FOperator := otSub; + temp.FVal2 := TPSValueData.Create; + TPSValueData(Temp.FVal2).Data := NewVariant(FindBaseType(bts32)); + TPSValueData(Temp.FVal2).Data.ts32 := 1; + temp.FVal1 := p; + Temp.FType := GetTypeNo(BlockInfo, P); + result := temp; + end; + + begin + case fParser.CurrTokenID of + CSTI_OpenBlock: + begin + if not ReadArray then + begin + Result := nil; + exit; + end; + end; + CSTII_Not: + begin + FParser.Next; + NewVar := ReadFactor; + if NewVar = nil then + begin + Result := nil; + exit; + end; + NewVarU := TPSUnValueOp.Create; + NewVarU.SetParserPos(FParser); + NewVarU.aType := GetTypeNo(BlockInfo, NewVar); + NewVarU.Operator := otNot; + NewVarU.Val1 := NewVar; + NewVar := NewVarU; + end; + CSTI_Plus: + begin + FParser.Next; + NewVar := ReadTerm; + if NewVar = nil then + begin + Result := nil; + exit; + end; + end; + CSTI_Minus: + begin + FParser.Next; + NewVar := ReadTerm; + if NewVar = nil then + begin + Result := nil; + exit; + end; + NewVarU := TPSUnValueOp.Create; + NewVarU.SetParserPos(FParser); + NewVarU.aType := GetTypeNo(BlockInfo, NewVar); + NewVarU.Operator := otMinus; + NewVarU.Val1 := NewVar; + NewVar := NewVarU; + end; + CSTII_Nil: + begin + FParser.Next; + NewVar := TPSValueNil.Create; + NewVar.SetParserPos(FParser); + end; + CSTI_AddressOf: + begin + FParser.Next; + if FParser.CurrTokenID <> CSTI_Identifier then + begin + MakeError('', ecIdentifierExpected, ''); + Result := nil; + exit; + end; + NewVar := TPSValueProcPtr.Create; + NewVar.SetParserPos(FParser); + TPSValueProcPtr(NewVar).ProcPtr := FindProc(FParser.GetToken); + if TPSValueProcPtr(NewVar).ProcPtr = InvalidVal then + begin + MakeError('', ecUnknownIdentifier, FParser.OriginalToken); + NewVar.Free; + Result := nil; + exit; + end; + Proc := FProcs[TPSValueProcPtr(NewVar).ProcPtr]; + if Proc.ClassType <> TPSInternalProcedure then + begin + MakeError('', ecUnknownIdentifier, FParser.OriginalToken); + NewVar.Free; + Result := nil; + exit; + end; + FParser.Next; + end; + CSTI_OpenRound: + begin + FParser.Next; + NewVar := ReadExpression(); + if NewVar = nil then + begin + Result := nil; + exit; + end; + if FParser.CurrTokenId <> CSTI_CloseRound then + begin + NewVar.Free; + Result := nil; + MakeError('', ecCloseRoundExpected, ''); + exit; + end; + FParser.Next; + end; + CSTI_Char, CSTI_String: + begin + NewVar := TPSValueData.Create; + NewVar.SetParserPos(FParser); + TPSValueData(NewVar).Data := ReadString; + if TPSValueData(NewVar).Data = nil then + begin + NewVar.Free; + Result := nil; + exit; + end; + end; + CSTI_HexInt, CSTI_Integer: + begin + NewVar := TPSValueData.Create; + NewVar.SetParserPos(FParser); + TPSValueData(NewVar).Data := ReadInteger(FParser.GetToken); + FParser.Next; + end; + CSTI_Real: + begin + NewVar := TPSValueData.Create; + NewVar.SetParserPos(FParser); + TPSValueData(NewVar).Data := ReadReal(FParser.GetToken); + FParser.Next; + end; + CSTII_Ord: + begin + FParser.Next; + if fParser.Currtokenid <> CSTI_OpenRound then + begin + Result := nil; + MakeError('', ecOpenRoundExpected, ''); + exit; + end; + FParser.Next; + NewVar := ReadExpression(); + if NewVar = nil then + begin + Result := nil; + exit; + end; + if FParser.CurrTokenId <> CSTI_CloseRound then + begin + NewVar.Free; + Result := nil; + MakeError('', ecCloseRoundExpected, ''); + exit; + end; + if not ((GetTypeNo(BlockInfo, NewVar).BaseType = btChar) or + {$IFNDEF PS_NOWIDESTRING} (GetTypeNo(BlockInfo, NewVar).BaseType = btWideChar) or{$ENDIF} + (GetTypeNo(BlockInfo, NewVar).BaseType = btEnum) or (IsIntType(GetTypeNo(BlockInfo, NewVar).BaseType))) then + begin + NewVar.Free; + Result := nil; + MakeError('', ecTypeMismatch, ''); + exit; + end; + NewVarU := TPSUnValueOp.Create; + NewVarU.SetParserPos(FParser); + NewVarU.Operator := otCast; + NewVarU.FType := at2ut(FindBaseType(btu32)); + NewVarU.Val1 := NewVar; + NewVar := NewVarU; + FParser.Next; + end; + CSTII_Chr: + begin + FParser.Next; + if fParser.Currtokenid <> CSTI_OpenRound then + begin + Result := nil; + MakeError('', ecOpenRoundExpected, ''); + exit; + end; + FParser.Next; + NewVar := ReadExpression(); + if NewVar = nil then + begin + Result := nil; + exit; + end; + if FParser.CurrTokenId <> CSTI_CloseRound then + begin + NewVar.Free; + Result := nil; + MakeError('', ecCloseRoundExpected, ''); + exit; + end; + if not (IsIntType(GetTypeNo(BlockInfo, NewVar).BaseType)) then + begin + NewVar.Free; + Result := nil; + MakeError('', ecTypeMismatch, ''); + exit; + end; + NewVarU := TPSUnValueOp.Create; + NewVarU.SetParserPos(FParser); + NewVarU.Operator := otCast; + NewVarU.FType := at2ut(FindBaseType(btChar)); + NewVarU.Val1 := NewVar; + NewVar := NewVarU; + FParser.Next; + end; + CSTI_Identifier: + begin + if FParser.GetToken = 'SUCC' then + begin + FParser.Next; + if FParser.CurrTokenID <> CSTI_OpenRound then + begin + Result := nil; + MakeError('', ecOpenRoundExpected, ''); + exit; + end; + FParser.Next; + NewVar := ReadExpression; + if NewVar = nil then + begin + result := nil; + exit; + end; + if (GetTypeNo(BlockInfo, NewVar) = nil) or (not IsIntType(GetTypeNo(BlockInfo, NewVar).BaseType) and + (GetTypeNo(BlockInfo, NewVar).BaseType <> btEnum)) then + begin + NewVar.Free; + Result := nil; + MakeError('', ecTypeMismatch, ''); + exit; + end; + if FParser.CurrTokenID <> CSTI_CloseRound then + begin + NewVar.Free; + Result := nil; + MakeError('', eccloseRoundExpected, ''); + exit; + end; + NewVar := CallSucc(NewVar); + FParser.Next; + end else + if FParser.GetToken = 'PRED' then + begin + FParser.Next; + if FParser.CurrTokenID <> CSTI_OpenRound then + begin + Result := nil; + MakeError('', ecOpenRoundExpected, ''); + exit; + end; + FParser.Next; + NewVar := ReadExpression; + if NewVar = nil then + begin + result := nil; + exit; + end; + if (GetTypeNo(BlockInfo, NewVar) = nil) or (not IsIntType(GetTypeNo(BlockInfo, NewVar).BaseType) and + (GetTypeNo(BlockInfo, NewVar).BaseType <> btEnum)) then + begin + NewVar.Free; + Result := nil; + MakeError('', ecTypeMismatch, ''); + exit; + end; + if FParser.CurrTokenID <> CSTI_CloseRound then + begin + NewVar.Free; + Result := nil; + MakeError('', eccloseRoundExpected, ''); + exit; + end; + NewVar := CallPred(NewVar); + FParser.Next; + end else + if FParser.GetToken = 'ASSIGNED' then + begin + FParser.Next; + if FParser.CurrTokenID <> CSTI_OpenRound then + begin + Result := nil; + MakeError('', ecOpenRoundExpected, ''); + exit; + end; + FParser.Next; + NewVar := GetIdentifier(0); + if NewVar = nil then + begin + result := nil; + exit; + end; + if (GetTypeNo(BlockInfo, NewVar) = nil) or ((GetTypeNo(BlockInfo, NewVar).BaseType <> btClass) and + (GetTypeNo(BlockInfo, NewVar).BaseType <> btPChar) and + (GetTypeNo(BlockInfo, NewVar).BaseType <> btString)) then + begin + NewVar.Free; + Result := nil; + MakeError('', ecTypeMismatch, ''); + exit; + end; + if FParser.CurrTokenID <> CSTI_CloseRound then + begin + NewVar.Free; + Result := nil; + MakeError('', eccloseRoundExpected, ''); + exit; + end; + NewVar := CallAssigned(NewVar); + FParser.Next; + end else + begin + NewVar := GetIdentifier(0); + if NewVar = nil then + begin + Result := nil; + exit; + end; + end; + end; + else + begin + MakeError('', ecSyntaxError, ''); + Result := nil; + exit; + end; + end; {case} + Result := NewVar; + end; // ReadFactor + + function GetResultType(p1, P2: TPSValue; Cmd: TPSBinOperatorType): TPSType; + var + pp, t1, t2: PIFPSType; + begin + t1 := GetTypeNo(BlockInfo, p1); + t2 := GetTypeNo(BlockInfo, P2); + if (t1 = nil) or (t2 = nil) then + begin + if ((p1.ClassType = TPSValueNil) or (p2.ClassType = TPSValueNil)) and ((t1 <> nil) or (t2 <> nil)) then + begin + if p1.ClassType = TPSValueNil then + pp := t2 + else + pp := t1; + if (pp.BaseType = btPchar) or (pp.BaseType = btString) or (pp.BaseType = btClass) {$IFNDEF PS_NOINTERFACES}or (pp.BaseType =btInterface){$ENDIF} or (pp.BaseType = btProcPtr) then + Result := AT2UT(FDefaultBoolType) + else + Result := nil; + exit; + end; + Result := nil; + exit; + end; + case Cmd of + otAdd: {plus} + begin + if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and ( + ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or + (t2.BaseType = btString) or + {$IFNDEF PS_NOWIDESTRING} + (t2.BaseType = btwideString) or + (t2.BaseType = btUnicodestring) or + (t2.BaseType = btwidechar) or + {$ENDIF} + (t2.BaseType = btPchar) or + (t2.BaseType = btChar) or + (isIntRealType(t2.BaseType))) then + Result := t1 + else + if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and ( + ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or + (t1.BaseType = btString) or + {$IFNDEF PS_NOWIDESTRING} + (t1.BaseType = btUnicodestring) or + (t1.BaseType = btwideString) or + (t1.BaseType = btwidechar) or + {$ENDIF} + (t1.BaseType = btPchar) or + (t1.BaseType = btChar) or + (isIntRealType(t1.BaseType))) then + Result := t2 + else if ((t1.BaseType = btSet) and (t2.BaseType = btSet)) and (t1 = t2) then + Result := t1 + else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then + Result := t1 + else if IsIntRealType(t1.BaseType) and + IsIntRealType(t2.BaseType) then + begin + if IsRealType(t1.BaseType) then + Result := t1 + else + Result := t2; + end + else if (t1.basetype = btSet) and (t2.Name = 'TVARIANTARRAY') then + Result := t1 + else if (t2.basetype = btSet) and (t1.Name = 'TVARIANTARRAY') then + Result := t2 + else if ((t1.BaseType = btPchar) or(t1.BaseType = btString) or (t1.BaseType = btChar)) and ((t2.BaseType = btPchar) or(t2.BaseType = btString) or (t2.BaseType = btChar)) then + Result := at2ut(FindBaseType(btString)) + {$IFNDEF PS_NOWIDESTRING} + else if ((t1.BaseType = btString) or (t1.BaseType = btChar) or (t1.BaseType = btPchar)or (t1.BaseType = btWideString) or (t1.BaseType = btWideChar) or (t1.BaseType = btUnicodeString)) and + ((t2.BaseType = btString) or (t2.BaseType = btChar) or (t2.BaseType = btPchar) or (t2.BaseType = btWideString) or (t2.BaseType = btWideChar) or (t2.BaseType = btUnicodeString)) then + Result := at2ut(FindBaseType(btWideString)) + {$ENDIF} + else + Result := nil; + end; + otSub, otMul, otDiv: { - * / } + begin + if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and ( + ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or + (isIntRealType(t2.BaseType))) then + Result := t1 + else if ((t1.BaseType = btSet) and (t2.BaseType = btSet)) and (t1 = t2) and ((cmd = otSub) or (cmd = otMul)) then + Result := t1 + else if (t1.basetype = btSet) and (t2.Name = 'TVARIANTARRAY') and ((cmd = otSub) or (cmd = otMul)) then + Result := t1 + else if (t2.basetype = btSet) and (t1.Name = 'TVARIANTARRAY') and ((cmd = otSub) or (cmd = otMul)) then + Result := t2 + else + if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and ( + ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or + (isIntRealType(t1.BaseType))) then + Result := t2 + else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then + Result := t1 + else if IsIntRealType(t1.BaseType) and + IsIntRealType(t2.BaseType) then + begin + if IsRealType(t1.BaseType) then + Result := t1 + else + Result := t2; + end + else + Result := nil; + end; + otAnd, otOr, otXor: {and,or,xor} + begin + if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and ( + ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or + (isIntType(t2.BaseType))) then + Result := t1 + else + if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and ( + ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or + (isIntType(t1.BaseType))) then + Result := t2 + else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then + Result := t1 + else if (IsBoolean(t1)) and ((t2 = t1) or ((t2.BaseType = btVariant) + or (t2.BaseType = btNotificationVariant))) then + begin + Result := t1; + if ((p1.ClassType = TPSValueData) or (p2.ClassType = TPSValueData)) then + begin + if cmd = otAnd then {and} + begin + if p1.ClassType = TPSValueData then + begin + if (TPSValueData(p1).FData^.tu8 <> 0) then + begin + with MakeWarning('', ewIsNotNeeded, '"True and"') do + begin + FRow := p1.Row; + FCol := p1.Col; + FPosition := p1.Pos; + end; + end else + begin + with MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'False') do + begin + FRow := p1.Row; + FCol := p1.Col; + FPosition := p1.Pos; + end; + end; + end else begin + if (TPSValueData(p2).Data.tu8 <> 0) then + begin + with MakeWarning('', ewIsNotNeeded, '"and True"') do + begin + FRow := p1.Row; + FCol := p1.Col; + FPosition := p1.Pos; + end; + end + else + begin + with MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'False') do + begin + FRow := p1.Row; + FCol := p1.Col; + FPosition := p1.Pos; + end; + end; + end; + end else if cmd = otOr then {or} + begin + if p1.ClassType = TPSValueData then + begin + if (TPSValueData(p1).Data.tu8 <> 0) then + begin + with MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'True') do + begin + FRow := p1.Row; + FCol := p1.Col; + FPosition := p1.Pos; + end; + end + else + begin + with MakeWarning('', ewIsNotNeeded, '"False or"') do + begin + FRow := p1.Row; + FCol := p1.Col; + FPosition := p1.Pos; + end; + end + end else begin + if (TPSValueData(p2).Data.tu8 <> 0) then + begin + with MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'True') do + begin + FRow := p1.Row; + FCol := p1.Col; + FPosition := p1.Pos; + end; + end + else + begin + with MakeWarning('', ewIsNotNeeded, '"or False"') do + begin + FRow := p1.Row; + FCol := p1.Col; + FPosition := p1.Pos; + end; + end + end; + end; + end; + end else + Result := nil; + end; + otMod, otShl, otShr: {mod,shl,shr} + begin + if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and ( + ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or + (isIntType(t2.BaseType))) then + Result := t1 + else + if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and ( + ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or + (isIntType(t1.BaseType))) then + Result := t2 + else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then + Result := t1 + else + Result := nil; + end; + otGreater, otLess, otGreaterEqual, otLessEqual: { >=, <=, >, <} + begin + if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and ( + ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or + (t2.BaseType = btString) or + (t2.BaseType = btPchar) or + (t2.BaseType = btChar) or + (isIntRealType(t2.BaseType))) then + Result := FDefaultBoolType + else if ((t1.BaseType = btSet) and (t2.BaseType = btSet)) and (t1 = t2) and ((cmd = otGreaterEqual) or (cmd = otLessEqual)) then + Result := FDefaultBoolType + else + if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and ( + ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or + (t1.BaseType = btString) or + (t1.BaseType = btPchar) or + (t1.BaseType = btChar) or + (isIntRealType(t1.BaseType))) then + Result := FDefaultBoolType + else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then + Result := FDefaultBoolType + else if IsIntRealType(t1.BaseType) and + IsIntRealType(t2.BaseType) then + Result := FDefaultBoolType + else if + ((t1.BaseType = btString) or (t1.BaseType = btChar) {$IFNDEF PS_NOWIDESTRING} or (t1.BaseType = btWideString) or (t1.BaseType = btWideChar) or (t1.BaseType = btUnicodestring){$ENDIF}) and + ((t2.BaseType = btString) or (t2.BaseType = btChar) {$IFNDEF PS_NOWIDESTRING} or (t2.BaseType = btWideString) or (t2.BaseType = btWideChar) or (t2.BaseType = btUnicodestring){$ENDIF}) then + Result := FDefaultBoolType + else if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) then + Result := FDefaultBoolType + else + Result := nil; + end; + otEqual, otNotEqual: {=, <>} + begin + if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and ( + ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or + (t2.BaseType = btString) or + (t2.BaseType = btPchar) or + (t2.BaseType = btChar) or + (isIntRealType(t2.BaseType))) then + Result := FDefaultBoolType + else if ((t1.BaseType = btSet) and (t2.BaseType = btSet)) and (t1 = t2) then + Result := FDefaultBoolType + else + if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and ( + ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or + (t1.BaseType = btString) or + (t1.BaseType = btPchar) or + (t1.BaseType = btChar) or + (isIntRealType(t1.BaseType))) then + Result := FDefaultBoolType + else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then + Result := FDefaultBoolType + else if IsIntRealType(t1.BaseType) and + IsIntRealType(t2.BaseType) then + Result := FDefaultBoolType + else if + ((t1.BaseType = btString) or (t1.BaseType = btChar) {$IFNDEF PS_NOWIDESTRING} or (t1.BaseType = btWideString) or (t1.BaseType = btWideChar) or (t1.BaseType = btUnicodestring){$ENDIF}) and + ((t2.BaseType = btString) or (t2.BaseType = btChar) {$IFNDEF PS_NOWIDESTRING} or (t2.BaseType = btWideString) or (t2.BaseType = btWideChar) or (t2.BaseType = btUnicodestring){$ENDIF}) then + Result := FDefaultBoolType + else if (t1.basetype = btSet) and (t2.Name = 'TVARIANTARRAY') then + Result := FDefaultBoolType + else if (t2.basetype = btSet) and (t1.Name = 'TVARIANTARRAY') then + Result := FDefaultBoolType + else if (t1.BaseType = btEnum) and (t1 = t2) then + Result := FDefaultBoolType + else if (t1.BaseType = btClass) and (t2.BaseType = btClass) then + Result := FDefaultBoolType + else if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) then + Result := FDefaultBoolType + else Result := nil; + end; + otIn: + begin + if (t2.Name = 'TVARIANTARRAY') then + Result := FDefaultBoolType + else + if (t2.BaseType = btSet) and (TPSSetType(t2).SetType = t1) then + Result := FDefaultBoolType + else + Result := nil; + end; + otIs: + begin + if t2.BaseType = btType then + begin + Result := FDefaultBoolType + end else + Result := nil; + end; + otAs: + begin + if t2.BaseType = btType then + begin + Result := at2ut(TPSValueData(p2).Data.ttype); + end else + Result := nil; + end; + else + Result := nil; + end; + end; + + + function ReadTerm: TPSValue; + var + F1, F2: TPSValue; + F: TPSBinValueOp; + Token: TPSPasToken; + Op: TPSBinOperatorType; + begin + F1 := ReadFactor; + if F1 = nil then + begin + Result := nil; + exit; + end; + while FParser.CurrTokenID in [CSTI_Multiply, CSTI_Divide, CSTII_Div, CSTII_Mod, CSTII_And, CSTII_Shl, CSTII_Shr, CSTII_As] do + begin + Token := FParser.CurrTokenID; + FParser.Next; + F2 := ReadFactor; + if f2 = nil then + begin + f1.Free; + Result := nil; + exit; + end; + case Token of + CSTI_Multiply: Op := otMul; + CSTII_div, CSTI_Divide: Op := otDiv; + CSTII_mod: Op := otMod; + CSTII_and: Op := otAnd; + CSTII_shl: Op := otShl; + CSTII_shr: Op := otShr; + CSTII_As: Op := otAs; + else + Op := otAdd; + end; + F := TPSBinValueOp.Create; + f.Val1 := F1; + f.Val2 := F2; + f.Operator := Op; + f.aType := GetResultType(F1, F2, Op); + if f.aType = nil then + begin + MakeError('', ecTypeMismatch, ''); + f.Free; + Result := nil; + exit; + end; + f1 := f; + end; + Result := F1; + end; // ReadTerm + + function ReadSimpleExpression: TPSValue; + var + F1, F2: TPSValue; + F: TPSBinValueOp; + Token: TPSPasToken; + Op: TPSBinOperatorType; + begin + F1 := ReadTerm; + if F1 = nil then + begin + Result := nil; + exit; + end; + while FParser.CurrTokenID in [CSTI_Plus, CSTI_Minus, CSTII_Or, CSTII_Xor] do + begin + Token := FParser.CurrTokenID; + FParser.Next; + F2 := ReadTerm; + if f2 = nil then + begin + f1.Free; + Result := nil; + exit; + end; + case Token of + CSTI_Plus: Op := otAdd; + CSTI_Minus: Op := otSub; + CSTII_or: Op := otOr; + CSTII_xor: Op := otXor; + else + Op := otAdd; + end; + F := TPSBinValueOp.Create; + f.Val1 := F1; + f.Val2 := F2; + f.Operator := Op; + f.aType := GetResultType(F1, F2, Op); + if f.aType = nil then + begin + MakeError('', ecTypeMismatch, ''); + f.Free; + Result := nil; + exit; + end; + f1 := f; + end; + Result := F1; + end; // ReadSimpleExpression + + + function ReadExpression: TPSValue; + var + F1, F2: TPSValue; + F: TPSBinValueOp; + Token: TPSPasToken; + Op: TPSBinOperatorType; + begin + F1 := ReadSimpleExpression; + if F1 = nil then + begin + Result := nil; + exit; + end; + while FParser.CurrTokenID in [ CSTI_GreaterEqual, CSTI_LessEqual, CSTI_Greater, CSTI_Less, CSTI_Equal, CSTI_NotEqual, CSTII_in, CSTII_is] do + begin + Token := FParser.CurrTokenID; + FParser.Next; + F2 := ReadSimpleExpression; + if f2 = nil then + begin + f1.Free; + Result := nil; + exit; + end; + case Token of + CSTI_GreaterEqual: Op := otGreaterEqual; + CSTI_LessEqual: Op := otLessEqual; + CSTI_Greater: Op := otGreater; + CSTI_Less: Op := otLess; + CSTI_Equal: Op := otEqual; + CSTI_NotEqual: Op := otNotEqual; + CSTII_in: Op := otIn; + CSTII_is: Op := otIs; + else + Op := otAdd; + end; + F := TPSBinValueOp.Create; + f.Val1 := F1; + f.Val2 := F2; + f.Operator := Op; + f.aType := GetResultType(F1, F2, Op); + if f.aType = nil then + begin + MakeError('', ecTypeMismatch, ''); + f.Free; + Result := nil; + exit; + end; + f1 := f; + end; + Result := F1; + end; // ReadExpression + + function TryEvalConst(var P: TPSValue): Boolean; + var + preplace: TPSValue; + begin + if p is TPSBinValueOp then + begin + if not (TryEvalConst(TPSBinValueOp(p).FVal1) and TryEvalConst(TPSBinValueOp(p).FVal2)) then + begin + Result := False; + exit; + end; + if (TPSBinValueOp(p).FVal1.ClassType = TPSValueData) and (TPSBinValueOp(p).FVal2.ClassType = TPSValueData) then + begin + if not PreCalc(True, 0, TPSValueData(TPSBinValueOp(p).Val1).Data, 0, TPSValueData(TPSBinValueOp(p).Val2).Data, TPSBinValueOp(p).Operator, p.Pos, p.Row, p.Col) then + begin + Result := False; + exit; + end; + preplace := TPSValueData.Create; + preplace.Pos := p.Pos; + preplace.Row := p.Row; + preplace.Col := p.Col; + TPSValueData(preplace).Data := TPSValueData(TPSBinValueOp(p).Val1).Data; + TPSValueData(TPSBinValueOp(p).Val1).Data := nil; + p.Free; + p := preplace; + end; + end else if p is TPSUnValueOp then + begin + if not TryEvalConst(TPSUnValueOp(p).FVal1) then + begin + Result := False; + exit; + end; + if TPSUnValueOp(p).FVal1.ClassType = TPSValueData then + begin +// + case TPSUnValueOp(p).Operator of + otNot: + begin + case TPSValueData(TPSUnValueOp(p).FVal1).Data^.FType.BaseType of + btEnum: + begin + if IsBoolean(TPSValueData(TPSUnValueOp(p).FVal1).Data^.FType) then + begin + TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8 := (not TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8) and 1; + end else + begin + MakeError('', ecTypeMismatch, ''); + Result := False; + exit; + end; + end; + btU8: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8; + btU16: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16; + btU32: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu32 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu32; + bts8: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts8 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts8; + bts16: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts16 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts16; + bts32: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts32 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts32; + {$IFNDEF PS_NOINT64} + bts64: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64; + {$ENDIF} + else + begin + MakeError('', ecTypeMismatch, ''); + Result := False; + exit; + end; + end; + preplace := TPSUnValueOp(p).Val1; + TPSUnValueOp(p).Val1 := nil; + p.Free; + p := preplace; + end; + otMinus: + begin + case TPSValueData(TPSUnValueOp(p).FVal1).Data^.FType.BaseType of + btU8: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8; + btU16: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16; + btU32: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu32 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu32; + bts8: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts8 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts8; + bts16: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts16 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts16; + bts32: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts32 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts32; + {$IFNDEF PS_NOINT64} + bts64: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64; + {$ENDIF} + btSingle: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tsingle := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tsingle; + btDouble: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tdouble := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tdouble; + btExtended: TPSValueData(TPSUnValueOp(p).FVal1).Data^.textended := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.textended; + btCurrency: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tcurrency := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tcurrency; + else + begin + MakeError('', ecTypeMismatch, ''); + Result := False; + exit; + end; + end; + preplace := TPSUnValueOp(p).Val1; + TPSUnValueOp(p).Val1 := nil; + p.Free; + p := preplace; + end; + otCast: + begin + preplace := TPSValueData.Create; + TPSValueData(preplace).Data := NewVariant(TPSUnValueOp(p).FType); + case TPSUnValueOp(p).FType.BaseType of + btU8: + begin + case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of + btchar: TPSValueData(preplace).Data.tu8 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); + {$IFNDEF PS_NOWIDESTRING} + btwidechar: TPSValueData(preplace).Data.tu8 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar); + {$ENDIF} + btU8: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8; + btS8: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8; + btU16: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16; + btS16: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16; + btU32: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32; + btS32: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32; + {$IFNDEF PS_NOINT64} + btS64: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64; + {$ENDIF} + else + begin + MakeError('', ecTypeMismatch, ''); + preplace.Free; + Result := False; + exit; + end; + end; + end; + btS8: + begin + case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of + btchar: TPSValueData(preplace).Data.ts8 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); + {$IFNDEF PS_NOWIDESTRING} + btwidechar: TPSValueData(preplace).Data.ts8 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar); + {$ENDIF} + btU8: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8; + btS8: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8; + btU16: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16; + btS16: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16; + btU32: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32; + btS32: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32; + {$IFNDEF PS_NOINT64} + btS64: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64; + {$ENDIF} + else + begin + MakeError('', ecTypeMismatch, ''); + preplace.Free; + Result := False; + exit; + end; + end; + end; + btU16: + begin + case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of + btchar: TPSValueData(preplace).Data.tu16 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); + {$IFNDEF PS_NOWIDESTRING} + btwidechar: TPSValueData(preplace).Data.tu16 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar); + {$ENDIF} + btU8: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8; + btS8: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8; + btU16: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16; + btS16: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16; + btU32: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32; + btS32: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32; + {$IFNDEF PS_NOINT64} + btS64: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64; + {$ENDIF} + else + begin + MakeError('', ecTypeMismatch, ''); + preplace.Free; + Result := False; + exit; + end; + end; + end; + bts16: + begin + case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of + btchar: TPSValueData(preplace).Data.ts16 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); + {$IFNDEF PS_NOWIDESTRING} + btwidechar: TPSValueData(preplace).Data.ts16 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar); + {$ENDIF} + btU8: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8; + btS8: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8; + btU16: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16; + btS16: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16; + btU32: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32; + btS32: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32; + {$IFNDEF PS_NOINT64} + btS64: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64; + {$ENDIF} + else + begin + MakeError('', ecTypeMismatch, ''); + preplace.Free; + Result := False; + exit; + end; + end; + end; + btU32: + begin + case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of + btchar: TPSValueData(preplace).Data.tu32 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); + {$IFNDEF PS_NOWIDESTRING} + btwidechar: TPSValueData(preplace).Data.tu32 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar); + {$ENDIF} + btU8: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8; + btS8: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8; + btU16: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16; + btS16: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16; + btU32: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32; + btS32: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32; + {$IFNDEF PS_NOINT64} + btS64: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64; + {$ENDIF} + else + begin + MakeError('', ecTypeMismatch, ''); + preplace.Free; + Result := False; + exit; + end; + end; + end; + btS32: + begin + case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of + btchar: TPSValueData(preplace).Data.ts32 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); + {$IFNDEF PS_NOWIDESTRING} + btwidechar: TPSValueData(preplace).Data.ts32 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar); + {$ENDIF} + btU8: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8; + btS8: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8; + btU16: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16; + btS16: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16; + btU32: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32; + btS32: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32; + {$IFNDEF PS_NOINT64} + btS64: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64; + {$ENDIF} + else + begin + MakeError('', ecTypeMismatch, ''); + preplace.Free; + Result := False; + exit; + end; + end; + end; + {$IFNDEF PS_NOINT64} + btS64: + begin + case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of + btchar: TPSValueData(preplace).Data.ts64 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); + {$IFNDEF PS_NOWIDESTRING} + btwidechar: TPSValueData(preplace).Data.ts64 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar); + {$ENDIF} + btU8: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8; + btS8: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8; + btU16: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16; + btS16: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16; + btU32: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32; + btS32: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32; + btS64: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64; + else + begin + MakeError('', ecTypeMismatch, ''); + preplace.Free; + Result := False; + exit; + end; + end; + end; + {$ENDIF} + btChar: + begin + case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of + btchar: TPSValueData(preplace).Data.tchar := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar; + btU8: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8); + btS8: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8); + btU16: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16); + btS16: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16); + btU32: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32); + btS32: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32); + {$IFNDEF PS_NOINT64} + btS64: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64); + {$ENDIF} + else + begin + MakeError('', ecTypeMismatch, ''); + Result := False; + preplace.Free; + exit; + end; + end; + end; + else + begin + MakeError('', ecTypeMismatch, ''); + Result := False; + preplace.Free; + exit; + end; + end; + p.Free; + p := preplace; + end; + else + begin + MakeError('', ecTypeMismatch, ''); + Result := False; + exit; + end; + end; // case + end; // if + end; + Result := True; + end; + + var + Val: TPSValue; + +begin + Val := ReadExpression; + if Val = nil then + begin + Result := nil; + exit; + end; + if not TryEvalConst(Val) then + begin + Val.Free; + Result := nil; + exit; + end; + Result := Val; + end; + + function ReadParameters(IsProperty: Boolean; Dest: TPSParameters): Boolean; + var + sr,cr: TPSPasToken; + begin + if IsProperty then + begin + sr := CSTI_OpenBlock; + cr := CSTI_CloseBlock; + end else begin + sr := CSTI_OpenRound; + cr := CSTI_CloseRound; + end; + if FParser.CurrTokenId = sr then + begin + FParser.Next; + if FParser.CurrTokenId = cr then + begin + FParser.Next; + Result := True; + exit; + end; + end else + begin + result := True; + exit; + end; + repeat + with Dest.Add do + begin + Val := calc(CSTI_CloseRound); + if Val = nil then + begin + result := false; + exit; + end; + end; + if FParser.CurrTokenId = cr then + begin + FParser.Next; + Break; + end; + if FParser.CurrTokenId <> CSTI_Comma then + begin + MakeError('', ecCommaExpected, ''); + Result := false; + exit; + end; {if} + FParser.Next; + until False; + Result := true; + end; + + function ReadProcParameters(ProcNo: Cardinal; FSelf: TPSValue): TPSValue; + var + Decl: TPSParametersDecl; + begin + if TPSProcedure(FProcs[ProcNo]).ClassType = TPSInternalProcedure then + Decl := TPSInternalProcedure(FProcs[ProcNo]).Decl + else + Decl := TPSExternalProcedure(FProcs[ProcNo]).RegProc.Decl; + UseProc(Decl); + Result := TPSValueProcNo.Create; + TPSValueProcNo(Result).ProcNo := ProcNo; + TPSValueProcNo(Result).ResultType := Decl.Result; + with TPSValueProcNo(Result) do + begin + SetParserPos(FParser); + Parameters := TPSParameters.Create; + if FSelf <> nil then + begin + Parameters.Add; + end; + end; + + if not ReadParameters(False, TPSValueProc(Result).Parameters) then + begin + FSelf.Free; + Result.Free; + Result := nil; + exit; + end; + + if not ValidateParameters(BlockInfo, TPSValueProc(Result).Parameters, Decl) then + begin + FSelf.Free; + Result.Free; + Result := nil; + exit; + end; + if FSelf <> nil then + begin + with TPSValueProcNo(Result).Parameters[0] do + begin + Val := FSelf; + ExpectedType := GetTypeNo(BlockInfo, FSelf); + end; + end; + end; + {$IFNDEF PS_NOIDISPATCH} + + function ReadIDispatchParameters(const ProcName: tbtString; aVariantType: TPSVariantType; FSelf: TPSValue): TPSValue; + var + Par: TPSParameters; + PropSet: Boolean; + i: Longint; + Temp: TPSValue; + begin + Par := TPSParameters.Create; + try + if not ReadParameters(FParser.CurrTokenID = CSTI_OpenBlock, Par) then + begin + FSelf.Free; + Result := nil; + exit; + end; + + if FParser.CurrTokenID = CSTI_Assignment then + begin + FParser.Next; + PropSet := True; + Temp := calc(CSTI_SemiColon); + if temp = nil then + begin + FSelf.Free; + Result := nil; + exit; + end; + with par.Add do + begin + FValue := Temp; + end; + end else + begin + PropSet := False; + end; + + Result := TPSValueProcNo.Create; + TPSValueProcNo(Result).ResultType := aVariantType; + with TPSValueProcNo(Result) do + begin + SetParserPos(FParser); + Parameters := TPSParameters.Create; + if FSelf <> nil then + begin + with Parameters.Add do + begin + Val := FSelf; + ExpectedType := aVariantType.GetDynIvokeSelfType(Self); + end; + with Parameters.Add do + begin + Val := TPSValueData.Create; + TPSValueData(Val).Data := NewVariant(FDefaultBoolType); + TPSValueData(Val).Data.tu8 := Ord(PropSet); + ExpectedType := FDefaultBoolType; + end; + + with Parameters.Add do + begin + Val := TPSValueData.Create; + TPSValueData(Val).Data := NewVariant(FindBaseType(btString)); + tbtString(TPSValueData(Val).data.tString) := Procname; + ExpectedType := FindBaseType(btString); + end; + + with Parameters.Add do + begin + val := TPSValueArray.Create; + ExpectedType := aVariantType.GetDynInvokeParamType(Self); + temp := Val; + end; + for i := 0 to Par.Count -1 do + begin + TPSValueArray(Temp).Add(par.Item[i].Val); + par.Item[i].val := nil; + end; + end; + end; + TPSValueProcNo(Result).ProcNo := aVariantType.GetDynInvokeProcNo(Self, ProcName, TPSValueProcNo(Result).Parameters); + finally + Par.Free; + end; + + end; + + {$ENDIF} + + function ReadVarParameters(ProcNoVar: TPSValue): TPSValue; + var + Decl: TPSParametersDecl; + begin + Decl := TPSProceduralType(GetTypeNo(BlockInfo, ProcnoVar)).ProcDef; + UseProc(Decl); + + Result := TPSValueProcVal.Create; + + with TPSValueProcVal(Result) do + begin + ResultType := Decl.Result; + ProcNo := ProcNoVar; + Parameters := TPSParameters.Create; + end; + + if not ReadParameters(False, TPSValueProc(Result).Parameters) then + begin + Result.Free; + Result := nil; + exit; + end; + + if not ValidateParameters(BlockInfo, TPSValueProc(Result).Parameters, Decl) then + begin + Result.Free; + Result := nil; + exit; + end; + end; + + + function WriteCalculation(InData, OutReg: TPSValue): Boolean; + + function CheckOutreg(Where, Outreg: TPSValue; aRoot: Boolean): Boolean; + var + i: Longint; + begin + Result := False; + if Outreg is TPSValueReplace + then Outreg:=TPSValueReplace(Outreg).OldValue; + if Where is TPSValueVar then begin + if TPSValueVar(Where).GetRecCount > 0 then result := true; + if SAmeReg(Where, OutReg) and not aRoot then + result := true; + end else + if Where.ClassType = TPSUnValueOp then + begin + if CheckOutReg(TPSUnValueOp(Where).Val1, OutReg, aRoot) then + Result := True; + end else if Where.ClassType = TPSBinValueOp then + begin + if CheckOutreg(TPSBinValueOp(Where).Val1, OutReg, aRoot) or CheckOutreg(TPSBinValueOp(Where).Val2, OutReg, False) then + Result := True; + end else if Where is TPSValueVar then + begin + if SameReg(Where, OutReg) then + Result := True; + end else if Where is TPSValueProc then + begin + for i := 0 to TPSValueProc(Where).Parameters.Count -1 do + begin + if Checkoutreg(TPSValueProc(Where).Parameters[i].Val, Outreg, false) then + begin + Result := True; + break; + end; + end; + end; + end; + begin + if not CheckCompatType(Outreg, InData) then + begin + MakeError('', ecTypeMismatch, ''); + Result := False; + exit; + end; + if SameReg(OutReg, InData) then + begin + Result := True; + exit; + end; + if InData is TPSValueProc then + begin + Result := _ProcessFunction(TPSValueProc(indata), OutReg) + end else begin + if not PreWriteOutRec(OutReg, nil) then + begin + Result := False; + exit; + end; + if (not CheckOutReg(InData, OutReg, true)) and (InData is TPSBinValueOp) or (InData is TPSUnValueOp) then + begin + if InData is TPSBinValueOp then + begin + if not DoBinCalc(TPSBinValueOp(InData), OutReg) then + begin + AfterWriteOutRec(OutReg); + Result := False; + exit; + end; + end else + begin + if not DoUnCalc(TPSUnValueOp(InData), OutReg) then + begin + AfterWriteOutRec(OutReg); + Result := False; + exit; + end; + end; + end else if (InData is TPSBinValueOp) and (not CheckOutReg(TPSBinValueOp(InData).Val2, OutReg, false)) then + begin + if not DoBinCalc(TPSBinValueOp(InData), OutReg) then + begin + AfterWriteOutRec(OutReg); + Result := False; + exit; + end; + end else begin + if not PreWriteOutRec(InData, GetTypeNo(BlockInfo, OutReg)) then + begin + Result := False; + exit; + end; + BlockWriteByte(BlockInfo, CM_A); + if not (WriteOutRec(OutReg, False) and WriteOutRec(InData, True)) then + begin + Result := False; + exit; + end; + AfterWriteOutRec(InData); + end; + AfterWriteOutRec(OutReg); + Result := True; + end; + end; {WriteCalculation} + + + function _ProcessFunction(ProcCall: TPSValueProc; ResultRegister: TPSValue): Boolean; + var + res: TPSType; + tmp: TPSParameter; + lTv: TPSValue; + resreg: TPSValue; + l: Longint; + + function Cleanup: Boolean; + var + i: Longint; + begin + for i := 0 to ProcCall.Parameters.Count -1 do + begin + if ProcCall.Parameters[i].TempVar <> nil then + ProcCall.Parameters[i].TempVar.Free; + ProcCall.Parameters[i].TempVar := nil; + end; + if ProcCall is TPSValueProcVal then + AfterWriteOutRec(TPSValueProcVal(ProcCall).fProcNo); + if ResReg <> nil then + AfterWriteOutRec(resreg); + if ResReg <> nil then + begin + if ResReg <> ResultRegister then + begin + if ResultRegister <> nil then + begin + if not WriteCalculation(ResReg, ResultRegister) then + begin + Result := False; + resreg.Free; + exit; + end; + end; + resreg.Free; + end; + end; + Result := True; + end; + + begin + Res := ProcCall.ResultType; + Result := False; + if (res = nil) and (ResultRegister <> nil) then + begin + MakeError('', ecNoResult, ''); + exit; + end + else if (res <> nil) then + begin + if (ResultRegister = nil) or (Res <> GetTypeNo(BlockInfo, ResultRegister)) then + begin + resreg := AllocStackReg(res); + + end else resreg := ResultRegister; + end + else + resreg := nil; + if ResReg <> nil then + begin + if not PreWriteOutRec(resreg, nil) then + begin + Cleanup; + exit; + end; + end; + if Proccall is TPSValueProcVal then + begin + if not PreWriteOutRec(TPSValueProcVal(ProcCall).fProcNo, nil) then + begin + Cleanup; + exit; + end; + end; + for l := ProcCall.Parameters.Count - 1 downto 0 do + begin + Tmp := ProcCall.Parameters[l]; + if (Tmp.ParamMode <> pmIn) then + begin + if IsVarInCompatible(GetTypeNo(BlockInfo, tmp.Val), tmp.ExpectedType) then + begin + with MakeError('', ecTypeMismatch, '') do + begin + pos := tmp.Val.Pos; + row := tmp.Val.row; + col := tmp.Val.col; + end; + Cleanup; + exit; + end; + if Copy(tmp.ExpectedType.Name, 1, 10) = '!OPENARRAY' then begin + tmp.TempVar := AllocPointer(tmp.ExpectedType); + lTv := AllocStackReg(tmp.ExpectedType); + if not PreWriteOutRec(Tmp.FValue, nil) then + begin + cleanup; + exit; + end; + BlockWriteByte(BlockInfo, CM_A); + WriteOutRec(lTv, False); + WriteOutRec(Tmp.FValue, False); + AfterWriteOutRec(Tmp.FValue); + + BlockWriteByte(BlockInfo, cm_sp); + WriteOutRec(tmp.TempVar, False); + WriteOutRec(lTv, False); + + lTv.Free; +// BlockWriteByte(BlockInfo, CM_PO); // pop the temp var + + end else begin + tmp.TempVar := AllocPointer(GetTypeNo(BlockInfo, Tmp.FValue)); + if not PreWriteOutRec(Tmp.FValue, nil) then + begin + cleanup; + exit; + end; + BlockWriteByte(BlockInfo, cm_sp); + WriteOutRec(tmp.TempVar, False); + WriteOutRec(Tmp.FValue, False); + AfterWriteOutRec(Tmp.FValue); + end; + end + else + begin + if Tmp.ExpectedType = nil then + Tmp.ExpectedType := GetTypeNo(BlockInfo, tmp.Val); + if Tmp.ExpectedType.BaseType = btPChar then + begin + Tmp.TempVar := AllocStackReg(at2ut(FindBaseType(btstring))) + end else + begin + Tmp.TempVar := AllocStackReg(Tmp.ExpectedType); + end; + if not WriteCalculation(Tmp.Val, Tmp.TempVar) then + begin + Cleanup; + exit; + end; + end; + end; {for} + if res <> nil then + begin + BlockWriteByte(BlockInfo, CM_PV); + + if not WriteOutRec(resreg, False) then + begin + Cleanup; + MakeError('', ecInternalError, '00015'); + exit; + end; + end; + if ProcCall is TPSValueProcVal then + begin + BlockWriteByte(BlockInfo, Cm_cv); + WriteOutRec(TPSValueProcVal(ProcCall).ProcNo, True); + end else begin + BlockWriteByte(BlockInfo, CM_C); + BlockWriteLong(BlockInfo, TPSValueProcNo(ProcCall).ProcNo); + end; + if res <> nil then + BlockWriteByte(BlockInfo, CM_PO); + if not Cleanup then + begin + Result := False; + exit; + end; + Result := True; + end; {ProcessVarFunction} + + function HasInvalidJumps(StartPos, EndPos: Cardinal): Boolean; + var + I, J: Longint; + Ok: LongBool; + FLabelsInBlock: TIfStringList; + s: tbtString; + begin + FLabelsInBlock := TIfStringList.Create; + for i := 0 to BlockInfo.Proc.FLabels.Count -1 do + begin + s := BlockInfo.Proc.FLabels[I]; + if (Cardinal((@s[1])^) >= StartPos) and (Cardinal((@s[1])^) <= EndPos) then + begin + Delete(s, 1, 8); + FLabelsInBlock.Add(s); + end; + end; + for i := 0 to BlockInfo.Proc.FGotos.Count -1 do + begin + s := BlockInfo.Proc.FGotos[I]; + if (Cardinal((@s[1])^) >= StartPos) and (Cardinal((@s[1])^) <= EndPos) then + begin + Delete(s, 1, 4); + s := BlockInfo.Proc.FLabels[Cardinal((@s[1])^)]; + Delete(s,1,8); + OK := False; + for J := 0 to FLabelsInBlock.Count -1 do + begin + if FLabelsInBlock[J] = s then + begin + Ok := True; + Break; + end; + end; + if not Ok then + begin + MakeError('', ecInvalidJump, ''); + Result := True; + FLabelsInBlock.Free; + exit; + end; + end else begin + Delete(s, 1, 4); + s := BlockInfo.Proc.FLabels[Cardinal((@s[1])^)]; + Delete(s,1,8); + OK := True; + for J := 0 to FLabelsInBlock.Count -1 do + begin + if FLabelsInBlock[J] = s then + begin + Ok := False; + Break; + end; + end; + if not Ok then + begin + MakeError('', ecInvalidJump, ''); + Result := True; + FLabelsInBlock.Free; + exit; + end; + end; + end; + FLabelsInBlock.Free; + Result := False; + end; + + function ProcessFor: Boolean; + { Process a for x := y to z do } + var + VariableVar: TPSValue; + TempBool, + InitVal, + finVal: TPSValue; + Block: TPSBlockInfo; + Backwards: Boolean; + FPos, NPos, EPos, RPos: Longint; + OldCO, OldBO: TPSList; + I: Longint; + iOldWithCount: Integer; + iOldTryCount: Integer; + iOldExFnlCount: Integer; + lType: TPSType; + begin + Debug_WriteLine(BlockInfo); + Result := False; + FParser.Next; + if FParser.CurrTokenId <> CSTI_Identifier then + begin + MakeError('', ecIdentifierExpected, ''); + exit; + end; + VariableVar := GetIdentifier(1); + if VariableVar = nil then + exit; + lType := GetTypeNo(BlockInfo, VariableVar); + if lType = nil then begin + MakeError('', ecTypeMismatch, ''); + VariableVar.Free; + exit; + end; + case lType.BaseType of + btU8, btS8, btU16, btS16, btU32, btS32, {$IFNDEF PS_NOINT64} btS64, {$ENDIF} btVariant: ; + else + begin + MakeError('', ecTypeMismatch, ''); + VariableVar.Free; + exit; + end; + end; + if FParser.CurrTokenId <> CSTI_Assignment then + begin + MakeError('', ecAssignmentExpected, ''); + VariableVar.Free; + exit; + end; + FParser.Next; + InitVal := calc(CSTII_DownTo); + if InitVal = nil then + begin + VariableVar.Free; + exit; + end; + if FParser.CurrTokenId = CSTII_To then + Backwards := False + else if FParser.CurrTokenId = CSTII_DownTo then + Backwards := True + else + begin + MakeError('', ecToExpected, ''); + VariableVar.Free; + InitVal.Free; + exit; + end; + FParser.Next; + finVal := calc(CSTII_do); + if finVal = nil then + begin + VariableVar.Free; + InitVal.Free; + exit; + end; + lType := GetTypeNo(BlockInfo, finVal); + if lType = nil then begin + MakeError('', ecTypeMismatch, ''); + VariableVar.Free; + InitVal.Free; + exit; + end; + case lType.BaseType of + btVariant, btU8, btS8, btU16, btS16, btU32, btS32: ; + else + begin + MakeError('', ecTypeMismatch, ''); + VariableVar.Free; + InitVal.Free; + exit; + end; + end; + if FParser.CurrTokenId <> CSTII_do then + begin + MakeError('', ecDoExpected, ''); + finVal.Free; + InitVal.Free; + VariableVar.Free; + exit; + end; + FParser.Next; + if not WriteCalculation(InitVal, VariableVar) then + begin + VariableVar.Free; + InitVal.Free; + finVal.Free; + exit; + end; + InitVal.Free; + TempBool := AllocStackReg(at2ut(FDefaultBoolType)); + NPos := Length(BlockInfo.Proc.Data); + if not (PreWriteOutRec(VariableVar, nil) and PreWriteOutRec(finVal, nil)) then + begin + TempBool.Free; + VariableVar.Free; + finVal.Free; + exit; + end; + BlockWriteByte(BlockInfo, CM_CO); + if Backwards then + begin + BlockWriteByte(BlockInfo, 0); { >= } + end + else + begin + BlockWriteByte(BlockInfo, 1); { <= } + end; + if not (WriteOutRec(TempBool, False) and WriteOutRec(VariableVar, True) and WriteOutRec(finVal, True)) then + begin + TempBool.Free; + VariableVar.Free; + finVal.Free; + exit; + end; + AfterWriteOutRec(finVal); + AfterWriteOutRec(VariableVar); + finVal.Free; + BlockWriteByte(BlockInfo, Cm_CNG); + EPos := Length(BlockInfo.Proc.Data); + BlockWriteLong(BlockInfo, $12345678); + WriteOutRec(TempBool, False); + RPos := Length(BlockInfo.Proc.Data); + OldCO := FContinueOffsets; + FContinueOffsets := TPSList.Create; + OldBO := FBreakOffsets; + FBreakOffsets := TPSList.Create; + Block := TPSBlockInfo.Create(BlockInfo); + Block.SubType := tOneLiner; + + iOldWithCount := FWithCount; + FWithCount := 0; + iOldTryCount := FTryCount; + FTryCount := 0; + iOldExFnlCount := FExceptFinallyCount; + FExceptFinallyCount := 0; + + if not ProcessSub(Block) then + begin + Block.Free; + TempBool.Free; + VariableVar.Free; + FBreakOffsets.Free; + FContinueOffsets.Free; + FContinueOffsets := OldCO; + FBreakOffsets := OldBo; + + FWithCount := iOldWithCount; + FTryCount := iOldTryCount; + FExceptFinallyCount := iOldExFnlCount; + + exit; + end; + Block.Free; + FPos := Length(BlockInfo.Proc.Data); + if not PreWriteOutRec(VariableVar, nil) then + begin + TempBool.Free; + VariableVar.Free; + FBreakOffsets.Free; + FContinueOffsets.Free; + FContinueOffsets := OldCO; + FBreakOffsets := OldBo; + + FWithCount := iOldWithCount; + FTryCount := iOldTryCount; + FExceptFinallyCount := iOldExFnlCount; + + exit; + end; + if Backwards then + BlockWriteByte(BlockInfo, cm_dec) + else + BlockWriteByte(BlockInfo, cm_inc); + if not WriteOutRec(VariableVar, False) then + begin + TempBool.Free; + VariableVar.Free; + FBreakOffsets.Free; + FContinueOffsets.Free; + FContinueOffsets := OldCO; + FBreakOffsets := OldBo; + + FWithCount := iOldWithCount; + FTryCount := iOldTryCount; + FExceptFinallyCount := iOldExFnlCount; + + exit; + end; + AfterWriteOutRec(VariableVar); + BlockWriteByte(BlockInfo, Cm_G); + BlockWriteLong(BlockInfo, Longint(NPos - Length(BlockInfo.Proc.Data) - 4)); + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + unaligned(Longint((@BlockInfo.Proc.Data[EPos + 1])^)) := Length(BlockInfo.Proc.Data) - RPos; + {$else} + Longint((@BlockInfo.Proc.Data[EPos + 1])^) := Length(BlockInfo.Proc.Data) - RPos; + {$endif} + for i := 0 to FBreakOffsets.Count -1 do + begin + EPos := IPointer(FBreakOffsets[I]); + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(EPos); + {$else} + Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos); + {$endif} + end; + for i := 0 to FContinueOffsets.Count -1 do + begin + EPos := IPointer(FContinueOffsets[I]); + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Longint(FPos) - Longint(EPos); + {$else} + Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(FPos) - Longint(EPos); + {$endif} + end; + FBreakOffsets.Free; + FContinueOffsets.Free; + FContinueOffsets := OldCO; + FBreakOffsets := OldBo; + + FWithCount := iOldWithCount; + FTryCount := iOldTryCount; + FExceptFinallyCount := iOldExFnlCount; + + TempBool.Free; + VariableVar.Free; + if HasInvalidJumps(RPos, Length(BlockInfo.Proc.Data)) then + begin + Result := False; + exit; + end; + Result := True; + end; {ProcessFor} + + function ProcessWhile: Boolean; + var + vin, vout: TPSValue; + SPos, EPos: Cardinal; + OldCo, OldBO: TPSList; + I: Longint; + Block: TPSBlockInfo; + + iOldWithCount: Integer; + iOldTryCount: Integer; + iOldExFnlCount: Integer; + + begin + Result := False; + Debug_WriteLine(BlockInfo); + FParser.Next; + vout := calc(CSTII_do); + if vout = nil then + exit; + if FParser.CurrTokenId <> CSTII_do then + begin + vout.Free; + MakeError('', ecDoExpected, ''); + exit; + end; + vin := AllocStackReg(at2ut(FDefaultBoolType)); + SPos := Length(BlockInfo.Proc.Data); // start position + OldCo := FContinueOffsets; + FContinueOffsets := TPSList.Create; + OldBO := FBreakOffsets; + FBreakOffsets := TPSList.Create; + if not WriteCalculation(vout, vin) then + begin + vout.Free; + vin.Free; + FBreakOffsets.Free; + FContinueOffsets.Free; + FContinueOffsets := OldCO; + FBreakOffsets := OldBo; + exit; + end; + vout.Free; + FParser.Next; // skip DO + BlockWriteByte(BlockInfo, Cm_CNG); // only goto if expression is false + BlockWriteLong(BlockInfo, $12345678); + EPos := Length(BlockInfo.Proc.Data); + if not WriteOutRec(vin, False) then + begin + MakeError('', ecInternalError, '00017'); + vin.Free; + FBreakOffsets.Free; + FContinueOffsets.Free; + FContinueOffsets := OldCO; + FBreakOffsets := OldBo; + exit; + end; + Block := TPSBlockInfo.Create(BlockInfo); + Block.SubType := tOneLiner; + + iOldWithCount := FWithCount; + FWithCount := 0; + iOldTryCount := FTryCount; + FTryCount := 0; + iOldExFnlCount := FExceptFinallyCount; + FExceptFinallyCount := 0; + + if not ProcessSub(Block) then + begin + Block.Free; + vin.Free; + FBreakOffsets.Free; + FContinueOffsets.Free; + FContinueOffsets := OldCO; + FBreakOffsets := OldBo; + + FWithCount := iOldWithCount; + FTryCount := iOldTryCount; + FExceptFinallyCount := iOldExFnlCount; + + exit; + end; + Block.Free; + Debug_WriteLine(BlockInfo); + BlockWriteByte(BlockInfo, Cm_G); + BlockWriteLong(BlockInfo, Longint(SPos) - Length(BlockInfo.Proc.Data) - 4); + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(EPos) - 5; + {$else} + Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos) - 5; + {$endif} + for i := 0 to FBreakOffsets.Count -1 do + begin + EPos := Cardinal(FBreakOffsets[I]); + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(EPos); + {$else} + Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos); + {$endif} + end; + for i := 0 to FContinueOffsets.Count -1 do + begin + EPos := Cardinal(FContinueOffsets[I]); + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Longint(SPos) - Longint(EPos); + {$else} + Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(SPos) - Longint(EPos); + {$endif} + end; + FBreakOffsets.Free; + FContinueOffsets.Free; + FContinueOffsets := OldCO; + FBreakOffsets := OldBo; + + FWithCount := iOldWithCount; + FTryCount := iOldTryCount; + FExceptFinallyCount := iOldExFnlCount; + + vin.Free; + if HasInvalidJumps(EPos, Length(BlockInfo.Proc.Data)) then + begin + Result := False; + exit; + end; + Result := True; + end; + + function ProcessRepeat: Boolean; + var + vin, vout: TPSValue; + CPos, SPos, EPos: Cardinal; + I: Longint; + OldCo, OldBO: TPSList; + Block: TPSBlockInfo; + + iOldWithCount: Integer; + iOldTryCount: Integer; + iOldExFnlCount: Integer; + + begin + Result := False; + Debug_WriteLine(BlockInfo); + FParser.Next; + OldCo := FContinueOffsets; + FContinueOffsets := TPSList.Create; + OldBO := FBreakOffsets; + FBreakOffsets := TPSList.Create; + vin := AllocStackReg(at2ut(FDefaultBoolType)); + SPos := Length(BlockInfo.Proc.Data); + Block := TPSBlockInfo.Create(BlockInfo); + Block.SubType := tRepeat; + + iOldWithCount := FWithCount; + FWithCount := 0; + iOldTryCount := FTryCount; + FTryCount := 0; + iOldExFnlCount := FExceptFinallyCount; + FExceptFinallyCount := 0; + + if not ProcessSub(Block) then + begin + Block.Free; + FBreakOffsets.Free; + FContinueOffsets.Free; + FContinueOffsets := OldCO; + FBreakOffsets := OldBo; + + FWithCount := iOldWithCount; + FTryCount := iOldTryCount; + FExceptFinallyCount := iOldExFnlCount; + + vin.Free; + exit; + end; + Block.Free; + FParser.Next; //cstii_until + vout := calc(CSTI_Semicolon); + if vout = nil then + begin + FBreakOffsets.Free; + FContinueOffsets.Free; + FContinueOffsets := OldCO; + FBreakOffsets := OldBo; + + FWithCount := iOldWithCount; + FTryCount := iOldTryCount; + FExceptFinallyCount := iOldExFnlCount; + + vin.Free; + exit; + end; + CPos := Length(BlockInfo.Proc.Data); + if not WriteCalculation(vout, vin) then + begin + vout.Free; + vin.Free; + FBreakOffsets.Free; + FContinueOffsets.Free; + FContinueOffsets := OldCO; + FBreakOffsets := OldBo; + + FWithCount := iOldWithCount; + FTryCount := iOldTryCount; + FExceptFinallyCount := iOldExFnlCount; + + exit; + end; + vout.Free; + BlockWriteByte(BlockInfo, Cm_CNG); + BlockWriteLong(BlockInfo, $12345678); + EPos := Length(BlockInfo. Proc.Data); + if not WriteOutRec(vin, False) then + begin + MakeError('', ecInternalError, '00016'); + vin.Free; + FBreakOffsets.Free; + FContinueOffsets.Free; + FContinueOffsets := OldCO; + FBreakOffsets := OldBo; + + FWithCount := iOldWithCount; + FTryCount := iOldTryCount; + FExceptFinallyCount := iOldExFnlCount; + + exit; + end; + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Longint(SPos) - + Length(BlockInfo.Proc.Data); + {$else} + Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(SPos) - + Length(BlockInfo.Proc.Data); + {$endif} + for i := 0 to FBreakOffsets.Count -1 do + begin + EPos := Cardinal(FBreakOffsets[I]); + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Length(BlockInfo. Proc.Data) - Longint(EPos); + {$else} + Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo. Proc.Data) - Longint(EPos); + {$endif} + end; + for i := 0 to FContinueOffsets.Count -1 do + begin + EPos := Cardinal(FContinueOffsets[I]); + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Longint(CPos) - Longint(EPos); + {$else} + Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(CPos) - Longint(EPos); + {$endif} + end; + FBreakOffsets.Free; + FContinueOffsets.Free; + FContinueOffsets := OldCO; + FBreakOffsets := OldBo; + + FWithCount := iOldWithCount; + FTryCount := iOldTryCount; + FExceptFinallyCount := iOldExFnlCount; + + vin.Free; + if HasInvalidJumps(SPos, Length(BlockInfo. Proc.Data)) then + begin + Result := False; + exit; + end; + Result := True; + end; {ProcessRepeat} + + function ProcessIf: Boolean; + var + vout, vin: TPSValue; + SPos, EPos: Cardinal; + Block: TPSBlockInfo; + begin + Result := False; + Debug_WriteLine(BlockInfo); + FParser.Next; + vout := calc(CSTII_Then); + if vout = nil then + exit; + if FParser.CurrTokenId <> CSTII_Then then + begin + vout.Free; + MakeError('', ecThenExpected, ''); + exit; + end; + vin := AllocStackReg(at2ut(FDefaultBoolType)); + if not WriteCalculation(vout, vin) then + begin + vout.Free; + vin.Free; + exit; + end; + vout.Free; + BlockWriteByte(BlockInfo, cm_sf); + if not WriteOutRec(vin, False) then + begin + MakeError('', ecInternalError, '00018'); + vin.Free; + exit; + end; + BlockWriteByte(BlockInfo, 1); + vin.Free; + BlockWriteByte(BlockInfo, cm_fg); + BlockWriteLong(BlockInfo, $12345678); + SPos := Length(BlockInfo.Proc.Data); + FParser.Next; // skip then + Block := TPSBlockInfo.Create(BlockInfo); + Block.SubType := tifOneliner; + if not ProcessSub(Block) then + begin + Block.Free; + exit; + end; + Block.Free; + if FParser.CurrTokenId = CSTII_Else then + begin + BlockWriteByte(BlockInfo, Cm_G); + BlockWriteLong(BlockInfo, $12345678); + EPos := Length(BlockInfo.Proc.Data); + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + unaligned(Longint((@BlockInfo.Proc.Data[SPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(SPos); + {$else} + Longint((@BlockInfo.Proc.Data[SPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(SPos); + {$endif} + FParser.Next; + Block := TPSBlockInfo.Create(BlockInfo); + Block.SubType := tOneLiner; + if not ProcessSub(Block) then + begin + Block.Free; + exit; + end; + Block.Free; + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(EPos); + {$else} + Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos); + {$endif} + end + else + begin + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + unaligned(Longint((@BlockInfo.Proc.Data[SPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(SPos) + 5 - 5; + {$else} + Longint((@BlockInfo.Proc.Data[SPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(SPos) + 5 - 5; + {$endif} + end; + Result := True; + end; {ProcessIf} + + function _ProcessLabel: Longint; {0 = failed; 1 = successful; 2 = no label} + var + I, H: Longint; + s: tbtString; + begin + h := MakeHash(FParser.GetToken); + for i := 0 to BlockInfo.Proc.FLabels.Count -1 do + begin + s := BlockInfo.Proc.FLabels[I]; + delete(s, 1, 4); + if Longint((@s[1])^) = h then + begin + delete(s, 1, 4); + if s = FParser.GetToken then + begin + s := BlockInfo.Proc.FLabels[I]; + Cardinal((@s[1])^) := Length(BlockInfo.Proc.Data); + BlockInfo.Proc.FLabels[i] := s; + FParser.Next; + if fParser.CurrTokenId = CSTI_Colon then + begin + Result := 1; + FParser.Next; + exit; + end else begin + MakeError('', ecColonExpected, ''); + Result := 0; + Exit; + end; + end; + end; + end; + result := 2; + end; + + function ProcessIdentifier: Boolean; + var + vin, vout: TPSValue; + begin + Result := False; + Debug_WriteLine(BlockInfo); + vin := GetIdentifier(2); + if vin <> nil then + begin + if vin is TPSValueVar then + begin // assignment needed + if FParser.CurrTokenId <> CSTI_Assignment then + begin + MakeError('', ecAssignmentExpected, ''); + vin.Free; + exit; + end; + FParser.Next; + vout := calc(CSTI_Semicolon); + if vout = nil then + begin + vin.Free; + exit; + end; + if not WriteCalculation(vout, vin) then + begin + vin.Free; + vout.Free; + exit; + end; + vin.Free; + vout.Free; + end else if vin is TPSValueProc then + begin + Result := _ProcessFunction(TPSValueProc(vin), nil); + vin.Free; + Exit; + end else + begin + MakeError('', ecInternalError, '20'); + vin.Free; + REsult := False; + exit; + end; + end + else + begin + Result := False; + exit; + end; + Result := True; + end; {ProcessIdentifier} + + function ProcessCase: Boolean; + var + V1, V2, TempRec, Val, CalcItem: TPSValue; + p: TPSBinValueOp; + SPos, CurrP: Cardinal; + I: Longint; + EndReloc: TPSList; + Block: TPSBlockInfo; + + function NewRec(val: TPSValue): TPSValueReplace; + begin + Result := TPSValueReplace.Create; + Result.SetParserPos(FParser); + Result.FNewValue := Val; + Result.FreeNewValue := False; + end; + + function Combine(v1, v2: TPSValue; Op: TPSBinOperatorType): TPSValue; + begin + if V1 = nil then + begin + Result := v2; + end else if v2 = nil then + begin + Result := V1; + end else + begin + Result := TPSBinValueOp.Create; + TPSBinValueOp(Result).FType := FDefaultBoolType; + TPSBinValueOp(Result).Operator := Op; + Result.SetParserPos(FParser); + TPSBinValueOp(Result).FVal1 := V1; + TPSBinValueOp(Result).FVal2 := V2; + end; + end; + + + begin + Debug_WriteLine(BlockInfo); + FParser.Next; + Val := calc(CSTII_of); + if Val = nil then + begin + ProcessCase := False; + exit; + end; {if} + if FParser.CurrTokenId <> CSTII_Of then + begin + MakeError('', ecOfExpected, ''); + val.Free; + ProcessCase := False; + exit; + end; {if} + FParser.Next; + TempRec := AllocStackReg(GetTypeNo(BlockInfo, Val)); + if not WriteCalculation(Val, TempRec) then + begin + TempRec.Free; + val.Free; + ProcessCase := False; + exit; + end; {if} + val.Free; + EndReloc := TPSList.Create; + CalcItem := AllocStackReg(at2ut(FDefaultBoolType)); + SPos := Length(BlockInfo.Proc.Data); + repeat + V1 := nil; + while true do + begin + Val := calc(CSTI_Colon); + if (Val = nil) then + begin + V1.Free; + CalcItem.Free; + TempRec.Free; + EndReloc.Free; + ProcessCase := False; + exit; + end; {if} + if fParser.CurrTokenID = CSTI_TwoDots then begin + FParser.Next; + V2 := Calc(CSTI_colon); + if V2 = nil then begin + V1.Free; + CalcItem.Free; + TempRec.Free; + EndReloc.Free; + ProcessCase := False; + Val.Free; + exit; + end; + p := TPSBinValueOp.Create; + p.SetParserPos(FParser); + p.Operator := otGreaterEqual; + p.aType := at2ut(FDefaultBoolType); + p.Val2 := Val; + p.Val1 := NewRec(TempRec); + Val := p; + p := TPSBinValueOp.Create; + p.SetParserPos(FParser); + p.Operator := otLessEqual; + p.aType := at2ut(FDefaultBoolType); + p.Val2 := V2; + p.Val1 := NewRec(TempRec); + P := TPSBinValueOp(Combine(Val,P, otAnd)); + end else begin + p := TPSBinValueOp.Create; + p.SetParserPos(FParser); + p.Operator := otEqual; + p.aType := at2ut(FDefaultBoolType); + p.Val1 := Val; + p.Val2 := NewRec(TempRec); + end; + V1 := Combine(V1, P, otOr); + if FParser.CurrTokenId = CSTI_Colon then Break; + if FParser.CurrTokenID <> CSTI_Comma then + begin + MakeError('', ecColonExpected, ''); + V1.Free; + CalcItem.Free; + TempRec.Free; + EndReloc.Free; + ProcessCase := False; + exit; + end; + FParser.Next; + end; + FParser.Next; + if not WriteCalculation(V1, CalcItem) then + begin + CalcItem.Free; + v1.Free; + EndReloc.Free; + ProcessCase := False; + exit; + end; + v1.Free; + BlockWriteByte(BlockInfo, Cm_CNG); + BlockWriteLong(BlockInfo, $12345678); + CurrP := Length(BlockInfo.Proc.Data); + WriteOutRec(CalcItem, False); + Block := TPSBlockInfo.Create(BlockInfo); + Block.SubType := tifOneliner; + if not ProcessSub(Block) then + begin + Block.Free; + CalcItem.Free; + TempRec.Free; + EndReloc.Free; + ProcessCase := False; + exit; + end; + Block.Free; + BlockWriteByte(BlockInfo, Cm_G); + BlockWriteLong(BlockInfo, $12345678); + EndReloc.Add(Pointer(Length(BlockInfo.Proc.Data))); + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + unaligned(Cardinal((@BlockInfo.Proc.Data[CurrP - 3])^)) := Cardinal(Length(BlockInfo.Proc.Data)) - CurrP - 5; + {$else} + Cardinal((@BlockInfo.Proc.Data[CurrP - 3])^) := Cardinal(Length(BlockInfo.Proc.Data)) - CurrP - 5; + {$endif} + if FParser.CurrTokenID = CSTI_Semicolon then FParser.Next; + if FParser.CurrTokenID = CSTII_Else then + begin + FParser.Next; + Block := TPSBlockInfo.Create(BlockInfo); + Block.SubType := tOneliner; + if not ProcessSub(Block) then + begin + Block.Free; + CalcItem.Free; + TempRec.Free; + EndReloc.Free; + ProcessCase := False; + exit; + end; + Block.Free; + if FParser.CurrTokenID = CSTI_Semicolon then FParser.Next; + if FParser.CurrtokenId <> CSTII_End then + begin + MakeError('', ecEndExpected, ''); + CalcItem.Free; + TempRec.Free; + EndReloc.Free; + ProcessCase := False; + exit; + end; + end; + until FParser.CurrTokenID = CSTII_End; + FParser.Next; + for i := 0 to EndReloc.Count -1 do + begin + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + unaligned(Cardinal((@BlockInfo.Proc.Data[Cardinal(EndReloc[I])- 3])^)) := Cardinal(Length(BlockInfo.Proc.Data)) - Cardinal(EndReloc[I]); + {$else} + Cardinal((@BlockInfo.Proc.Data[Cardinal(EndReloc[I])- 3])^) := Cardinal(Length(BlockInfo.Proc.Data)) - Cardinal(EndReloc[I]); + {$endif} + end; + CalcItem.Free; + TempRec.Free; + EndReloc.Free; + if FContinueOffsets <> nil then + begin + for i := 0 to FContinueOffsets.Count -1 do + begin + if Cardinal(FContinueOffsets[i]) >= SPos then + begin + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + unaligned(Byte((@BlockInfo.Proc.Data[Longint(FContinueOffsets[i]) - 4])^)) := Cm_P2G; + {$else} + Byte((@BlockInfo.Proc.Data[Longint(FContinueOffsets[i]) - 4])^) := Cm_P2G; + {$endif} + end; + end; + end; + if FBreakOffsets <> nil then + begin + for i := 0 to FBreakOffsets.Count -1 do + begin + if Cardinal(FBreakOffsets[i]) >= SPos then + begin + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + unaligned(Byte((@BlockInfo.Proc.Data[Longint(FBreakOffsets[i]) - 4])^)) := Cm_P2G; + {$else} + Byte((@BlockInfo.Proc.Data[Longint(FBreakOffsets[i]) - 4])^) := Cm_P2G; + {$endif} + end; + end; + end; + if HasInvalidJumps(SPos, Length(BlockInfo.Proc.Data)) then + begin + Result := False; + exit; + end; + Result := True; + end; {ProcessCase} + function ProcessGoto: Boolean; + var + I, H: Longint; + s: tbtString; + begin + Debug_WriteLine(BlockInfo); + FParser.Next; + h := MakeHash(FParser.GetToken); + for i := 0 to BlockInfo.Proc.FLabels.Count -1 do + begin + s := BlockInfo.Proc.FLabels[I]; + delete(s, 1, 4); + if Longint((@s[1])^) = h then + begin + delete(s, 1, 4); + if s = FParser.GetToken then + begin + FParser.Next; + BlockWriteByte(BlockInfo, Cm_G); + BlockWriteLong(BlockInfo, $12345678); + BlockInfo.Proc.FGotos.Add(PS_mi2s(length(BlockInfo.Proc.Data))+PS_mi2s(i)); + Result := True; + exit; + end; + end; + end; + MakeError('', ecUnknownIdentifier, FParser.OriginalToken); + Result := False; + end; {ProcessGoto} + + function ProcessWith: Boolean; + var + Block: TPSBlockInfo; + aVar, aReplace: TPSValue; + aType: TPSType; + + iStartOffset: Integer; + + tmp: TPSValue; + begin + Debug_WriteLine(BlockInfo); + Block := TPSBlockInfo.Create(BlockInfo); + Block.SubType := tOneLiner; + + FParser.Next; + repeat + aVar := GetIdentifier(0); + if aVar = nil then + begin + block.Free; + Result := False; + exit; + end; + AType := GetTypeNo(BlockInfo, aVar); + if (AType = nil) or ((aType.BaseType <> btRecord) and (aType.BaseType <> btClass)) then + begin + MakeError('', ecClassTypeExpected, ''); + Block.Free; + Result := False; + exit; + end; + + aReplace := TPSValueReplace.Create; + aReplace.SetParserPos(FParser); + TPSValueReplace(aReplace).FreeOldValue := True; + TPSValueReplace(aReplace).FreeNewValue := True; + TPSValueReplace(aReplace).OldValue := aVar; + + //if aVar.InheritsFrom(TPSVar) then TPSVar(aVar).Use; + tmp := AllocPointer(GetTypeNo(BlockInfo, aVar)); + TPSProcVar(BlockInfo.Proc.ProcVars[TPSValueAllocatedStackVar(tmp).LocalVarNo]).Use; + PreWriteOutRec(tmp,GetTypeNo(BlockInfo, tmp)); + PreWriteOutRec(aVar,GetTypeNo(BlockInfo, aVar)); + BlockWriteByte(BlockInfo, cm_sp); + WriteOutRec(tmp, false); + WriteOutRec(aVar, false); + TPSValueReplace(aReplace).NewValue := tmp; + + + + Block.WithList.Add(aReplace); + + if FParser.CurrTokenID = CSTII_do then + begin + FParser.Next; + Break; + end else + if FParser.CurrTokenId <> CSTI_Comma then + begin + MakeError('', ecDoExpected, ''); + Block.Free; + Result := False; + exit; + end; + FParser.Next; + until False; + + + inc(FWithCount); + + iStartOffset := Length(Block.Proc.Data); + + if not (ProcessSub(Block) and (not HasInvalidJumps(iStartOffset,Length(BlockInfo.Proc.Data) + 1)) ) then + begin + dec(FWithCount); + Block.Free; + Result := False; + exit; + end; + dec(FWithCount); + + AfterWriteOutRec(aVar); + AfterWriteOutRec(tmp); + Block.Free; + Result := True; + end; + + function ProcessTry: Boolean; + var + FStartOffset: Cardinal; + iBlockStartOffset: Integer; + Block: TPSBlockInfo; + begin + FParser.Next; + BlockWriteByte(BlockInfo, cm_puexh); + FStartOffset := Length(BlockInfo.Proc.Data) + 1; + BlockWriteLong(BlockInfo, InvalidVal); + BlockWriteLong(BlockInfo, InvalidVal); + BlockWriteLong(BlockInfo, InvalidVal); + BlockWriteLong(BlockInfo, InvalidVal); + Block := TPSBlockInfo.Create(BlockInfo); + Block.SubType := tTry; + inc(FTryCount); + if ProcessSub(Block) and (not HasInvalidJumps(FStartOffset,Length(BlockInfo.Proc.Data) + 1)) then + begin + dec(FTryCount); + Block.Free; + BlockWriteByte(BlockInfo, cm_poexh); + BlockWriteByte(BlockInfo, 0); + if FParser.CurrTokenID = CSTII_Except then + begin + FParser.Next; + Cardinal((@BlockInfo.Proc.Data[FStartOffset + 4])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15; + iBlockStartOffset := Length(BlockInfo.Proc.Data) ; + Block := TPSBlockInfo.Create(BlockInfo); + Block.SubType := tTryEnd; + inc(FExceptFinallyCount); + if ProcessSub(Block) and (not HasInvalidJumps(iBlockStartOffset,Length(BlockInfo.Proc.Data) + 1)) then + begin + dec(FExceptFinallyCount); + Block.Free; + BlockWriteByte(BlockInfo, cm_poexh); + BlockWriteByte(BlockInfo, 2); + if FParser.CurrTokenId = CSTII_Finally then + begin + Cardinal((@BlockInfo.Proc.Data[FStartOffset + 8])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15; + iBlockStartOffset := Length(BlockInfo.Proc.Data) ; + Block := TPSBlockInfo.Create(BlockInfo); + Block.SubType := tTryEnd; + FParser.Next; + inc(FExceptFinallyCount); + if ProcessSub(Block) and (not HasInvalidJumps(iBlockStartOffset,Length(BlockInfo.Proc.Data) + 1)) then + begin + dec(FExceptFinallyCount); + Block.Free; + if FParser.CurrTokenId = CSTII_End then + begin + BlockWriteByte(BlockInfo, cm_poexh); + BlockWriteByte(BlockInfo, 3); + end else begin + MakeError('', ecEndExpected, ''); + Result := False; + exit; + end; + end else + begin + Block.Free; + Result := False; + dec(FExceptFinallyCount); + exit; + end; + end else if FParser.CurrTokenID <> CSTII_End then + begin + MakeError('', ecEndExpected, ''); + Result := False; + exit; + end; + FParser.Next; + end else + begin + Block.Free; + Result := False; + dec(FExceptFinallyCount); + exit; + end; + end else if FParser.CurrTokenId = CSTII_Finally then + begin + FParser.Next; + Cardinal((@BlockInfo.Proc.Data[FStartOffset])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15; + iBlockStartOffset := Length(BlockInfo.Proc.Data) ; + Block := TPSBlockInfo.Create(BlockInfo); + Block.SubType := tTryEnd; + inc(FExceptFinallyCount); + if ProcessSub(Block) and (not HasInvalidJumps(iBlockStartOffset,Length(BlockInfo.Proc.Data) + 1)) then + begin + dec(FExceptFinallyCount); + Block.Free; + BlockWriteByte(BlockInfo, cm_poexh); + BlockWriteByte(BlockInfo, 1); + if FParser.CurrTokenId = CSTII_Except then + begin + Cardinal((@BlockInfo.Proc.Data[FStartOffset + 4])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15; + iBlockStartOffset := Length(BlockInfo.Proc.Data) ; + FParser.Next; + Block := TPSBlockInfo.Create(BlockInfo); + Block.SubType := tTryEnd; + inc(FExceptFinallyCount); + if ProcessSub(Block) and (not HasInvalidJumps(iBlockStartOffset,Length(BlockInfo.Proc.Data) + 1)) then + begin + dec(FExceptFinallyCount); + Block.Free; + if FParser.CurrTokenId = CSTII_End then + begin + BlockWriteByte(BlockInfo, cm_poexh); + BlockWriteByte(BlockInfo, 2); + end else begin + MakeError('', ecEndExpected, ''); + Result := False; + exit; + end; + end else + begin + Block.Free; + Result := False; + dec(FExceptFinallyCount); + exit; + end; + end else if FParser.CurrTokenID <> CSTII_End then + begin + MakeError('', ecEndExpected, ''); + Result := False; + exit; + end; + FParser.Next; + end else + begin + Block.Free; + Result := False; + dec(FExceptFinallyCount); + exit; + end; + end; + end else + begin + Block.Free; + Result := False; + dec(FTryCount); + exit; + end; + Cardinal((@BlockInfo.Proc.Data[FStartOffset + 12])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15; + Result := True; + end; {ProcessTry} + +var + i: Integer; + Block: TPSBlockInfo; + +begin + ProcessSub := False; + if (BlockInfo.SubType = tProcBegin) or (BlockInfo.SubType= tMainBegin) or +{$IFDEF PS_USESSUPPORT} + (BlockInfo.SubType = tUnitInit) or (BlockInfo.SubType= tUnitFinish) or // NvdS +{$endif} + (BlockInfo.SubType= tSubBegin) then + begin + FParser.Next; // skip CSTII_Begin + end; + while True do + begin + case FParser.CurrTokenId of + CSTII_Goto: + begin + if not ProcessGoto then + Exit; + if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then + break; + end; + CSTII_With: + begin + if not ProcessWith then + Exit; + if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then + break; + end; + CSTII_Try: + begin + if not ProcessTry then + Exit; + if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then + break; + end; + CSTII_Finally, CSTII_Except: + begin + if (BlockInfo.SubType = tTry) or (BlockInfo.SubType = tTryEnd) then + Break + else + begin + MakeError('', ecEndExpected, ''); + Exit; + end; + end; + CSTII_Begin: + begin + Block := TPSBlockInfo.Create(BlockInfo); + Block.SubType := tSubBegin; + if not ProcessSub(Block) then + begin + Block.Free; + Exit; + end; + Block.Free; + + FParser.Next; // skip END + if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then + break; + end; + CSTI_Semicolon: + begin + + if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then + break + else FParser.Next; + end; + CSTII_until: + begin + Debug_WriteLine(BlockInfo); + if BlockInfo.SubType = tRepeat then + begin + break; + end + else + begin + MakeError('', ecIdentifierExpected, ''); + exit; + end; + if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then + break; + end; + CSTII_Else: + begin + if BlockInfo.SubType = tifOneliner then + break + else + begin + MakeError('', ecIdentifierExpected, ''); + exit; + end; + end; + CSTII_repeat: + begin + if not ProcessRepeat then + exit; + if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then + break; + end; + CSTII_For: + begin + if not ProcessFor then + exit; + if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then + break; + end; + CSTII_While: + begin + if not ProcessWhile then + exit; + if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then + break; + end; + CSTII_Exit: + begin + Debug_WriteLine(BlockInfo); + BlockWriteByte(BlockInfo, Cm_R); + FParser.Next; + if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then + break; + end; + CSTII_Case: + begin + if not ProcessCase then + exit; + if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then + break; + end; + CSTII_If: + begin + if not ProcessIf then + exit; + if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then + break; + end; + CSTI_Identifier: + begin + case _ProcessLabel of + 0: Exit; + 1: ; + else + begin + if FParser.GetToken = 'BREAK' then + begin + if FBreakOffsets = nil then + begin + MakeError('', ecNotInLoop, ''); + exit; + end; + for i := 0 to FExceptFinallyCount - 1 do + begin + BlockWriteByte(BlockInfo, cm_poexh); + BlockWriteByte(BlockInfo, 1); + end; + + for i := 0 to FTryCount - 1 do + begin + BlockWriteByte(BlockInfo, cm_poexh); + BlockWriteByte(BlockInfo, 0); + BlockWriteByte(BlockInfo, cm_poexh); + BlockWriteByte(BlockInfo, 1); + end; + + for i := 0 to FWithCount - 1 do + BlockWriteByte(BlockInfo,cm_po); + BlockWriteByte(BlockInfo, Cm_G); + BlockWriteLong(BlockInfo, $12345678); + FBreakOffsets.Add(Pointer(Length(BlockInfo.Proc.Data))); + FParser.Next; + if (BlockInfo.SubType= tifOneliner) or (BlockInfo.SubType = TOneLiner) then + break; + end else if FParser.GetToken = 'CONTINUE' then + begin + if FBreakOffsets = nil then + begin + MakeError('', ecNotInLoop, ''); + exit; + end; + for i := 0 to FExceptFinallyCount - 1 do + begin + BlockWriteByte(BlockInfo, cm_poexh); + BlockWriteByte(BlockInfo, 1); + end; + + for i := 0 to FTryCount - 1 do + begin + BlockWriteByte(BlockInfo, cm_poexh); + BlockWriteByte(BlockInfo, 0); + BlockWriteByte(BlockInfo, cm_poexh); + BlockWriteByte(BlockInfo, 1); + end; + + for i := 0 to FWithCount - 1 do + BlockWriteByte(BlockInfo,cm_po); + BlockWriteByte(BlockInfo, Cm_G); + BlockWriteLong(BlockInfo, $12345678); + FContinueOffsets.Add(Pointer(Length(BlockInfo.Proc.Data))); + FParser.Next; + if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then + break; + end else + if not ProcessIdentifier then + exit; + if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then + break; + end; + end; {case} + + if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then + break; + + end; + {$IFDEF PS_USESSUPPORT} + CSTII_Finalization: //NvdS + begin // + if (BlockInfo.SubType = tUnitInit) then // + begin // + break; // + end // + else // + begin // + MakeError('', ecIdentifierExpected, ''); // + exit; // + end; // + end; //nvds + {$endif} + CSTII_End: + begin + if (BlockInfo.SubType = tTryEnd) or (BlockInfo.SubType = tMainBegin) or + (BlockInfo.SubType = tSubBegin) or (BlockInfo.SubType = tifOneliner) or + (BlockInfo.SubType = tProcBegin) or (BlockInfo.SubType = TOneLiner) + {$IFDEF PS_USESSUPPORT} or (BlockInfo.SubType = tUnitInit) or (BlockInfo.SubType = tUnitFinish) {$endif} then //nvds + begin + break; + end + else + begin + MakeError('', ecIdentifierExpected, ''); + exit; + end; + end; + CSTI_EOF: + begin + MakeError('', ecUnexpectedEndOfFile, ''); + exit; + end; + else + begin + MakeError('', ecIdentifierExpected, ''); + exit; + end; + end; + end; + if (BlockInfo.SubType = tMainBegin) or (BlockInfo.SubType = tProcBegin) + {$IFDEF PS_USESSUPPORT} or (BlockInfo.SubType = tUnitInit) or (BlockInfo.SubType = tUnitFinish) {$endif} then //nvds + begin + Debug_WriteLine(BlockInfo); + BlockWriteByte(BlockInfo, Cm_R); + {$IFDEF PS_USESSUPPORT} + if FParser.CurrTokenId = CSTII_End then //nvds + begin + {$endif} + FParser.Next; // skip end + if ((BlockInfo.SubType = tMainBegin) + {$IFDEF PS_USESSUPPORT} or (BlockInfo.SubType = tUnitInit) or (BlockInfo.SubType = tUnitFinish){$endif}) //nvds + and (FParser.CurrTokenId <> CSTI_Period) then + begin + MakeError('', ecPeriodExpected, ''); + exit; + end; + if (BlockInfo.SubType = tProcBegin) and (FParser.CurrTokenId <> CSTI_Semicolon) then + begin + MakeError('', ecSemicolonExpected, ''); + exit; + end; + FParser.Next; + {$IFDEF PS_USESSUPPORT} + end; //nvds + {$endif} + end + else if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then + begin + if (FParser.CurrTokenID <> CSTII_Else) and (FParser.CurrTokenID <> CSTII_End) then + if FParser.CurrTokenID <> CSTI_Semicolon then + begin + MakeError('', ecSemicolonExpected, ''); + exit; + end; + end; + + ProcessSub := True; +end; +procedure TPSPascalCompiler.UseProc(procdecl: TPSParametersDecl); +var + i: Longint; +begin + if procdecl.Result <> nil then + procdecl.Result := at2ut(procdecl.Result); + for i := 0 to procdecl.ParamCount -1 do + begin + procdecl.Params[i].aType := at2ut(procdecl.Params[i].aType); + end; +end; + +function TPSPascalCompiler.at2ut(p: TPSType): TPSType; +var + i: Longint; +begin + p := GetTypeCopyLink(p); + if p = nil then + begin + Result := nil; + exit; + end; + if not p.Used then + begin + p.Use; + case p.BaseType of + btStaticArray, btArray: TPSArrayType(p).ArrayTypeNo := at2ut(TPSArrayType(p).ArrayTypeNo); + btRecord: + begin + for i := 0 to TPSRecordType(p).RecValCount -1 do + begin + TPSRecordType(p).RecVal(i).aType := at2ut(TPSRecordType(p).RecVal(i).aType); + end; + end; + btSet: TPSSetType(p).SetType := at2ut(TPSSetType(p).SetType); + btProcPtr: + begin + UseProc(TPSProceduralType(p).ProcDef); + end; + end; + p.FFinalTypeNo := FCurrUsedTypeNo; + inc(FCurrUsedTypeNo); + end; + Result := p; +end; + +function TPSPascalCompiler.ProcessLabelForwards(Proc: TPSInternalProcedure): Boolean; +var + i: Longint; + s, s2: tbtString; +begin + for i := 0 to Proc.FLabels.Count -1 do + begin + s := Proc.FLabels[I]; + if Longint((@s[1])^) = -1 then + begin + delete(s, 1, 8); + MakeError('', ecUnSetLabel, s); + Result := False; + exit; + end; + end; + for i := Proc.FGotos.Count -1 downto 0 do + begin + s := Proc.FGotos[I]; + s2 := Proc.FLabels[Cardinal((@s[5])^)]; + Cardinal((@Proc.Data[Cardinal((@s[1])^)-3])^) := Cardinal((@s2[1])^) - Cardinal((@s[1])^) ; + end; + Result := True; +end; + + +type + TCompilerState = (csStart, csProgram, csUnit, csUses, csInterface, csInterfaceUses, csImplementation); + +function TPSPascalCompiler.Compile(const s: tbtString): Boolean; +var + Position: TCompilerState; + i: Longint; + {$IFDEF PS_USESSUPPORT} + OldFileName: tbtString; + OldParser : TPSPascalParser; + OldIsUnit : Boolean; + {$ENDIF} + + procedure Cleanup; + var + I: Longint; + PT: TPSType; + begin + {$IFDEF PS_USESSUPPORT} + if fInCompile>1 then + begin + dec(fInCompile); + exit; + end; + {$ENDIF} + + if @FOnBeforeCleanup <> nil then + FOnBeforeCleanup(Self); // no reason it actually read the result of this call + FGlobalBlock.Free; + FGlobalBlock := nil; + + for I := 0 to FRegProcs.Count - 1 do + TObject(FRegProcs[I]).Free; + FRegProcs.Free; + for i := 0 to FConstants.Count -1 do + begin + TPSConstant(FConstants[I]).Free; + end; + Fconstants.Free; + for I := 0 to FVars.Count - 1 do + begin + TPSVar(FVars[I]).Free; + end; + FVars.Free; + FVars := nil; + for I := 0 to FProcs.Count - 1 do + TPSProcedure(FProcs[I]).Free; + FProcs.Free; + FProcs := nil; + for I := 0 to FTypes.Count - 1 do + begin + PT := FTypes[I]; + pt.Free; + end; + FTypes.Free; + +{$IFNDEF PS_NOINTERFACES} + for i := FInterfaces.Count -1 downto 0 do + TPSInterface(FInterfaces[i]).Free; + FInterfaces.Free; +{$ENDIF} + + for i := FClasses.Count -1 downto 0 do + begin + TPSCompileTimeClass(FClasses[I]).Free; + end; + FClasses.Free; + for i := FAttributeTypes.Count -1 downto 0 do + begin + TPSAttributeType(FAttributeTypes[i]).Free; + end; + FAttributeTypes.Free; + FAttributeTypes := nil; + + {$IFDEF PS_USESSUPPORT} + for I := 0 to FUnitInits.Count - 1 do //nvds + begin //nvds + TPSBlockInfo(FUnitInits[I]).free; //nvds + end; //nvds + FUnitInits.Free; //nvds + FUnitInits := nil; // + for I := 0 to FUnitFinits.Count - 1 do //nvds + begin //nvds + TPSBlockInfo(FUnitFinits[I]).free; //nvds + end; //nvds + FUnitFinits.Free; // + FUnitFinits := nil; // + + FUses.Free; + FUses:=nil; + fInCompile:=0; + {$ENDIF} + end; + + function MakeOutput: Boolean; + + procedure WriteByte(b: Byte); + begin + FOutput := FOutput + tbtChar(b); + end; + + procedure WriteData(const Data; Len: Longint); + var + l: Longint; + begin + if Len < 0 then Len := 0; + l := Length(FOutput); + SetLength(FOutput, l + Len); + Move(Data, FOutput[l + 1], Len); + end; + + procedure WriteLong(l: Cardinal); + begin + WriteData(l, 4); + end; + + procedure WriteVariant(p: PIfRVariant); + begin + WriteLong(p^.FType.FinalTypeNo); + case p.FType.BaseType of + btType: WriteLong(p^.ttype.FinalTypeNo); + {$IFNDEF PS_NOWIDESTRING} + btWideString: + begin + WriteLong(Length(tbtWideString(p^.twidestring))); + WriteData(tbtwidestring(p^.twidestring)[1], 2*Length(tbtWideString(p^.twidestring))); + end; + btUnicodeString: + begin + WriteLong(Length(tbtUnicodestring(p^.twidestring))); + WriteData(tbtUnicodestring(p^.twidestring)[1], 2*Length(tbtUnicodestring(p^.twidestring))); + end; + btWideChar: WriteData(p^.twidechar, 2); + {$ENDIF} + btSingle: WriteData(p^.tsingle, sizeof(tbtSingle)); + btDouble: WriteData(p^.tsingle, sizeof(tbtDouble)); + btExtended: WriteData(p^.tsingle, sizeof(tbtExtended)); + btCurrency: WriteData(p^.tsingle, sizeof(tbtCurrency)); + btChar: WriteData(p^.tchar, 1); + btSet: + begin + WriteData(tbtString(p^.tstring)[1], Length(tbtString(p^.tstring))); + end; + btString: + begin + WriteLong(Length(tbtString(p^.tstring))); + WriteData(tbtString(p^.tstring)[1], Length(tbtString(p^.tstring))); + end; + btenum: + begin + if TPSEnumType(p^.FType).HighValue <=256 then + WriteData( p^.tu32, 1) + else if TPSEnumType(p^.FType).HighValue <=65536 then + WriteData(p^.tu32, 2) + else + WriteData(p^.tu32, 4); + end; + bts8,btu8: WriteData(p^.tu8, 1); + bts16,btu16: WriteData(p^.tu16, 2); + bts32,btu32: WriteData(p^.tu32, 4); + {$IFNDEF PS_NOINT64} + bts64: WriteData(p^.ts64, 8); + {$ENDIF} + btProcPtr: WriteData(p^.tu32, 4); + {$IFDEF DEBUG} + else + asm int 3; end; + {$ENDIF} + end; + end; + + procedure WriteAttributes(attr: TPSAttributes); + var + i, j: Longint; + begin + WriteLong(attr.Count); + for i := 0 to Attr.Count -1 do + begin + j := Length(attr[i].FAttribType.Name); + WriteLong(j); + WriteData(Attr[i].FAttribType.Name[1], j); + WriteLong(Attr[i].Count); + for j := 0 to Attr[i].Count -1 do + begin + WriteVariant(Attr[i][j]); + end; + end; + end; + + procedure WriteTypes; + var + l, n: Longint; + bt: TPSBaseType; + x: TPSType; + s: tbtString; + FExportName: tbtString; + Items: TPSList; + procedure WriteTypeNo(TypeNo: Cardinal); + begin + WriteData(TypeNo, 4); + end; + begin + Items := TPSList.Create; + try + for l := 0 to FCurrUsedTypeNo -1 do + Items.Add(nil); + for l := 0 to FTypes.Count -1 do + begin + x := FTypes[l]; + if x.Used then + Items[x.FinalTypeNo] := x; + end; + for l := 0 to Items.Count - 1 do + begin + x := Items[l]; + if x.FExportName then + FExportName := x.Name + else + FExportName := ''; + if (x.BaseType = btExtClass) and (x is TPSUndefinedClassType) then + begin + x := GetTypeCopyLink(TPSUndefinedClassType(x).ExtClass.SelfType); + end; + bt := x.BaseType; + if (x.BaseType = btType) or (x.BaseType = btNotificationVariant) then + begin + bt := btU32; + end else + if (x.BaseType = btEnum) then begin + if TPSEnumType(x).HighValue <= 256 then + bt := btU8 + else if TPSEnumType(x).HighValue <= 65536 then + bt := btU16 + else + bt := btU32; + end; + if FExportName <> '' then + begin + WriteByte(bt + 128); + end + else + WriteByte(bt); +{$IFNDEF PS_NOINTERFACES} if x.BaseType = btInterface then + begin + WriteData(TPSInterfaceType(x).Intf.Guid, Sizeof(TGuid)); + end else {$ENDIF} if x.BaseType = btClass then + begin + WriteLong(Length(TPSClassType(X).Cl.FClassName)); + WriteData(TPSClassType(X).Cl.FClassName[1], Length(TPSClassType(X).Cl.FClassName)); + end else + if (x.BaseType = btProcPtr) then + begin + s := DeclToBits(TPSProceduralType(x).ProcDef); + WriteLong(Length(s)); + WriteData(s[1], Length(s)); + end else + if (x.BaseType = btSet) then + begin + WriteLong(TPSSetType(x).BitSize); + end else + if (x.BaseType = btArray) or (x.basetype = btStaticArray) then + begin + WriteLong(TPSArrayType(x).ArrayTypeNo.FinalTypeNo); + if (x.baseType = btstaticarray) then begin + WriteLong(TPSStaticArrayType(x).Length); + WriteLong(TPSStaticArrayType(x).StartOffset); //<-additional StartOffset + end; + end else if x.BaseType = btRecord then + begin + n := TPSRecordType(x).RecValCount; + WriteData( n, 4); + for n := 0 to TPSRecordType(x).RecValCount - 1 do + WriteTypeNo(TPSRecordType(x).RecVal(n).FType.FinalTypeNo); + end; + if FExportName <> '' then + begin + WriteLong(Length(FExportName)); + WriteData(FExportName[1], length(FExportName)); + end; + WriteAttributes(x.Attributes); + end; + finally + Items.Free; + end; + end; + + procedure WriteVars; + var + l,j : Longint; + x: TPSVar; + begin + for l := 0 to FVars.Count - 1 do + begin + x := FVars[l]; + if x.SaveAsPointer then + begin + for j := FTypes.count -1 downto 0 do + begin + if TPSType(FTypes[j]).BaseType = btPointer then + begin + WriteLong(TPSType(FTypes[j]).FinalTypeNo); + break; + end; + end; + end else + WriteLong(x.FType.FinalTypeNo); + if x.exportname <> '' then + begin + WriteByte( 1); + WriteLong(Length(X.ExportName)); + WriteData( X.ExportName[1], length(X.ExportName)); + end else + WriteByte( 0); + end; + end; + + procedure WriteProcs; + var + l: Longint; + xp: TPSProcedure; + xo: TPSInternalProcedure; + xe: TPSExternalProcedure; + s: tbtString; + att: Byte; + begin + for l := 0 to FProcs.Count - 1 do + begin + xp := FProcs[l]; + if xp.Attributes.Count <> 0 then att := 4 else att := 0; + if xp.ClassType = TPSInternalProcedure then + begin + xo := TPSInternalProcedure(xp); + xo.OutputDeclPosition := Length(FOutput); + WriteByte(att or 2); // exported + WriteLong(0); // offset is unknown at this time + WriteLong(0); // length is also unknown at this time + WriteLong(Length(xo.Name)); + WriteData( xo.Name[1], length(xo.Name)); + s := MakeExportDecl(xo.Decl); + WriteLong(Length(s)); + WriteData( s[1], length(S)); + end + else + begin + xe := TPSExternalProcedure(xp); + if xe.RegProc.ImportDecl <> '' then + begin + WriteByte( att or 3); // imported + if xe.RegProc.FExportName then + begin + WriteByte(Length(xe.RegProc.Name)); + WriteData(xe.RegProc.Name[1], Length(xe.RegProc.Name) and $FF); + end else begin + WriteByte(0); + end; + WriteLong(Length(xe.RegProc.ImportDecl)); + WriteData(xe.RegProc.ImportDecl[1], Length(xe.RegProc.ImportDecl)); + end else begin + WriteByte(att or 1); // imported + WriteByte(Length(xe.RegProc.Name)); + WriteData(xe.RegProc.Name[1], Length(xe.RegProc.Name) and $FF); + end; + end; + if xp.Attributes.Count <> 0 then + WriteAttributes(xp.Attributes); + end; + end; + + procedure WriteProcs2; + var + l: Longint; + L2: Cardinal; + x: TPSProcedure; + begin + for l := 0 to FProcs.Count - 1 do + begin + x := FProcs[l]; + if x.ClassType = TPSInternalProcedure then + begin + if TPSInternalProcedure(x).Data = '' then + TPSInternalProcedure(x).Data := Chr(Cm_R); + L2 := Length(FOutput); + Move(L2, FOutput[TPSInternalProcedure(x).OutputDeclPosition + 2], 4); + // write position + WriteData(TPSInternalProcedure(x).Data[1], Length(TPSInternalProcedure(x).Data)); + L2 := Cardinal(Length(FOutput)) - L2; + Move(L2, FOutput[TPSInternalProcedure(x).OutputDeclPosition + 6], 4); // write length + end; + end; + end; + + + + {$IFDEF PS_USESSUPPORT} + function FindMainProc: Cardinal; + var + l: Longint; + Proc : TPSInternalProcedure; + ProcData : tbtString; + Calls : Integer; + + procedure WriteProc(const aData: Longint); + var + l: Longint; + begin + ProcData := ProcData + Chr(cm_c); + l := Length(ProcData); + SetLength(ProcData, l + 4); + Move(aData, ProcData[l + 1], 4); + inc(Calls); + end; + begin + ProcData := ''; Calls := 1; + for l := 0 to FUnitInits.Count-1 do + if (FUnitInits[l] <> nil) and + (TPSBlockInfo(FUnitInits[l]).Proc.Data<>'') then + WriteProc(TPSBlockInfo(FUnitInits[l]).FProcNo); + + WriteProc(FGlobalBlock.FProcNo); + + for l := FUnitFinits.Count-1 downto 0 do + if (FUnitFinits[l] <> nil) and + (TPSBlockInfo(FUnitFinits[l]).Proc.Data<>'') then + WriteProc(TPSBlockInfo(FUnitFinits[l]).FProcNo); + + if Calls = 1 then begin + Result := FGlobalBlock.FProcNo; + end else + begin + Proc := NewProc('Master proc', '!MASTERPROC'); + Result := FindProc('!MASTERPROC'); + Proc.data := Procdata + Chr(cm_R); + end; + end; + {$ELSE} + function FindMainProc: Cardinal; + var + l: Longint; + begin + for l := 0 to FProcs.Count - 1 do + begin + if (TPSProcedure(FProcs[l]).ClassType = TPSInternalProcedure) and + (TPSInternalProcedure(FProcs[l]).Name = PSMainProcName) then + begin + Result := l; + exit; + end; + end; + Result := InvalidVal; + end; + {$ENDIF} + + procedure CreateDebugData; + var + I: Longint; + p: TPSProcedure; + pv: TPSVar; + s: tbtString; + begin + s := #0; + for I := 0 to FProcs.Count - 1 do + begin + p := FProcs[I]; + if p.ClassType = TPSInternalProcedure then + begin + if TPSInternalProcedure(p).Name = PSMainProcName then + s := s + #1 + else + s := s + TPSInternalProcedure(p).OriginalName + #1; + end + else + begin + s := s+ TPSExternalProcedure(p).RegProc.OrgName + #1; + end; + end; + s := s + #0#1; + for I := 0 to FVars.Count - 1 do + begin + pv := FVars[I]; + s := s + pv.OrgName + #1; + end; + s := s + #0; + WriteDebugData(s); + end; + + var //nvds + MainProc : Cardinal; //nvds + + begin + if @FOnBeforeOutput <> nil then + begin + if not FOnBeforeOutput(Self) then + begin + Result := false; + exit; + end; + end; + MainProc := FindMainProc; //NvdS (need it here becose FindMainProc can create a New proc. + CreateDebugData; + WriteLong(PSValidHeader); + WriteLong(PSCurrentBuildNo); + WriteLong(FCurrUsedTypeNo); + WriteLong(FProcs.Count); + WriteLong(FVars.Count); + WriteLong(MainProc); //nvds + WriteLong(0); + WriteTypes; + WriteProcs; + WriteVars; + WriteProcs2; + + Result := true; + end; + + function CheckExports: Boolean; + var + i: Longint; + p: TPSProcedure; + begin + if @FOnExportCheck = nil then + begin + result := true; + exit; + end; + for i := 0 to FProcs.Count -1 do + begin + p := FProcs[I]; + if p.ClassType = TPSInternalProcedure then + begin + if not FOnExportCheck(Self, TPSInternalProcedure(p), MakeDecl(TPSInternalProcedure(p).Decl)) then + begin + Result := false; + exit; + end; + end; + end; + Result := True; + end; + function DoConstBlock: Boolean; + var + COrgName: tbtString; + CTemp, CValue: PIFRVariant; + Cp: TPSConstant; + TokenPos, TokenRow, TokenCol: Integer; + begin + FParser.Next; + repeat + if FParser.CurrTokenID <> CSTI_Identifier then + begin + MakeError('', ecIdentifierExpected, ''); + Result := False; + Exit; + end; + TokenPos := FParser.CurrTokenPos; + TokenRow := FParser.Row; + TokenCol := FParser.Col; + COrgName := FParser.OriginalToken; + if IsDuplicate(FastUpperCase(COrgName), [dcVars, dcProcs, dcConsts]) then + begin + MakeError('', ecDuplicateIdentifier, COrgName); + Result := False; + exit; + end; + FParser.Next; + if FParser.CurrTokenID <> CSTI_Equal then + begin + MakeError('', ecIsExpected, ''); + Result := False; + Exit; + end; + FParser.Next; + CValue := ReadConstant(FParser, CSTI_SemiColon); + if CValue = nil then + begin + Result := False; + Exit; + end; + if FParser.CurrTokenID <> CSTI_Semicolon then + begin + MakeError('', ecSemicolonExpected, ''); + Result := False; + exit; + end; + cp := TPSConstant.Create; + cp.Orgname := COrgName; + cp.Name := FastUpperCase(COrgName); + {$IFDEF PS_USESSUPPORT} + cp.DeclareUnit:=fModule; + {$ENDIF} + cp.DeclarePos := TokenPos; + cp.DeclareRow := TokenRow; + cp.DeclareCol := TokenCol; + New(CTemp); + InitializeVariant(CTemp, CValue.FType); + CopyVariantContents(cvalue, CTemp); + cp.Value := CTemp; + FConstants.Add(cp); + DisposeVariant(CValue); + FParser.Next; + until FParser.CurrTokenId <> CSTI_Identifier; + Result := True; + end; + + function ProcessUses: Boolean; + var + {$IFNDEF PS_USESSUPPORT} + FUses: TIfStringList; + {$ENDIF} + I: Longint; + s: tbtString; + {$IFDEF PS_USESSUPPORT} + Parse: Boolean; + ParseUnit: tbtString; + ParserPos: TPSPascalParser; + {$ENDIF} + begin + FParser.Next; + {$IFNDEF PS_USESSUPPORT} + FUses := TIfStringList.Create; + FUses.Add('SYSTEM'); + {$ENDIF} + repeat + if FParser.CurrTokenID <> CSTI_Identifier then + begin + MakeError('', ecIdentifierExpected, ''); + {$IFNDEF PS_USESSUPPORT} + FUses.Free; + {$ENDIF} + Result := False; + exit; + end; + s := FParser.GetToken; + {$IFDEF PS_USESSUPPORT} + Parse:=true; + {$ENDIF} + for i := 0 to FUses.Count -1 do + begin + if FUses[I] = s then + begin + {$IFNDEF PS_USESSUPPORT} + MakeError('', ecDuplicateIdentifier, s); + FUses.Free; + Result := False; + exit; + {$ELSE} + Parse:=false; + {$ENDIF} + end; + end; + {$IFDEF PS_USESSUPPORT} + if Parse then + begin + {$ENDIF} + FUses.Add(s); + if @FOnUses <> nil then + begin + try + {$IFDEF PS_USESSUPPORT} + OldFileName:=fModule; + fModule:=FParser.OriginalToken; + ParseUnit:=FParser.OriginalToken; + ParserPos:=FParser; + {$ENDIF} + if not OnUses(Self, FParser.GetToken) then + begin + {$IFNDEF PS_USESSUPPORT} + FUses.Free; + {$ELSE} + FParser:=ParserPos; + fModule:=OldFileName; + MakeError(OldFileName, ecUnitNotFoundOrContainsErrors, ParseUnit); + {$ENDIF} + Result := False; + exit; + end; + {$IFDEF PS_USESSUPPORT} + fModule:=OldFileName; + {$ENDIF} + except + on e: Exception do + begin + MakeError('', ecCustomError, tbtstring(e.Message)); + {$IFNDEF PS_USESSUPPORT} + FUses.Free; + {$ENDIF} + Result := False; + exit; + end; + end; + end; + {$IFDEF PS_USESSUPPORT} + end; + {$ENDIF} + FParser.Next; + if FParser.CurrTokenID = CSTI_Semicolon then break + else if FParser.CurrTokenId <> CSTI_Comma then + begin + MakeError('', ecSemicolonExpected, ''); + Result := False; + {$IFNDEF PS_USESSUPPORT} + FUses.Free; + {$ENDIF} + exit; + end; + FParser.Next; + until False; + {$IFNDEF PS_USESSUPPORT} + FUses.Free; + {$ENDIF} + FParser.next; + Result := True; + end; + +var + Proc: TPSProcedure; + {$IFDEF PS_USESSUPPORT} + Block : TPSBlockInfo; //nvds + {$ENDIF} +begin + Result := False; + FWithCount := -1; + + {$IFDEF PS_USESSUPPORT} + if fInCompile=0 then + begin + {$ENDIF} + FUnitName := ''; + FCurrUsedTypeNo := 0; + FIsUnit := False; + Clear; + FParserHadError := False; + FParser.SetText(s); + FAttributeTypes := TPSList.Create; + FProcs := TPSList.Create; + FConstants := TPSList.Create; + FVars := TPSList.Create; + FTypes := TPSList.Create; + FRegProcs := TPSList.Create; + FClasses := TPSList.Create; + + {$IFDEF PS_USESSUPPORT} + FUnitInits := TPSList.Create; //nvds + FUnitFinits:= TPSList.Create; //nvds + + FUses:=TIFStringList.Create; + {$ENDIF} + {$IFNDEF PS_NOINTERFACES} FInterfaces := TPSList.Create;{$ENDIF} + + FGlobalBlock := TPSBlockInfo.Create(nil); + FGlobalBlock.SubType := tMainBegin; + + FGlobalBlock.Proc := NewProc(PSMainProcNameOrg, PSMainProcName); + FGlobalBlock.ProcNo := FindProc(PSMainProcName); + + {$IFDEF PS_USESSUPPORT} + OldFileName:=fModule; + fModule:='System'; + FUses.Add('SYSTEM'); + {$ENDIF} + {$IFNDEF PS_NOSTANDARDTYPES} + DefineStandardTypes; + DefineStandardProcedures; + {$ENDIF} + if @FOnUses <> nil then + begin + try + if not OnUses(Self, 'SYSTEM') then + begin + Cleanup; + exit; + end; + except + on e: Exception do + begin + MakeError('', ecCustomError, tbtstring(e.Message)); + Cleanup; + exit; + end; + end; + end; + {$IFDEF PS_USESSUPPORT} + fModule:=OldFileName; + OldParser:=nil; + OldIsUnit:=false; // defaults + end + else + begin + OldParser:=FParser; + OldIsUnit:=FIsUnit; + FParser:=TPSPascalParser.Create; + FParser.SetText(s); + end; + + inc(fInCompile); + {$ENDIF} + + Position := csStart; + repeat + if FParser.CurrTokenId = CSTI_EOF then + begin + if FParserHadError then + begin + Cleanup; + exit; + end; + if FAllowNoEnd then + Break + else + begin + MakeError('', ecUnexpectedEndOfFile, ''); + Cleanup; + exit; + end; + end; + if (FParser.CurrTokenId = CSTII_Program) and (Position = csStart) then + begin + {$IFDEF PS_USESSUPPORT} + if fInCompile>1 then + begin + MakeError('', ecNotAllowed, 'program'); + Cleanup; + exit; + end; + {$ENDIF} + Position := csProgram; + FParser.Next; + if FParser.CurrTokenId <> CSTI_Identifier then + begin + MakeError('', ecIdentifierExpected, ''); + Cleanup; + exit; + end; + FParser.Next; + if FParser.CurrTokenId <> CSTI_Semicolon then + begin + MakeError('', ecSemicolonExpected, ''); + Cleanup; + exit; + end; + FParser.Next; + end else + if (Fparser.CurrTokenID = CSTII_Implementation) and ((Position = csinterface) or (position = csInterfaceUses)) then + begin + Position := csImplementation; + FParser.Next; + end else + if (Fparser.CurrTokenID = CSTII_Interface) and (Position = csUnit) then + begin + Position := csInterface; + FParser.Next; + end else + if (FParser.CurrTokenId = CSTII_Unit) and (Position = csStart) and (FAllowUnit) then + begin + Position := csUnit; + FIsUnit := True; + FParser.Next; + if FParser.CurrTokenId <> CSTI_Identifier then + begin + MakeError('', ecIdentifierExpected, ''); + Cleanup; + exit; + end; + if fInCompile = 1 then + FUnitName := FParser.OriginalToken; + FParser.Next; + if FParser.CurrTokenId <> CSTI_Semicolon then + begin + MakeError('', ecSemicolonExpected, ''); + Cleanup; + exit; + end; + FParser.Next; + end + else if (FParser.CurrTokenID = CSTII_Uses) and ((Position < csuses) or (Position = csInterface)) then + begin + if (Position = csInterface) or (Position =csInterfaceUses) + then Position := csInterfaceUses + else Position := csUses; + if not ProcessUses then + begin + Cleanup; + exit; + end; + end else if (FParser.CurrTokenId = CSTII_Procedure) or + (FParser.CurrTokenId = CSTII_Function) or (FParser.CurrTokenID = CSTI_OpenBlock) then + begin + if (Position = csInterface) or (position = csInterfaceUses) then + begin + if not ProcessFunction(True, nil) then + begin + Cleanup; + exit; + end; + end else begin + Position := csUses; + if not ProcessFunction(False, nil) then + begin + Cleanup; + exit; + end; + end; + end + else if (FParser.CurrTokenId = CSTII_Label) then + begin + if (Position = csInterface) or (Position =csInterfaceUses) + then Position := csInterfaceUses + else Position := csUses; + if not ProcessLabel(FGlobalBlock.Proc) then + begin + Cleanup; + exit; + end; + end + else if (FParser.CurrTokenId = CSTII_Var) then + begin + if (Position = csInterface) or (Position =csInterfaceUses) + then Position := csInterfaceUses + else Position := csUses; + if not DoVarBlock(nil) then + begin + Cleanup; + exit; + end; + end + else if (FParser.CurrTokenId = CSTII_Const) then + begin + if (Position = csInterface) or (Position =csInterfaceUses) + then Position := csInterfaceUses + else Position := csUses; + if not DoConstBlock then + begin + Cleanup; + exit; + end; + end + else if (FParser.CurrTokenId = CSTII_Type) then + begin + if (Position = csInterface) or (Position =csInterfaceUses) + then Position := csInterfaceUses + else Position := csUses; + if not DoTypeBlock(FParser) then + begin + Cleanup; + exit; + end; + end + else if (FParser.CurrTokenId = CSTII_Begin) + {$IFDEF PS_USESSUPPORT} + or ((FParser.CurrTokenID = CSTII_initialization) and FIsUnit) {$ENDIF} then //nvds + begin + {$IFDEF PS_USESSUPPORT} + if FIsUnit then + begin + Block := TPSBlockInfo.Create(nil); //nvds + Block.SubType := tUnitInit; //nvds + Block.Proc := NewProc(PSMainProcNameOrg+'_'+fModule, FastUpperCase(PSMainProcName+'_'+fModule)); //nvds + Block.ProcNo := FindProc(PSMainProcName+'_'+fModule); //nvds + Block.Proc.DeclareUnit:= fModule; + Block.Proc.DeclarePos := FParser.CurrTokenPos; + Block.Proc.DeclareRow := FParser.Row; + Block.Proc.DeclareCol := FParser.Col; + Block.Proc.Use; + FUnitInits.Add(Block); + if ProcessSub(Block) then + begin + if (Fparser.CurrTokenId = CSTI_EOF) THEN break; + end + else + begin + Cleanup; + exit; + end; + end + else + begin + FGlobalBlock.Proc.DeclareUnit:= fModule; + {$ENDIF} + FGlobalBlock.Proc.DeclarePos := FParser.CurrTokenPos; + FGlobalBlock.Proc.DeclareRow := FParser.Row; + FGlobalBlock.Proc.DeclareCol := FParser.Col; + if ProcessSub(FGlobalBlock) then + begin + break; + end + else + begin + Cleanup; + exit; + end; + {$IFDEF PS_USESSUPPORT} + end; + {$ENDIF} + end + {$IFDEF PS_USESSUPPORT} + else if ((FParser.CurrTokenID = CSTII_finalization) and FIsUnit) then //NvdS + begin + Block := TPSBlockInfo.Create(nil); + Block.SubType := tUnitFinish; + Block.Proc := NewProc('!Finish_'+fModule, '!FINISH_'+FastUppercase(fModule)); + Block.ProcNo := FindProc('!FINISH_'+FastUppercase(fModule)); + Block.Proc.DeclareUnit:= fModule; + + Block.Proc.DeclarePos := FParser.CurrTokenPos; + Block.Proc.DeclareRow := FParser.Row; + Block.Proc.DeclareCol := FParser.Col; + Block.Proc.use; + FUnitFinits.Add(Block); + if ProcessSub(Block) then + begin + break; + end else begin + Cleanup; + Result := False; //Cleanup; + exit; + end; + end + {$endif} + else if (Fparser.CurrTokenId = CSTII_End) and (FAllowNoBegin or FIsUnit) then + begin + FParser.Next; + if FParser.CurrTokenID <> CSTI_Period then + begin + MakeError('', ecPeriodExpected, ''); + Cleanup; + exit; + end; + break; + end else + begin + MakeError('', ecBeginExpected, ''); + Cleanup; + exit; + end; + until False; + + {$IFDEF PS_USESSUPPORT} + dec(fInCompile); + if fInCompile=0 then + begin + {$ENDIF} + if not ProcessLabelForwards(FGlobalBlock.Proc) then + begin + Cleanup; + exit; + end; + // NVDS: Do we need to check here also do a ProcessLabelForwards() for each Initialisation/finalization block? + + for i := 0 to FProcs.Count -1 do + begin + Proc := FProcs[I]; + if (Proc.ClassType = TPSInternalProcedure) and (TPSInternalProcedure(Proc).Forwarded) then + begin + with MakeError('', ecUnsatisfiedForward, TPSInternalProcedure(Proc).Name) do + begin + FPosition := TPSInternalProcedure(Proc).DeclarePos; + FRow := TPSInternalProcedure(Proc).DeclareRow; + FCol := TPSInternalProcedure(Proc).DeclareCol; + end; + Cleanup; + Exit; + end; + end; + if not CheckExports then + begin + Cleanup; + exit; + end; + for i := 0 to FVars.Count -1 do + begin + if not TPSVar(FVars[I]).Used then + begin + with MakeHint({$IFDEF PS_USESSUPPORT}TPSVar(FVars[I]).DeclareUnit{$ELSE}''{$ENDIF}, ehVariableNotUsed, TPSVar(FVars[I]).Name) do + begin + FPosition := TPSVar(FVars[I]).DeclarePos; + FRow := TPSVar(FVars[I]).DeclareRow; + FCol := TPSVar(FVars[I]).DeclareCol; + end; + end; + end; + + Result := MakeOutput; + Cleanup; + {$IFDEF PS_USESSUPPORT} + end + else + begin + fParser.Free; + fParser:=OldParser; + fIsUnit:=OldIsUnit; + result:=true; + end; + {$ENDIF} +end; + +constructor TPSPascalCompiler.Create; +begin + inherited Create; + FParser := TPSPascalParser.Create; + FParser.OnParserError := ParserError; + FAutoFreeList := TPSList.Create; + FOutput := ''; + {$IFDEF PS_USESSUPPORT} + FAllowUnit := true; + {$ENDIF} + FMessages := TPSList.Create; +end; + +destructor TPSPascalCompiler.Destroy; +begin + Clear; + FAutoFreeList.Free; + + FMessages.Free; + FParser.Free; + inherited Destroy; +end; + +function TPSPascalCompiler.GetOutput(var s: tbtString): Boolean; +begin + if Length(FOutput) <> 0 then + begin + s := FOutput; + Result := True; + end + else + Result := False; +end; + +function TPSPascalCompiler.GetMsg(l: Longint): TPSPascalCompilerMessage; +begin + Result := FMessages[l]; +end; + +function TPSPascalCompiler.GetMsgCount: Longint; +begin + Result := FMessages.Count; +end; + +procedure TPSPascalCompiler.DefineStandardTypes; +var + i: Longint; +begin + AddType('Byte', btU8); + FDefaultBoolType := AddTypeS('Boolean', '(False, True)'); + FDefaultBoolType.ExportName := True; + with TPSEnumType(AddType('LongBool', btEnum)) do + begin + HighValue := 2147483647; // make sure it's gonna be a 4 byte var + end; + with TPSEnumType(AddType('WordBool', btEnum)) do + begin + HighValue := 65535; // make sure it's gonna be a 2 byte var + end; + with TPSEnumType(AddType('ByteBool', btEnum)) do + begin + HighValue := 255; // make sure it's gonna be a 1 byte var + end; + //following 2 IFDEFs should actually be UNICODE IFDEFs... + AddType({$IFDEF PS_PANSICHAR}'AnsiChar'{$ELSE}'Char'{$ENDIF}, btChar); + {$IFDEF PS_PANSICHAR} + AddType('Char', btWideChar); + {$ENDIF} + {$IFNDEF PS_NOWIDESTRING} + AddType('WideChar', btWideChar); + AddType('WideString', btWideString); + AddType('UnicodeString', btUnicodeString); + {$ENDIF} + AddType('AnsiString', btString); + {$IFDEF DELPHI2009UP} + AddType('String', btUnicodeString); + ADdType('NativeString', btUnicodeString); + {$ELSE} + AddType('String', btString); + AddType('NativeString', btString); + {$ENDIF} + FAnyString := AddType('AnyString', btString); + AddType('ShortInt', btS8); + AddType('Word', btU16); + AddType('SmallInt', btS16); + AddType('LongInt', btS32); + at2ut(AddType('___Pointer', btPointer)); + AddType('LongWord', btU32); + AddTypeCopyN('Integer', 'LONGINT'); + AddTypeCopyN('Cardinal', 'LONGWORD'); + AddType('tbtString', btString); + {$IFNDEF PS_NOINT64} + AddType('Int64', btS64); + {$ENDIF} + AddType('Single', btSingle); + AddType('Double', btDouble); + AddType('Extended', btExtended); + AddType('Currency', btCurrency); + AddType({$IFDEF PS_PANSICHAR}'PAnsiChar'{$ELSE}'PChar'{$ENDIF}, btPChar); + AddType('Variant', btVariant); + AddType('!NotificationVariant', btNotificationVariant); + for i := FTypes.Count -1 downto 0 do AT2UT(FTypes[i]); + TPSArrayType(AddType('TVariantArray', btArray)).ArrayTypeNo := FindType('VARIANT'); + + with AddFunction('function Assigned(I: Longint): Boolean;') do + begin + Name := '!ASSIGNED'; + end; + + with AddFunction('procedure _T(Name: tbtString; v: Variant);') do + begin + Name := '!NOTIFICATIONVARIANTSET'; + end; + with AddFunction('function _T(Name: tbtString): Variant;') do + begin + Name := '!NOTIFICATIONVARIANTGET'; + end; +end; + + +function TPSPascalCompiler.FindType(const Name: tbtString): TPSType; +var + i, n: Longint; + RName: tbtString; +begin + if FProcs = nil then begin Result := nil; exit;end; + RName := Fastuppercase(Name); + n := makehash(rname); + for i := FTypes.Count - 1 downto 0 do + begin + Result := FTypes.Data[I]; + if (Result.NameHash = n) and (Result.name = rname) then + begin + Result := GetTypeCopyLink(Result); + exit; + end; + end; + result := nil; +end; + +function TPSPascalCompiler.AddConstant(const Name: tbtString; FType: TPSType): TPSConstant; +var + pc: TPSConstant; + val: PIfRVariant; +begin + if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); + + FType := GetTypeCopyLink(FType); + if FType = nil then + Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterConst, [name]); + pc := TPSConstant.Create; + pc.OrgName := name; + pc.Name := FastUppercase(name); + pc.DeclarePos:=InvalidVal; + {$IFDEF PS_USESSUPPORT} + pc.DeclareUnit:=fModule; + {$ENDIF} + New(Val); + InitializeVariant(Val, FType); + pc.Value := Val; + FConstants.Add(pc); + result := pc; +end; + +function TPSPascalCompiler.ReadAttributes(Dest: TPSAttributes): Boolean; +var + Att: TPSAttributeType; + at: TPSAttribute; + varp: PIfRVariant; + h, i: Longint; + s: tbtString; +begin + if FParser.CurrTokenID <> CSTI_OpenBlock then begin Result := true; exit; end; + FParser.Next; + if FParser.CurrTokenID <> CSTI_Identifier then + begin + MakeError('', ecIdentifierExpected, ''); + Result := False; + exit; + end; + s := FParser.GetToken; + h := MakeHash(s); + att := nil; + for i := FAttributeTypes.count -1 downto 0 do + begin + att := FAttributeTypes[i]; + if (att.FNameHash = h) and (att.FName = s) then + Break; + att := nil; + end; + if att = nil then + begin + MakeError('', ecUnknownIdentifier, ''); + Result := False; + exit; + end; + FParser.Next; + i := 0; + at := Dest.Add(att); + while att.Fields[i].Hidden do + begin + at.AddValue(NewVariant(at2ut(att.Fields[i].FieldType))); + inc(i); + end; + if FParser.CurrTokenId <> CSTI_OpenRound then + begin + MakeError('', ecOpenRoundExpected, ''); + Result := False; + exit; + end; + FParser.Next; + if i < Att.FieldCount then + begin + while i < att.FieldCount do + begin + varp := ReadConstant(FParser, CSTI_CloseRound); + if varp = nil then + begin + Result := False; + exit; + end; + at.AddValue(varp); + if not IsCompatibleType(varp.FType, Att.Fields[i].FieldType, False) then + begin + MakeError('', ecTypeMismatch, ''); + Result := False; + exit; + end; + Inc(i); + while (i < Att.FieldCount) and (att.Fields[i].Hidden) do + begin + at.AddValue(NewVariant(at2ut(att.Fields[i].FieldType))); + inc(i); + end; + if i >= Att.FieldCount then + begin + break; + end else + begin + if FParser.CurrTokenID <> CSTI_Comma then + begin + MakeError('', ecCommaExpected, ''); + Result := False; + exit; + end; + end; + FParser.Next; + end; + end; + if FParser.CurrTokenID <> CSTI_CloseRound then + begin + MakeError('', ecCloseRoundExpected, ''); + Result := False; + exit; + end; + FParser.Next; + if FParser.CurrTokenID <> CSTI_CloseBlock then + begin + MakeError('', ecCloseBlockExpected, ''); + Result := False; + exit; + end; + FParser.Next; + Result := True; +end; + +type + TConstOperation = class(TObject) + private + FDeclPosition, FDeclRow, FDeclCol: Cardinal; + public + property DeclPosition: Cardinal read FDeclPosition write FDeclPosition; + property DeclRow: Cardinal read FDeclRow write FDeclRow; + property DeclCol: Cardinal read FDeclCol write FDeclCol; + procedure SetPos(Parser: TPSPascalParser); + end; + + TUnConstOperation = class(TConstOperation) + private + FOpType: TPSUnOperatorType; + FVal1: TConstOperation; + public + property OpType: TPSUnOperatorType read FOpType write FOpType; + property Val1: TConstOperation read FVal1 write FVal1; + + destructor Destroy; override; + end; + + TBinConstOperation = class(TConstOperation) + private + FOpType: TPSBinOperatorType; + FVal2: TConstOperation; + FVal1: TConstOperation; + public + property OpType: TPSBinOperatorType read FOpType write FOpType; + property Val1: TConstOperation read FVal1 write FVal1; + property Val2: TConstOperation read FVal2 write FVal2; + + destructor Destroy; override; + end; + + TConstData = class(TConstOperation) + private + FData: PIfRVariant; + public + property Data: PIfRVariant read FData write FData; + destructor Destroy; override; + end; + + +function TPSPascalCompiler.IsBoolean(aType: TPSType): Boolean; +begin + Result := (AType = FDefaultBoolType) + or (AType.Name = 'LONGBOOL') + or (AType.Name = 'WORDBOOL') + or (AType.Name = 'BYTEBOOL'); +end; + + +function TPSPascalCompiler.ReadConstant(FParser: TPSPascalParser; StopOn: TPSPasToken): PIfRVariant; + + function ReadExpression: TConstOperation; forward; + function ReadTerm: TConstOperation; forward; + function ReadFactor: TConstOperation; + var + NewVar: TConstOperation; + NewVarU: TUnConstOperation; + function GetConstantIdentifier: PIfRVariant; + var + s: tbtString; + sh: Longint; + i: Longint; + p: TPSConstant; + begin + s := FParser.GetToken; + sh := MakeHash(s); + for i := FConstants.Count -1 downto 0 do + begin + p := FConstants[I]; + if (p.NameHash = sh) and (p.Name = s) then + begin + New(Result); + InitializeVariant(Result, p.Value.FType); + CopyVariantContents(P.Value, Result); + FParser.Next; + exit; + end; + end; + MakeError('', ecUnknownIdentifier, ''); + Result := nil; + end; + begin + case fParser.CurrTokenID of + CSTII_Not: + begin + FParser.Next; + NewVar := ReadFactor; + if NewVar = nil then + begin + Result := nil; + exit; + end; + NewVarU := TUnConstOperation.Create; + NewVarU.OpType := otNot; + NewVarU.Val1 := NewVar; + NewVar := NewVarU; + end; + CSTI_Minus: + begin + FParser.Next; + NewVar := ReadTerm; + if NewVar = nil then + begin + Result := nil; + exit; + end; + NewVarU := TUnConstOperation.Create; + NewVarU.OpType := otMinus; + NewVarU.Val1 := NewVar; + NewVar := NewVarU; + end; + CSTI_OpenRound: + begin + FParser.Next; + NewVar := ReadExpression; + if NewVar = nil then + begin + Result := nil; + exit; + end; + if FParser.CurrTokenId <> CSTI_CloseRound then + begin + NewVar.Free; + Result := nil; + MakeError('', ecCloseRoundExpected, ''); + exit; + end; + FParser.Next; + end; + CSTI_Char, CSTI_String: + begin + NewVar := TConstData.Create; + NewVar.SetPos(FParser); + TConstData(NewVar).Data := ReadString; + end; + CSTI_HexInt, CSTI_Integer: + begin + NewVar := TConstData.Create; + NewVar.SetPos(FParser); + TConstData(NewVar).Data := ReadInteger(FParser.GetToken); + FParser.Next; + end; + CSTI_Real: + begin + NewVar := TConstData.Create; + NewVar.SetPos(FParser); + TConstData(NewVar).Data := ReadReal(FParser.GetToken); + FParser.Next; + end; + CSTI_Identifier: + begin + NewVar := TConstData.Create; + NewVar.SetPos(FParser); + TConstData(NewVar).Data := GetConstantIdentifier; + if TConstData(NewVar).Data = nil then + begin + NewVar.Free; + Result := nil; + exit; + end + end; + else + begin + MakeError('', ecSyntaxError, ''); + Result := nil; + exit; + end; + end; {case} + Result := NewVar; + end; // ReadFactor + + function ReadTerm: TConstOperation; + var + F1, F2: TConstOperation; + F: TBinConstOperation; + Token: TPSPasToken; + Op: TPSBinOperatorType; + begin + F1 := ReadFactor; + if F1 = nil then + begin + Result := nil; + exit; + end; + while FParser.CurrTokenID in [CSTI_Multiply, CSTI_Divide, CSTII_Div, CSTII_Mod, CSTII_And, CSTII_Shl, CSTII_Shr] do + begin + Token := FParser.CurrTokenID; + FParser.Next; + F2 := ReadFactor; + if f2 = nil then + begin + f1.Free; + Result := nil; + exit; + end; + case Token of + CSTI_Multiply: Op := otMul; + CSTII_div, CSTI_Divide: Op := otDiv; + CSTII_mod: Op := otMod; + CSTII_and: Op := otAnd; + CSTII_shl: Op := otShl; + CSTII_shr: Op := otShr; + else + Op := otAdd; + end; + F := TBinConstOperation.Create; + f.Val1 := F1; + f.Val2 := F2; + f.OpType := Op; + f1 := f; + end; + Result := F1; + end; // ReadTerm + + function ReadSimpleExpression: TConstOperation; + var + F1, F2: TConstOperation; + F: TBinConstOperation; + Token: TPSPasToken; + Op: TPSBinOperatorType; + begin + F1 := ReadTerm; + if F1 = nil then + begin + Result := nil; + exit; + end; + while FParser.CurrTokenID in [CSTI_Plus, CSTI_Minus, CSTII_Or, CSTII_Xor] do + begin + Token := FParser.CurrTokenID; + FParser.Next; + F2 := ReadTerm; + if f2 = nil then + begin + f1.Free; + Result := nil; + exit; + end; + case Token of + CSTI_Plus: Op := otAdd; + CSTI_Minus: Op := otSub; + CSTII_or: Op := otOr; + CSTII_xor: Op := otXor; + else + Op := otAdd; + end; + F := TBinConstOperation.Create; + f.Val1 := F1; + f.Val2 := F2; + f.OpType := Op; + f1 := f; + end; + Result := F1; + end; // ReadSimpleExpression + + + function ReadExpression: TConstOperation; + var + F1, F2: TConstOperation; + F: TBinConstOperation; + Token: TPSPasToken; + Op: TPSBinOperatorType; + begin + F1 := ReadSimpleExpression; + if F1 = nil then + begin + Result := nil; + exit; + end; + while FParser.CurrTokenID in [ CSTI_GreaterEqual, CSTI_LessEqual, CSTI_Greater, CSTI_Less, CSTI_Equal, CSTI_NotEqual] do + begin + Token := FParser.CurrTokenID; + FParser.Next; + F2 := ReadSimpleExpression; + if f2 = nil then + begin + f1.Free; + Result := nil; + exit; + end; + case Token of + CSTI_GreaterEqual: Op := otGreaterEqual; + CSTI_LessEqual: Op := otLessEqual; + CSTI_Greater: Op := otGreater; + CSTI_Less: Op := otLess; + CSTI_Equal: Op := otEqual; + CSTI_NotEqual: Op := otNotEqual; + else + Op := otAdd; + end; + F := TBinConstOperation.Create; + f.Val1 := F1; + f.Val2 := F2; + f.OpType := Op; + f1 := f; + end; + Result := F1; + end; // ReadExpression + + + function EvalConst(P: TConstOperation): PIfRVariant; + var + p1, p2: PIfRVariant; + begin + if p is TBinConstOperation then + begin + p1 := EvalConst(TBinConstOperation(p).Val1); + if p1 = nil then begin Result := nil; exit; end; + p2 := EvalConst(TBinConstOperation(p).Val2); + if p2 = nil then begin DisposeVariant(p1); Result := nil; exit; end; + if not PreCalc(False, 0, p1, 0, p2, TBinConstOperation(p).OpType, p.DeclPosition, p.DeclRow, p.DeclCol) then + begin + DisposeVariant(p1); + DisposeVariant(p2); +// MakeError('', ecTypeMismatch, ''); + result := nil; + exit; + end; + DisposeVariant(p2); + Result := p1; + end else if p is TUnConstOperation then + begin + with TUnConstOperation(P) do + begin + p1 := EvalConst(Val1); + case OpType of + otNot: + case p1.FType.BaseType of + btU8: p1.tu8 := not p1.tu8; + btU16: p1.tu16 := not p1.tu16; + btU32: p1.tu32 := not p1.tu32; + bts8: p1.ts8 := not p1.ts8; + bts16: p1.ts16 := not p1.ts16; + bts32: p1.ts32 := not p1.ts32; + {$IFNDEF PS_NOINT64} + bts64: p1.ts64 := not p1.ts64; + {$ENDIF} + else + begin + MakeError('', ecTypeMismatch, ''); + DisposeVariant(p1); + Result := nil; + exit; + end; + end; + otMinus: + case p1.FType.BaseType of + btU8: p1.tu8 := -p1.tu8; + btU16: p1.tu16 := -p1.tu16; + btU32: p1.tu32 := -p1.tu32; + bts8: p1.ts8 := -p1.ts8; + bts16: p1.ts16 := -p1.ts16; + bts32: p1.ts32 := -p1.ts32; + {$IFNDEF PS_NOINT64} + bts64: p1.ts64 := -p1.ts64; + {$ENDIF} + btDouble: p1.tdouble := - p1.tDouble; + btSingle: p1.tsingle := - p1.tsingle; + btCurrency: p1.tcurrency := - p1.tcurrency; + btExtended: p1.textended := - p1.textended; + else + begin + MakeError('', ecTypeMismatch, ''); + DisposeVariant(p1); + Result := nil; + exit; + end; + end; + else + begin + DisposeVariant(p1); + Result := nil; + exit; + end; + end; + end; + Result := p1; + end else + begin + if ((p as TConstData).Data.FType.BaseType = btString) + and (length(tbtstring((p as TConstData).Data.tstring)) =1) then + begin + New(p1); + InitializeVariant(p1, FindBaseType(btChar)); + p1.tchar := tbtstring((p as TConstData).Data.tstring)[1]; + Result := p1; + end else begin + New(p1); + InitializeVariant(p1, (p as TConstData).Data.FType); + CopyVariantContents((p as TConstData).Data, p1); + Result := p1; + end; + end; + end; + +var + Val: TConstOperation; +begin + Val := ReadExpression; + if val = nil then + begin + Result := nil; + exit; + end; + Result := EvalConst(Val); + Val.Free; +end; + +procedure TPSPascalCompiler.WriteDebugData(const s: tbtString); +begin + FDebugOutput := FDebugOutput + s; +end; + +function TPSPascalCompiler.GetDebugOutput(var s: tbtString): Boolean; +begin + if Length(FDebugOutput) <> 0 then + begin + s := FDebugOutput; + Result := True; + end + else + Result := False; +end; + +function TPSPascalCompiler.AddUsedFunction(var Proc: TPSInternalProcedure): Cardinal; +begin + if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); + Proc := TPSInternalProcedure.Create; + FProcs.Add(Proc); + Result := FProcs.Count - 1; +end; + +{$IFNDEF PS_NOINTERFACES} +const + IUnknown_Guid: TGuid = (D1: 0; d2: 0; d3: 0; d4: ($c0,00,00,00,00,00,00,$46)); + IDispatch_Guid: Tguid = (D1: $20400; D2: $0; D3: $0; D4:($C0, $0, $0, $0, $0, $0, $0, $46)); +{$ENDIF} + +procedure TPSPascalCompiler.DefineStandardProcedures; +var + p: TPSRegProc; +begin + {$IFNDEF PS_NOINT64} + AddFunction('function IntToStr(i: Int64): String;'); + {$ELSE} + AddFunction('function IntTostr(i: Integer): String;'); + {$ENDIF} + AddFunction('function StrToInt(s: String): Longint;'); + AddFunction('function StrToIntDef(s: String; def: Longint): Longint;'); + AddFunction('function Copy(s: AnyString; iFrom, iCount: Longint): AnyString;'); + AddFunction('function Pos(SubStr, S: AnyString): Longint;'); + AddFunction('procedure Delete(var s: AnyString; ifrom, icount: Longint);'); + AddFunction('procedure Insert(s: AnyString; var s2: AnyString; iPos: Longint);'); + p := AddFunction('function GetArrayLength: integer;'); + with P.Decl.AddParam do + begin + OrgName := 'arr'; + Mode := pmInOut; + end; + p := AddFunction('procedure SetArrayLength;'); + with P.Decl.AddParam do + begin + OrgName := 'arr'; + Mode := pmInOut; + end; + with P.Decl.AddParam do + begin + OrgName := 'count'; + aType := FindBaseType(btS32); + end; + AddFunction('Function StrGet(var S : String; I : Integer) : Char;'); + AddFunction('Function StrGet2(S : String; I : Integer) : Char;'); + AddFunction('procedure StrSet(c : Char; I : Integer; var s : String);'); + {$IFNDEF PS_NOWIDESTRING} + AddFunction('Function WStrGet(var S : AnyString; I : Integer) : WideChar;'); + AddFunction('procedure WStrSet(c : AnyString; I : Integer; var s : AnyString);'); + {$ENDIF} + AddFunction('Function AnsiUppercase(s : String) : String;'); + AddFunction('Function AnsiLowercase(s : String) : String;'); + AddFunction('Function Uppercase(s : AnyString) : AnyString;'); + AddFunction('Function Lowercase(s : AnyString) : AnyString;'); + AddFunction('Function Trim(s : AnyString) : AnyString;'); + AddFunction('function Length: Integer;').Decl.AddParam.OrgName:='s'; + with AddFunction('procedure SetLength;').Decl do + begin + with AddParam do + begin + OrgName:='s'; + Mode:=pmInOut; + end; + with AddParam do + begin + OrgName:='NewLength'; + aType:=FindBaseType(btS32); //Integer + end; + end; + {$IFNDEF PS_NOINT64} + AddFunction('function Low: Int64;').Decl.AddParam.OrgName:='x'; + AddFunction('function High: Int64;').Decl.AddParam.OrgName:='x'; + {$ELSE} + AddFunction('function Low: Integer;').Decl.AddParam.OrgName:='x'; + AddFunction('function High: Integer;').Decl.AddParam.OrgName:='x'; + {$ENDIF} + with AddFunction('procedure Dec;').Decl do begin + with AddParam do + begin + OrgName:='x'; + Mode:=pmInOut; + end; + end; + with AddFunction('procedure Inc;').Decl do begin + with AddParam do + begin + OrgName:='x'; + Mode:=pmInOut; + end; + end; + AddFunction('Function Sin(e : Extended) : Extended;'); + AddFunction('Function Cos(e : Extended) : Extended;'); + AddFunction('Function Sqrt(e : Extended) : Extended;'); + AddFunction('Function Round(e : Extended) : Longint;'); + AddFunction('Function Trunc(e : Extended) : Longint;'); + AddFunction('Function Int(e : Extended) : Extended;'); + AddFunction('Function Pi : Extended;'); + AddFunction('Function Abs(e : Extended) : Extended;'); + AddFunction('function StrToFloat(s: String): Extended;'); + AddFunction('Function FloatToStr(e : Extended) : String;'); + AddFunction('Function Padl(s : AnyString;I : longInt) : AnyString;'); + AddFunction('Function Padr(s : AnyString;I : longInt) : AnyString;'); + AddFunction('Function Padz(s : AnyString;I : longInt) : AnyString;'); + AddFunction('Function Replicate(c : char;I : longInt) : String;'); + AddFunction('Function StringOfChar(c : char;I : longInt) : String;'); + AddTypeS('TVarType', 'Word'); + AddConstantN('varEmpty', 'Word').Value.tu16 := varempty; + AddConstantN('varNull', 'Word').Value.tu16 := varnull; + AddConstantN('varSmallInt', 'Word').Value.tu16 := varsmallint; + AddConstantN('varInteger', 'Word').Value.tu16 := varinteger; + AddConstantN('varSingle', 'Word').Value.tu16 := varsingle; + AddConstantN('varDouble', 'Word').Value.tu16 := vardouble; + AddConstantN('varCurrency', 'Word').Value.tu16 := varcurrency; + AddConstantN('varDate', 'Word').Value.tu16 := vardate; + AddConstantN('varOleStr', 'Word').Value.tu16 := varolestr; + AddConstantN('varDispatch', 'Word').Value.tu16 := vardispatch; + AddConstantN('varError', 'Word').Value.tu16 := varerror; + AddConstantN('varBoolean', 'Word').Value.tu16 := varboolean; + AddConstantN('varVariant', 'Word').Value.tu16 := varvariant; + AddConstantN('varUnknown', 'Word').Value.tu16 := varunknown; +{$IFDEF DELPHI6UP} + AddConstantN('varShortInt', 'Word').Value.tu16 := varshortint; + AddConstantN('varByte', 'Word').Value.tu16 := varbyte; + AddConstantN('varWord', 'Word').Value.tu16 := varword; + AddConstantN('varLongWord', 'Word').Value.tu16 := varlongword; + AddConstantN('varInt64', 'Word').Value.tu16 := varint64; +{$ENDIF} +{$IFDEF DELPHI5UP} + AddConstantN('varStrArg', 'Word').Value.tu16 := varstrarg; + AddConstantN('varAny', 'Word').Value.tu16 := varany; +{$ENDIF} + AddConstantN('varString', 'Word').Value.tu16 := varstring; + AddConstantN('varTypeMask', 'Word').Value.tu16 := vartypemask; + AddConstantN('varArray', 'Word').Value.tu16 := vararray; + AddConstantN('varByRef', 'Word').Value.tu16 := varByRef; +{$IFDEF UNICODE} + AddConstantN('varUString', 'Word').Value.tu16 := varUString; +{$ENDIF} + AddDelphiFunction('function Unassigned: Variant;'); + AddDelphiFunction('function VarIsEmpty(const V: Variant): Boolean;'); + AddDelphiFunction('function Null: Variant;'); + AddDelphiFunction('function VarIsNull(const V: Variant): Boolean;'); + AddDelphiFunction('function VarType(const V: Variant): TVarType;'); + addTypeS('TIFException', '(ErNoError, erCannotImport, erInvalidType, ErInternalError, '+ + 'erInvalidHeader, erInvalidOpcode, erInvalidOpcodeParameter, erNoMainProc, erOutOfGlobalVarsRange, '+ + 'erOutOfProcRange, ErOutOfRange, erOutOfStackRange, ErTypeMismatch, erUnexpectedEof, '+ + 'erVersionError, ErDivideByZero, ErMathError,erCouldNotCallProc, erOutofRecordRange, '+ + 'erOutOfMemory, erException, erNullPointerException, erNullVariantError, erInterfaceNotSupported, erCustomError)'); + AddFunction('procedure RaiseLastException;'); + AddFunction('procedure RaiseException(Ex: TIFException; Param: String);'); + AddFunction('function ExceptionType: TIFException;'); + AddFunction('function ExceptionParam: String;'); + AddFunction('function ExceptionProc: Cardinal;'); + AddFunction('function ExceptionPos: Cardinal;'); + AddFunction('function ExceptionToString(er: TIFException; Param: String): String;'); + {$IFNDEF PS_NOINT64} + AddFunction('function StrToInt64(s: String): int64;'); + AddFunction('function Int64ToStr(i: Int64): String;'); + {$ENDIF} + + with AddFunction('function SizeOf: Longint;').Decl.AddParam do + begin + OrgName := 'Data'; + end; +{$IFNDEF PS_NOINTERFACES} + with AddInterface(nil, IUnknown_Guid, 'IUnknown') do + begin + RegisterDummyMethod; // Query Interface + RegisterDummyMethod; // _AddRef + RegisterDummyMethod; // _Release + end; + with AddInterface(nil, IUnknown_Guid, 'IInterface') do + begin + RegisterDummyMethod; // Query Interface + RegisterDummyMethod; // _AddRef + RegisterDummyMethod; // _Release + end; + + {$IFNDEF PS_NOIDISPATCH} + with AddInterface(FindInterface('IUnknown'), IDispatch_Guid, 'IDispatch') do + begin + RegisterDummyMethod; // GetTypeCount + RegisterDummyMethod; // GetTypeInfo + RegisterDummyMethod; // GetIdsOfName + RegisterDummyMethod; // Invoke + end; + with TPSInterfaceType(FindType('IDispatch')) do + begin + ExportName := True; + end; + AddDelphiFunction('function IDispatchInvoke(Self: IDispatch; PropertySet: Boolean; const Name: String; Par: array of variant): variant;'); + {$ENDIF} +{$ENDIF} +end; + +function TPSPascalCompiler.GetTypeCount: Longint; +begin + if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); + Result := FTypes.Count; +end; + +function TPSPascalCompiler.GetType(I: Longint): TPSType; +begin + if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); + Result := FTypes[I]; +end; + +function TPSPascalCompiler.GetVarCount: Longint; +begin + if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); + Result := FVars.Count; +end; + +function TPSPascalCompiler.GetVar(I: Longint): TPSVar; +begin + if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); + Result := FVars[i]; +end; + +function TPSPascalCompiler.GetProcCount: Longint; +begin + if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); + Result := FProcs.Count; +end; + +function TPSPascalCompiler.GetProc(I: Longint): TPSProcedure; +begin + if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); + Result := FProcs[i]; +end; + + + + +function TPSPascalCompiler.AddUsedFunction2(var Proc: TPSExternalProcedure): Cardinal; +begin + if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); + Proc := TPSExternalProcedure.Create; + FProcs.Add(Proc); + Result := FProcs.Count -1; +end; + +function TPSPascalCompiler.AddVariable(const Name: tbtString; FType: TPSType): TPSVar; +var + P: TPSVar; +begin + if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); + if FType = nil then raise EPSCompilerException.CreateFmt(RPS_InvalidTypeForVar, [Name]); + p := TPSVar.Create; + p.OrgName := Name; + p.Name := Fastuppercase(Name); + p.FType := AT2UT(FType); + p.exportname := p.Name; + FVars.Add(p); + Result := P; +end; + +function TPSPascalCompiler.AddAttributeType: TPSAttributeType; +begin + if FAttributeTypes = nil then Raise Exception.Create(RPS_OnUseEventOnly); + Result := TPSAttributeType.Create; + FAttributeTypes.Add(Result); +end; + +function TPSPascalCompiler.FindAttributeType(const Name: tbtString): TPSAttributeType; +var + h, i: Integer; + n: tbtString; +begin + if FAttributeTypes = nil then Raise Exception.Create(RPS_OnUseEventOnly); + n := FastUpperCase(Name); + h := MakeHash(n); + for i := FAttributeTypes.Count -1 downto 0 do + begin + result := TPSAttributeType(FAttributeTypes[i]); + if (Result.NameHash = h) and (Result.Name = n) then + exit; + end; + result := nil; +end; +function TPSPascalCompiler.GetConstCount: Longint; +begin + if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); + result := FConstants.Count; +end; + +function TPSPascalCompiler.GetConst(I: Longint): TPSConstant; +begin + if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); + Result := TPSConstant(FConstants[i]); +end; + +function TPSPascalCompiler.GetRegProcCount: Longint; +begin + if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); + Result := FRegProcs.Count; +end; + +function TPSPascalCompiler.GetRegProc(I: Longint): TPSRegProc; +begin + if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); + Result := TPSRegProc(FRegProcs[i]); +end; + + +procedure TPSPascalCompiler.AddToFreeList(Obj: TObject); +begin + FAutoFreeList.Add(Obj); +end; + +function TPSPascalCompiler.AddConstantN(const Name, + FType: tbtString): TPSConstant; +begin + Result := AddConstant(Name, FindType(FType)); +end; + +function TPSPascalCompiler.AddTypeCopy(const Name: tbtString; + TypeNo: TPSType): TPSType; +begin + if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); + TypeNo := GetTypeCopyLink(TypeNo); + if Typeno = nil then raise EPSCompilerException.Create(RPS_InvalidType); + Result := AddType(Name, BtTypeCopy); + TPSTypeLink(Result).LinkTypeNo := TypeNo; +end; + +function TPSPascalCompiler.AddTypeCopyN(const Name, + FType: tbtString): TPSType; +begin + Result := AddTypeCopy(Name, FindType(FType)); +end; + + +function TPSPascalCompiler.AddUsedVariable(const Name: tbtString; + FType: TPSType): TPSVar; +begin + Result := AddVariable(Name, FType); + if Result <> nil then + Result.Use; +end; + +function TPSPascalCompiler.AddUsedVariableN(const Name, + FType: tbtString): TPSVar; +begin + Result := AddVariable(Name, FindType(FType)); + if Result <> nil then + Result.Use; +end; + +function TPSPascalCompiler.AddVariableN(const Name, + FType: tbtString): TPSVar; +begin + Result := AddVariable(Name, FindType(FType)); +end; + +function TPSPascalCompiler.AddUsedPtrVariable(const Name: tbtString; FType: TPSType): TPSVar; +begin + Result := AddVariable(Name, FType); + if Result <> nil then + begin + result.SaveAsPointer := True; + Result.Use; + end; +end; + +function TPSPascalCompiler.AddUsedPtrVariableN(const Name, FType: tbtString): TPSVar; +begin + Result := AddVariable(Name, FindType(FType)); + if Result <> nil then + begin + result.SaveAsPointer := True; + Result.Use; + end; +end; + +function TPSPascalCompiler.AddTypeS(const Name, Decl: tbtString): TPSType; +var + Parser: TPSPascalParser; +begin + if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); + Parser := TPSPascalParser.Create; + Parser.SetText(Decl); + Result := ReadType(Name, Parser); + if Result<>nil then + begin + Result.DeclarePos:=InvalidVal; + {$IFDEF PS_USESSUPPORT} + Result.DeclareUnit:=fModule; + {$ENDIF} + Result.DeclareRow:=0; + Result.DeclareCol:=0; + end; + Parser.Free; + if result = nil then Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterType, [name]); +end; + + +function TPSPascalCompiler.CheckCompatProc(P: TPSType; ProcNo: Cardinal): Boolean; +var + i: Longint; + s1, s2: TPSParametersDecl; +begin + if p.BaseType <> btProcPtr then begin + Result := False; + Exit; + end; + + S1 := TPSProceduralType(p).ProcDef; + + if TPSProcedure(FProcs[ProcNo]).ClassType = TPSInternalProcedure then + s2 := TPSInternalProcedure(FProcs[ProcNo]).Decl + else + s2 := TPSExternalProcedure(FProcs[ProcNo]).RegProc.Decl; + if (s1.Result <> s2.Result) or (s1.ParamCount <> s2.ParamCount) then + begin + Result := False; + Exit; + end; + for i := 0 to s1.ParamCount -1 do + begin + if (s1.Params[i].Mode <> s2.Params[i].Mode) or (s1.Params[i].aType <> s2.Params[i].aType) then + begin + Result := False; + Exit; + end; + end; + Result := True; +end; + +function TPSPascalCompiler.MakeExportDecl(decl: TPSParametersDecl): tbtString; +var + i: Longint; +begin + if Decl.Result = nil then result := '-1' else + result := IntToStr(Decl.Result.FinalTypeNo); + + for i := 0 to decl.ParamCount -1 do + begin + if decl.GetParam(i).Mode = pmIn then + Result := Result + ' @' + else + Result := Result + ' !'; + Result := Result + inttostr(decl.GetParam(i).aType.FinalTypeNo); + end; +end; + + +function TPSPascalCompiler.IsIntBoolType(aType: TPSType): Boolean; +begin + if Isboolean(aType) then begin Result := True; exit;end; + + case aType.BaseType of + btU8, btS8, btU16, btS16, btU32, btS32{$IFNDEF PS_NOINT64}, btS64{$ENDIF}: Result := True; + else + Result := False; + end; +end; + + +procedure TPSPascalCompiler.ParserError(Parser: TObject; + Kind: TPSParserErrorKind); +begin + FParserHadError := True; + case Kind of + ICOMMENTERROR: MakeError('', ecCommentError, ''); + ISTRINGERROR: MakeError('', ecStringError, ''); + ICHARERROR: MakeError('', ecCharError, ''); + else + MakeError('', ecSyntaxError, ''); + end; +end; + + +function TPSPascalCompiler.AddDelphiFunction(const Decl: tbtString): TPSRegProc; +var + p: TPSRegProc; + pDecl: TPSParametersDecl; + DOrgName: tbtString; + FT: TPMFuncType; + i: Longint; + +begin + pDecl := TPSParametersDecl.Create; + p := nil; + try + if not ParseMethod(Self, '', Decl, DOrgName, pDecl, FT) then + Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Decl]); + + p := TPSRegProc.Create; + P.Name := FastUppercase(DOrgName); + p.OrgName := DOrgName; + p.ExportName := True; + p.Decl.Assign(pDecl); + + FRegProcs.Add(p); + + if pDecl.Result = nil then + begin + p.ImportDecl := p.ImportDecl + #0; + end else + p.ImportDecl := p.ImportDecl + #1; + for i := 0 to pDecl.ParamCount -1 do + begin + if pDecl.Params[i].Mode <> pmIn then + p.ImportDecl := p.ImportDecl + #1 + else + p.ImportDecl := p.ImportDecl + #0; + end; + finally + pDecl.Free; + end; + Result := p; +end; + +{$IFNDEF PS_NOINTERFACES} +function TPSPascalCompiler.AddInterface(InheritedFrom: TPSInterface; Guid: TGuid; const Name: tbtString): TPSInterface; +var + f: TPSType; +begin + if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); + f := FindType(Name); + if (f <> nil) and (f is TPSInterfaceType) then + begin + result := TPSInterfaceType(f).Intf; + Result.Guid := Guid; + Result.InheritedFrom := InheritedFrom; + exit; + end; + f := AddType(Name, btInterface); + Result := TPSInterface.Create(Self, InheritedFrom, GUID, FastUppercase(Name), f); + FInterfaces.Add(Result); + TPSInterfaceType(f).Intf := Result; +end; + +function TPSPascalCompiler.FindInterface(const Name: tbtString): TPSInterface; +var + n: tbtString; + i, nh: Longint; +begin + if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); + n := FastUpperCase(Name); + nh := MakeHash(n); + for i := FInterfaces.Count -1 downto 0 do + begin + Result := FInterfaces[i]; + if (Result.NameHash = nh) and (Result.Name = N) then + exit; + end; + raise EPSCompilerException.CreateFmt(RPS_UnknownInterface, [Name]); +end; +{$ENDIF} +function TPSPascalCompiler.AddClass(InheritsFrom: TPSCompileTimeClass; aClass: TClass): TPSCompileTimeClass; +var + f: TPSType; +begin + if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); + Result := FindClass(tbtstring(aClass.ClassName)); + if Result <> nil then exit; + f := AddType(tbtstring(aClass.ClassName), btClass); + Result := TPSCompileTimeClass.CreateC(aClass, Self, f); + Result.FInheritsFrom := InheritsFrom; + FClasses.Add(Result); + TPSClassType(f).Cl := Result; + f.ExportName := True; +end; + +function TPSPascalCompiler.AddClassN(InheritsFrom: TPSCompileTimeClass; const aClass: tbtString): TPSCompileTimeClass; +var + f: TPSType; +begin + if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); + Result := FindClass(aClass); + if Result <> nil then + begin + if InheritsFrom <> nil then + Result.FInheritsFrom := InheritsFrom; + exit; + end; + f := AddType(aClass, btClass); + Result := TPSCompileTimeClass.Create(FastUppercase(aClass), Self, f); + TPSClassType(f).Cl := Result; + Result.FInheritsFrom := InheritsFrom; + FClasses.Add(Result); + TPSClassType(f).Cl := Result; + f.ExportName := True; +end; + +function TPSPascalCompiler.FindClass(const aClass: tbtString): TPSCompileTimeClass; +var + i: Longint; + Cl: tbtString; + H: Longint; + x: TPSCompileTimeClass; +begin + cl := FastUpperCase(aClass); + H := MakeHash(Cl); + for i :=0 to FClasses.Count -1 do + begin + x := FClasses[I]; + if (X.FClassNameHash = H) and (X.FClassName = Cl) then + begin + Result := X; + Exit; + end; + end; + Result := nil; +end; + + + +{ } + +function TransDoubleToStr(D: Double): tbtString; +begin + SetLength(Result, SizeOf(Double)); + Double((@Result[1])^) := D; +end; + +function TransSingleToStr(D: Single): tbtString; +begin + SetLength(Result, SizeOf(Single)); + Single((@Result[1])^) := D; +end; + +function TransExtendedToStr(D: Extended): tbtString; +begin + SetLength(Result, SizeOf(Extended)); + Extended((@Result[1])^) := D; +end; + +function TransLongintToStr(D: Longint): tbtString; +begin + SetLength(Result, SizeOf(Longint)); + Longint((@Result[1])^) := D; +end; + +function TransCardinalToStr(D: Cardinal): tbtString; +begin + SetLength(Result, SizeOf(Cardinal)); + Cardinal((@Result[1])^) := D; +end; + +function TransWordToStr(D: Word): tbtString; +begin + SetLength(Result, SizeOf(Word)); + Word((@Result[1])^) := D; +end; + +function TransSmallIntToStr(D: SmallInt): tbtString; +begin + SetLength(Result, SizeOf(SmallInt)); + SmallInt((@Result[1])^) := D; +end; + +function TransByteToStr(D: Byte): tbtString; +begin + SetLength(Result, SizeOf(Byte)); + Byte((@Result[1])^) := D; +end; + +function TransShortIntToStr(D: ShortInt): tbtString; +begin + SetLength(Result, SizeOf(ShortInt)); + ShortInt((@Result[1])^) := D; +end; + +function TPSPascalCompiler.GetConstant(const Name: tbtString): TPSConstant; +var + h, i: Longint; + n: tbtString; + +begin + n := FastUppercase(name); + h := MakeHash(n); + for i := 0 to FConstants.Count -1 do + begin + result := TPSConstant(FConstants[i]); + if (Result.NameHash = h) and (Result.Name = n) then exit; + end; + result := nil; +end; + +{ TPSType } + +constructor TPSType.Create; +begin + inherited Create; + FAttributes := TPSAttributes.Create; + FFinalTypeNo := InvalidVal; +end; + +destructor TPSType.Destroy; +begin + FAttributes.Free; + inherited Destroy; +end; + +procedure TPSType.SetName(const Value: tbtString); +begin + FName := Value; + FNameHash := MakeHash(Value); +end; + +procedure TPSType.Use; +begin + FUsed := True; +end; + +{ TPSRecordType } + +function TPSRecordType.AddRecVal: PIFPSRecordFieldTypeDef; +begin + Result := TPSRecordFieldTypeDef.Create; + FRecordSubVals.Add(Result); +end; + +constructor TPSRecordType.Create; +begin + inherited Create; + FRecordSubVals := TPSList.Create; +end; + +destructor TPSRecordType.Destroy; +var + i: Longint; +begin + for i := FRecordSubVals.Count -1 downto 0 do + TPSRecordFieldTypeDef(FRecordSubVals[I]).Free; + FRecordSubVals.Free; + inherited Destroy; +end; + +function TPSRecordType.RecVal(I: Longint): PIFPSRecordFieldTypeDef; +begin + Result := FRecordSubVals[I] +end; + +function TPSRecordType.RecValCount: Longint; +begin + Result := FRecordSubVals.Count; +end; + + +{ TPSRegProc } + +constructor TPSRegProc.Create; +begin + inherited Create; + FDecl := TPSParametersDecl.Create; +end; + +destructor TPSRegProc.Destroy; +begin + FDecl.Free; + inherited Destroy; +end; + +procedure TPSRegProc.SetName(const Value: tbtString); +begin + FName := Value; + FNameHash := MakeHash(FName); +end; + +{ TPSRecordFieldTypeDef } + +procedure TPSRecordFieldTypeDef.SetFieldOrgName(const Value: tbtString); +begin + FFieldOrgName := Value; + FFieldName := FastUppercase(Value); + FFieldNameHash := MakeHash(FFieldName); +end; + +{ TPSProcVar } + +procedure TPSProcVar.SetName(const Value: tbtString); +begin + FName := Value; + FNameHash := MakeHash(FName); +end; + +procedure TPSProcVar.Use; +begin + FUsed := True; +end; + + + +{ TPSInternalProcedure } + +constructor TPSInternalProcedure.Create; +begin + inherited Create; + FProcVars := TPSList.Create; + FLabels := TIfStringList.Create; + FGotos := TIfStringList.Create; + FDecl := TPSParametersDecl.Create; +end; + +destructor TPSInternalProcedure.Destroy; +var + i: Longint; +begin + FDecl.Free; + for i := FProcVars.Count -1 downto 0 do + TPSProcVar(FProcVars[I]).Free; + FProcVars.Free; + FGotos.Free; + FLabels.Free; + inherited Destroy; +end; + +procedure TPSInternalProcedure.ResultUse; +begin + FResultUsed := True; +end; + +procedure TPSInternalProcedure.SetName(const Value: tbtString); +begin + FName := Value; + FNameHash := MakeHash(FName); +end; + +procedure TPSInternalProcedure.Use; +begin + FUsed := True; +end; + +{ TPSProcedure } +constructor TPSProcedure.Create; +begin + inherited Create; + FAttributes := TPSAttributes.Create; +end; + +destructor TPSProcedure.Destroy; +begin + FAttributes.Free; + inherited Destroy; +end; + +{ TPSVar } + +procedure TPSVar.SetName(const Value: tbtString); +begin + FName := Value; + FNameHash := MakeHash(Value); +end; + +procedure TPSVar.Use; +begin + FUsed := True; +end; + +{ TPSConstant } + +destructor TPSConstant.Destroy; +begin + DisposeVariant(Value); + inherited Destroy; +end; + +procedure TPSConstant.SetChar(c: tbtChar); +begin + if (FValue <> nil) then + begin + case FValue.FType.BaseType of + btChar: FValue.tchar := c; + btString: tbtString(FValue.tstring) := c; + {$IFNDEF PS_NOWIDESTRING} + btWideString: tbtwidestring(FValue.twidestring) := tbtWidestring(c); + btUnicodeString: tbtUnicodestring(FValue.twidestring) := tbtUnicodestring(c); + {$ENDIF} + else + raise EPSCompilerException.Create(RPS_ConstantValueMismatch); + end; + end else + raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned) +end; + +procedure TPSConstant.SetExtended(const Val: Extended); +begin + if (FValue <> nil) then + begin + case FValue.FType.BaseType of + btSingle: FValue.tsingle := Val; + btDouble: FValue.tdouble := Val; + btExtended: FValue.textended := Val; + btCurrency: FValue.tcurrency := Val; + else + raise EPSCompilerException.Create(RPS_ConstantValueMismatch); + end; + end else + raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned) +end; + +procedure TPSConstant.SetInt(const Val: Longint); +begin + if (FValue <> nil) then + begin + case FValue.FType.BaseType of + btEnum: FValue.tu32 := Val; + btU32, btS32: FValue.ts32 := Val; + btU16, btS16: FValue.ts16 := Val; + btU8, btS8: FValue.ts8 := Val; + btSingle: FValue.tsingle := Val; + btDouble: FValue.tdouble := Val; + btExtended: FValue.textended := Val; + btCurrency: FValue.tcurrency := Val; + {$IFNDEF PS_NOINT64} + bts64: FValue.ts64 := Val; + {$ENDIF} + else + raise EPSCompilerException.Create(RPS_ConstantValueMismatch); + end; + end else + raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned) +end; +{$IFNDEF PS_NOINT64} +procedure TPSConstant.SetInt64(const Val: Int64); +begin + if (FValue <> nil) then + begin + case FValue.FType.BaseType of + btEnum: FValue.tu32 := Val; + btU32, btS32: FValue.ts32 := Val; + btU16, btS16: FValue.ts16 := Val; + btU8, btS8: FValue.ts8 := Val; + btSingle: FValue.tsingle := Val; + btDouble: FValue.tdouble := Val; + btExtended: FValue.textended := Val; + btCurrency: FValue.tcurrency := Val; + bts64: FValue.ts64 := Val; + else + raise EPSCompilerException.Create(RPS_ConstantValueMismatch); + end; + end else + raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned) +end; +{$ENDIF} +procedure TPSConstant.SetName(const Value: tbtString); +begin + FName := Value; + FNameHash := MakeHash(Value); +end; + + +procedure TPSConstant.SetSet(const val); +begin + if (FValue <> nil) then + begin + case FValue.FType.BaseType of + btSet: + begin + if length(tbtstring(FValue.tstring)) <> TPSSetType(FValue.FType).ByteSize then + SetLength(tbtstring(FValue.tstring), TPSSetType(FValue.FType).ByteSize); + Move(Val, FValue.tstring^, TPSSetType(FValue.FType).ByteSize); + end; + else + raise EPSCompilerException.Create(RPS_ConstantValueMismatch); + end; + end else + raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned) +end; + +procedure TPSConstant.SetString(const Val: tbtString); +begin + if (FValue <> nil) then + begin + case FValue.FType.BaseType of + btChar: FValue.tchar := (Val+#0)[1]; + btWideChar: FValue.twidechar := WideChar((Val+#0)[1]); + btString: tbtString(FValue.tstring) := val; + {$IFNDEF PS_NOWIDESTRING} + btWideString: tbtwidestring(FValue.twidestring) := tbtwidestring(val); + btUnicodeString: tbtunicodestring(FValue.tunistring) := tbtunicodestring(val); + {$ENDIF} + else + raise EPSCompilerException.Create(RPS_ConstantValueMismatch); + end; + end else + raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned) +end; + +procedure TPSConstant.SetUInt(const Val: Cardinal); +begin + if (FValue <> nil) then + begin + case FValue.FType.BaseType of + btEnum: FValue.tu32 := Val; + btU32, btS32: FValue.tu32 := Val; + btU16, btS16: FValue.tu16 := Val; + btU8, btS8: FValue.tu8 := Val; + btSingle: FValue.tsingle := Val; + btDouble: FValue.tdouble := Val; + btExtended: FValue.textended := Val; + btCurrency: FValue.tcurrency := Val; + {$IFNDEF PS_NOINT64} + bts64: FValue.ts64 := Val; + {$ENDIF} + else + raise EPSCompilerException.Create(RPS_ConstantValueMismatch); + end; + end else + raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned) +end; + +{$IFNDEF PS_NOWIDESTRING} +procedure TPSConstant.SetWideChar(const val: WideChar); +begin + if (FValue <> nil) then + begin + case FValue.FType.BaseType of + btString: tbtString(FValue.tstring) := tbtstring(val); + btWideChar: FValue.twidechar := val; + btWideString: tbtwidestring(FValue.twidestring) := val; + btUnicodeString: tbtUnicodestring(FValue.tUniString) := val; + else + raise EPSCompilerException.Create(RPS_ConstantValueMismatch); + end; + end else + raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned) +end; + +procedure TPSConstant.SetWideString(const val: tbtwidestring); +begin + if (FValue <> nil) then + begin + case FValue.FType.BaseType of + btString: tbtString(FValue.tstring) := tbtstring(val); + btWideString: tbtwidestring(FValue.twidestring) := val; + btUnicodeString: tbtunicodestring(FValue.tunistring) := val; + else + raise EPSCompilerException.Create(RPS_ConstantValueMismatch); + end; + end else + raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned) +end; +procedure TPSConstant.SetUnicodeString(const val: tbtunicodestring); +begin + if (FValue <> nil) then + begin + case FValue.FType.BaseType of + btString: tbtString(FValue.tstring) := tbtstring(val); + btWideString: tbtwidestring(FValue.twidestring) := val; + btUnicodeString: tbtunicodestring(FValue.tunistring) := val; + else + raise EPSCompilerException.Create(RPS_ConstantValueMismatch); + end; + end else + raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned) +end; +{$ENDIF} +{ TPSPascalCompilerError } + +function TPSPascalCompilerError.ErrorType: tbtString; +begin + Result := tbtstring(RPS_Error); +end; + +function TPSPascalCompilerError.ShortMessageToString: tbtString; +begin + case Error of + ecUnknownIdentifier: Result := tbtstring(Format (RPS_UnknownIdentifier, [Param])); + ecIdentifierExpected: Result := tbtstring(RPS_IdentifierExpected); + ecCommentError: Result := tbtstring(RPS_CommentError); + ecStringError: Result := tbtstring(RPS_StringError); + ecCharError: Result := tbtstring(RPS_CharError); + ecSyntaxError: Result := tbtstring(RPS_SyntaxError); + ecUnexpectedEndOfFile: Result := tbtstring(RPS_EOF); + ecSemicolonExpected: Result := tbtstring(RPS_SemiColonExpected); + ecBeginExpected: Result := tbtstring(RPS_BeginExpected); + ecPeriodExpected: Result := tbtstring(RPS_PeriodExpected); + ecDuplicateIdentifier: Result := tbtstring(Format (RPS_DuplicateIdent, [Param])); + ecColonExpected: Result := tbtstring(RPS_ColonExpected); + ecUnknownType: Result := tbtstring(Format (RPS_UnknownType, [Param])); + ecCloseRoundExpected: Result := tbtstring(RPS_CloseRoundExpected); + ecTypeMismatch: Result := tbtstring(RPS_TypeMismatch); + ecInternalError: Result := tbtstring(Format (RPS_InternalError, [Param])); + ecAssignmentExpected: Result := tbtstring(RPS_AssignmentExpected); + ecThenExpected: Result := tbtstring(RPS_ThenExpected); + ecDoExpected: Result := tbtstring(RPS_DoExpected); + ecNoResult: Result := tbtstring(RPS_NoResult); + ecOpenRoundExpected: Result := tbtstring(RPS_OpenRoundExpected); + ecCommaExpected: Result := tbtstring(RPS_CommaExpected); + ecToExpected: Result := tbtstring(RPS_ToExpected); + ecIsExpected: Result := tbtstring(RPS_IsExpected); + ecOfExpected: Result := tbtstring(RPS_OfExpected); + ecCloseBlockExpected: Result := tbtstring(RPS_CloseBlockExpected); + ecVariableExpected: Result := tbtstring(RPS_VariableExpected); + ecStringExpected: result := tbtstring(RPS_StringExpected); + ecEndExpected: Result := tbtstring(RPS_EndExpected); + ecUnSetLabel: Result := tbtstring(Format (RPS_UnSetLabel, [Param])); + ecNotInLoop: Result := tbtstring(RPS_NotInLoop); + ecInvalidJump: Result := tbtstring(RPS_InvalidJump); + ecOpenBlockExpected: Result := tbtstring(RPS_OpenBlockExpected); + ecWriteOnlyProperty: Result := tbtstring(RPS_WriteOnlyProperty); + ecReadOnlyProperty: Result := tbtstring(RPS_ReadOnlyProperty); + ecClassTypeExpected: Result := tbtstring(RPS_ClassTypeExpected); + ecCustomError: Result := Param; + ecDivideByZero: Result := tbtstring(RPS_DivideByZero); + ecMathError: Result := tbtstring(RPS_MathError); + ecUnsatisfiedForward: Result := tbtstring(Format (RPS_UnsatisfiedForward, [Param])); + ecForwardParameterMismatch: Result := tbtstring(RPS_ForwardParameterMismatch); + ecInvalidnumberOfParameters: Result := tbtstring(RPS_InvalidNumberOfParameter); + {$IFDEF PS_USESSUPPORT} + ecNotAllowed : Result:=tbtstring(Format(RPS_NotAllowed,[Param])); + ecUnitNotFoundOrContainsErrors: Result:=tbtstring(Format(RPS_UnitNotFound,[Param])); + {$ENDIF} + else + Result := tbtstring(RPS_UnknownError); + end; + Result := Result; +end; + + +{ TPSPascalCompilerHint } + +function TPSPascalCompilerHint.ErrorType: tbtString; +begin + Result := tbtstring(RPS_Hint); +end; + +function TPSPascalCompilerHint.ShortMessageToString: tbtString; +begin + case Hint of + ehVariableNotUsed: Result := tbtstring(Format (RPS_VariableNotUsed, [Param])); + ehFunctionNotUsed: Result := tbtstring(Format (RPS_FunctionNotUsed, [Param])); + ehCustomHint: Result := Param; + else + Result := tbtstring(RPS_UnknownHint); + end; +end; + +{ TPSPascalCompilerWarning } + +function TPSPascalCompilerWarning.ErrorType: tbtString; +begin + Result := tbtstring(RPS_Warning); +end; + +function TPSPascalCompilerWarning.ShortMessageToString: tbtString; +begin + case Warning of + ewCustomWarning: Result := Param; + ewCalculationAlwaysEvaluatesTo: Result := tbtstring(Format (RPS_CalculationAlwaysEvaluatesTo, [Param])); + ewIsNotNeeded: Result := tbtstring(Format (RPS_IsNotNeeded, [Param])); + ewAbstractClass: Result := tbtstring(RPS_AbstractClass); + else + Result := tbtstring(RPS_UnknownWarning); + end; +end; + +{ TPSPascalCompilerMessage } + +function TPSPascalCompilerMessage.MessageToString: tbtString; +begin + Result := '['+ErrorType+'] '+FModuleName+'('+IntToStr(FRow)+':'+IntToStr(FCol)+'): '+ShortMessageToString; +end; + +procedure TPSPascalCompilerMessage.SetParserPos(Parser: TPSPascalParser); +begin + FPosition := Parser.CurrTokenPos; + FRow := Parser.Row; + FCol := Parser.Col; +end; + +procedure TPSPascalCompilerMessage.SetCustomPos(Pos, Row, Col: Cardinal); +begin + FPosition := Pos; + FRow := Row; + FCol := Col; +end; + +{ TUnConstOperation } + +destructor TUnConstOperation.Destroy; +begin + FVal1.Free; + inherited Destroy; +end; + + +{ TBinConstOperation } + +destructor TBinConstOperation.Destroy; +begin + FVal1.Free; + FVal2.Free; + inherited Destroy; +end; + +{ TConstData } + +destructor TConstData.Destroy; +begin + DisposeVariant(FData); + inherited Destroy; +end; + + +{ TConstOperation } + +procedure TConstOperation.SetPos(Parser: TPSPascalParser); +begin + FDeclPosition := Parser.CurrTokenPos; + FDeclRow := Parser.Row; + FDeclCol := Parser.Col; +end; + +{ TPSValue } + +procedure TPSValue.SetParserPos(P: TPSPascalParser); +begin + FPos := P.CurrTokenPos; + FRow := P.Row; + FCol := P.Col; +end; + +{ TPSValueData } + +destructor TPSValueData.Destroy; +begin + DisposeVariant(FData); + inherited Destroy; +end; + + +{ TPSValueReplace } + +constructor TPSValueReplace.Create; +begin + FFreeNewValue := True; + FReplaceTimes := 1; +end; + +destructor TPSValueReplace.Destroy; +begin + if FFreeOldValue then + FOldValue.Free; + if FFreeNewValue then + FNewValue.Free; + inherited Destroy; +end; + + + +{ TPSUnValueOp } + +destructor TPSUnValueOp.Destroy; +begin + FVal1.Free; + inherited Destroy; +end; + +{ TPSBinValueOp } + +destructor TPSBinValueOp.Destroy; +begin + FVal1.Free; + FVal2.Free; + inherited Destroy; +end; + + + + +{ TPSSubValue } + +destructor TPSSubValue.Destroy; +begin + FSubNo.Free; + inherited Destroy; +end; + +{ TPSValueVar } + +constructor TPSValueVar.Create; +begin + inherited Create; + FRecItems := TPSList.Create; +end; + +destructor TPSValueVar.Destroy; +var + i: Longint; +begin + for i := 0 to FRecItems.Count -1 do + begin + TPSSubItem(FRecItems[I]).Free; + end; + FRecItems.Free; + inherited Destroy; +end; + +function TPSValueVar.GetRecCount: Cardinal; +begin + Result := FRecItems.Count; +end; + +function TPSValueVar.GetRecItem(I: Cardinal): TPSSubItem; +begin + Result := FRecItems[I]; +end; + +function TPSValueVar.RecAdd(Val: TPSSubItem): Cardinal; +begin + Result := FRecItems.Add(Val); +end; + +procedure TPSValueVar.RecDelete(I: Cardinal); +var + rr :TPSSubItem; +begin + rr := FRecItems[i]; + FRecItems.Delete(I); + rr.Free; +end; + +{ TPSValueProc } + +destructor TPSValueProc.Destroy; +begin + FSelfPtr.Free; + FParameters.Free; +end; +{ TPSParameter } + +destructor TPSParameter.Destroy; +begin + FTempVar.Free; + FValue.Free; + inherited Destroy; +end; + + + { TPSParameters } + +function TPSParameters.Add: TPSParameter; +begin + Result := TPSParameter.Create; + FItems.Add(Result); +end; + +constructor TPSParameters.Create; +begin + inherited Create; + FItems := TPSList.Create; +end; + +procedure TPSParameters.Delete(I: Cardinal); +var + p: TPSParameter; +begin + p := FItems[I]; + FItems.Delete(i); + p.Free; +end; + +destructor TPSParameters.Destroy; +var + i: Longint; +begin + for i := FItems.Count -1 downto 0 do + begin + TPSParameter(FItems[I]).Free; + end; + FItems.Free; + inherited Destroy; +end; + +function TPSParameters.GetCount: Cardinal; +begin + Result := FItems.Count; +end; + +function TPSParameters.GetItem(I: Longint): TPSParameter; +begin + Result := FItems[I]; +end; + + +{ TPSValueArray } + +function TPSValueArray.Add(Item: TPSValue): Cardinal; +begin + Result := FItems.Add(Item); +end; + +constructor TPSValueArray.Create; +begin + inherited Create; + FItems := TPSList.Create; +end; + +procedure TPSValueArray.Delete(I: Cardinal); +begin + FItems.Delete(i); +end; + +destructor TPSValueArray.Destroy; +var + i: Longint; +begin + for i := FItems.Count -1 downto 0 do + TPSValue(FItems[I]).Free; + FItems.Free; + + inherited Destroy; +end; + +function TPSValueArray.GetCount: Cardinal; +begin + Result := FItems.Count; +end; + +function TPSValueArray.GetItem(I: Cardinal): TPSValue; +begin + Result := FItems[I]; +end; + + +{ TPSValueAllocatedStackVar } + +destructor TPSValueAllocatedStackVar.Destroy; +var + pv: TPSProcVar; +begin + {$IFDEF DEBUG} + if Cardinal(LocalVarNo +1) <> proc.ProcVars.Count then + begin + Abort; + exit; + end; + {$ENDIF} + if Proc <> nil then + begin + pv := Proc.ProcVars[Proc.ProcVars.Count -1]; + Proc.ProcVars.Delete(Proc.ProcVars.Count -1); + pv.Free; + Proc.Data := Proc.Data + tbtChar(CM_PO); + end; + inherited Destroy; +end; + + + + +function AddImportedClassVariable(Sender: TPSPascalCompiler; const VarName, VarType: tbtString): Boolean; +var + P: TPSVar; +begin + P := Sender.AddVariableN(VarName, VarType); + if p = nil then + begin + Result := False; + Exit; + end; + SetVarExportName(P, FastUppercase(VarName)); + p.Use; + Result := True; +end; + + +{'class:'+CLASSNAME+'|'+FUNCNAME+'|'+chr(CallingConv)+chr(hasresult)+params + +For property write functions there is an '@' after the funcname. +} + +const + ProcHDR = 'procedure a;'; + + + +{ TPSCompileTimeClass } + +function TPSCompileTimeClass.CastToType(IntoType: TPSType; + var ProcNo: Cardinal): Boolean; +var + P: TPSExternalProcedure; +begin + if (IntoType <> nil) and (IntoType.BaseType <> btClass) and (IntoType.BaseType <> btInterface) then + begin + Result := False; + exit; + end; + if FCastProc <> InvalidVal then + begin + Procno := FCastProc; + Result := True; + exit; + end; + ProcNo := FOwner. AddUsedFunction2(P); + P.RegProc := FOwner.AddFunction(ProcHDR); + P.RegProc.Name := ''; + + with P.RegProc.Decl.AddParam do + begin + OrgName := 'Org'; + aType := Self.FType; + end; + with P.RegProc.Decl.AddParam do + begin + OrgName := 'TypeNo'; + aType := FOwner.at2ut(FOwner.FindBaseType(btU32)); + end; + P.RegProc.Decl.Result := IntoType; + P.RegProc.ImportDecl := 'class:+'; + FCastProc := ProcNo; + Result := True; +end; + + +function TPSCompileTimeClass.ClassFunc_Call(Index: IPointer; + var ProcNo: Cardinal): Boolean; +var + C: TPSDelphiClassItemConstructor; + P: TPSExternalProcedure; + s: tbtString; + i: Longint; + +begin + if FIsAbstract then + FOwner.MakeWarning('', ewAbstractClass, ''); + C := Pointer(Index); + if c.MethodNo = InvalidVal then + begin + ProcNo := FOwner.AddUsedFunction2(P); + P.RegProc := FOwner.AddFunction(ProcHDR); + P.RegProc.Name := ''; + P.RegProc.Decl.Assign(c.Decl); + s := 'class:' + C.Owner.FClassName + '|' + C.Name + '|'+ chr(0); + if c.Decl.Result = nil then + s := s + #0 + else + s := s + #1; + for i := 0 to C.Decl.ParamCount -1 do + begin + if c.Decl.Params[i].Mode <> pmIn then + s := s + #1 + else + s := s + #0; + end; + P.RegProc.ImportDecl := s; + C.MethodNo := ProcNo; + end else begin + ProcNo := c.MethodNo; + end; + Result := True; +end; + +function TPSCompileTimeClass.ClassFunc_Find(const Name: tbtString; + var Index: IPointer): Boolean; +var + H: Longint; + I: Longint; + CurrClass: TPSCompileTimeClass; + C: TPSDelphiClassItem; +begin + H := MakeHash(Name); + CurrClass := Self; + while CurrClass <> nil do + begin + for i := CurrClass.FClassItems.Count -1 downto 0 do + begin + C := CurrClass.FClassItems[I]; + if (c is TPSDelphiClassItemConstructor) and (C.NameHash = H) and (C.Name = Name) then + begin + Index := Cardinal(C); + Result := True; + exit; + end; + end; + CurrClass := CurrClass.FInheritsFrom; + end; + Result := False; +end; + + +class function TPSCompileTimeClass.CreateC(FClass: TClass; aOwner: TPSPascalCompiler; aType: TPSType): TPSCompileTimeClass; +begin + Result := TPSCompileTimeClass.Create(FastUpperCase(tbtstring(FClass.ClassName)), aOwner, aType); + Result.FClass := FClass; +end; + +constructor TPSCompileTimeClass.Create(ClassName: tbtString; aOwner: TPSPascalCompiler; aType: TPSType); +begin + inherited Create; + FType := aType; + FCastProc := InvalidVal; + FNilProc := InvalidVal; + + FDefaultProperty := InvalidVal; + FClassName := Classname; + FClassNameHash := MakeHash(FClassName); + FClassItems := TPSList.Create; + FOwner := aOwner; +end; + +destructor TPSCompileTimeClass.Destroy; +var + I: Longint; +begin + for i := FClassItems.Count -1 downto 0 do + TPSDelphiClassItem(FClassItems[I]).Free; + FClassItems.Free; + inherited Destroy; +end; + + +function TPSCompileTimeClass.Func_Call(Index: IPointer; + var ProcNo: Cardinal): Boolean; +var + C: TPSDelphiClassItemMethod; + P: TPSExternalProcedure; + i: Longint; + s: tbtString; + +begin + C := Pointer(Index); + if c.MethodNo = InvalidVal then + begin + ProcNo := FOwner.AddUsedFunction2(P); + P.RegProc := FOwner.AddFunction(ProcHDR); + P.RegProc.Name := ''; + p.RegProc.Decl.Assign(c.Decl); + s := 'class:' + C.Owner.FClassName + '|' + C.Name + '|'+ chr(0); + if c.Decl.Result = nil then + s := s + #0 + else + s := s + #1; + for i := 0 to c.Decl.ParamCount -1 do + begin + if c.Decl.Params[i].Mode <> pmIn then + s := s + #1 + else + s := s + #0; + end; + P.RegProc.ImportDecl := s; + C.MethodNo := ProcNo; + end else begin + ProcNo := c.MethodNo; + end; + Result := True; +end; + +function TPSCompileTimeClass.Func_Find(const Name: tbtString; + var Index: IPointer): Boolean; +var + H: Longint; + I: Longint; + CurrClass: TPSCompileTimeClass; + C: TPSDelphiClassItem; +begin + H := MakeHash(Name); + CurrClass := Self; + while CurrClass <> nil do + begin + for i := CurrClass.FClassItems.Count -1 downto 0 do + begin + C := CurrClass.FClassItems[I]; + if (c is TPSDelphiClassItemMethod) and (C.NameHash = H) and (C.Name = Name) then + begin + Index := Cardinal(C); + Result := True; + exit; + end; + end; + CurrClass := CurrClass.FInheritsFrom; + end; + Result := False; +end; + +function TPSCompileTimeClass.GetCount: Longint; +begin + Result := FClassItems.Count; +end; + +function TPSCompileTimeClass.GetItem(i: Longint): TPSDelphiClassItem; +begin + Result := FClassItems[i]; +end; + +function TPSCompileTimeClass.IsCompatibleWith(aType: TPSType): Boolean; +var + Temp: TPSCompileTimeClass; +begin + if (atype.BaseType <> btClass) then + begin + Result := False; + exit; + end; + temp := TPSClassType(aType).Cl; + while Temp <> nil do + begin + if Temp = Self then + begin + Result := True; + exit; + end; + Temp := Temp.FInheritsFrom; + end; + Result := False; +end; + +function TPSCompileTimeClass.Property_Find(const Name: tbtString; + var Index: IPointer): Boolean; +var + H: Longint; + I: Longint; + CurrClass: TPSCompileTimeClass; + C: TPSDelphiClassItem; +begin + if Name = '' then + begin + CurrClass := Self; + while CurrClass <> nil do + begin + if CurrClass.FDefaultProperty <> InvalidVal then + begin + Index := Cardinal(CurrClass.FClassItems[Currclass.FDefaultProperty]); + result := True; + exit; + end; + CurrClass := CurrClass.FInheritsFrom; + end; + Result := False; + exit; + end; + H := MakeHash(Name); + CurrClass := Self; + while CurrClass <> nil do + begin + for i := CurrClass.FClassItems.Count -1 downto 0 do + begin + C := CurrClass.FClassItems[I]; + if (c is TPSDelphiClassItemProperty) and (C.NameHash = H) and (C.Name = Name) then + begin + Index := Cardinal(C); + Result := True; + exit; + end; + end; + CurrClass := CurrClass.FInheritsFrom; + end; + Result := False; +end; + +function TPSCompileTimeClass.Property_Get(Index: IPointer; + var ProcNo: Cardinal): Boolean; +var + C: TPSDelphiClassItemProperty; + P: TPSExternalProcedure; + s: tbtString; + +begin + C := Pointer(Index); + if c.AccessType = iptW then + begin + Result := False; + exit; + end; + if c.ReadProcNo = InvalidVal then + begin + ProcNo := FOwner.AddUsedFunction2(P); + P.RegProc := FOwner.AddFunction(ProcHDR); + P.RegProc.Name := ''; + P.RegProc.Decl.Result := C.Decl.Result; + s := 'class:' + C.Owner.FClassName + '|' + C.Name + '|'+#0#0#0#0; + Longint((@(s[length(s)-3]))^) := c.Decl.ParamCount +1; + P.RegProc.ImportDecl := s; + C.ReadProcNo := ProcNo; + end else begin + ProcNo := c.ReadProcNo; + end; + Result := True; +end; + +function TPSCompileTimeClass.Property_GetHeader(Index: IPointer; + Dest: TPSParametersDecl): Boolean; +var + c: TPSDelphiClassItemProperty; +begin + C := Pointer(Index); + FOwner.UseProc(c.Decl); + Dest.Assign(c.Decl); + Result := True; +end; + +function TPSCompileTimeClass.Property_Set(Index: IPointer; + var ProcNo: Cardinal): Boolean; +var + C: TPSDelphiClassItemProperty; + P: TPSExternalProcedure; + s: tbtString; + +begin + C := Pointer(Index); + if c.AccessType = iptR then + begin + Result := False; + exit; + end; + if c.WriteProcNo = InvalidVal then + begin + ProcNo := FOwner.AddUsedFunction2(P); + P.RegProc := FOwner.AddFunction(ProcHDR); + P.RegProc.Name := ''; + s := 'class:' + C.Owner.FClassName + '|' + C.Name + '@|'#0#0#0#0; + Longint((@(s[length(s)-3]))^) := C.Decl.ParamCount+1; + P.RegProc.ImportDecl := s; + C.WriteProcNo := ProcNo; + end else begin + ProcNo := c.WriteProcNo; + end; + Result := True; +end; + +function TPSCompileTimeClass.RegisterMethod(const Decl: tbtString): Boolean; +var + DOrgName: tbtString; + DDecl: TPSParametersDecl; + FT: TPMFuncType; + p: TPSDelphiClassItemMethod; +begin + DDecl := TPSParametersDecl.Create; + try + if not ParseMethod(FOwner, FClassName, Decl, DOrgName, DDecl, FT) then + begin + Result := False; + {$IFDEF DEBUG} raise EPSCompilerException.CreateFmt(RPS_UnableToRegister, [Decl]); {$ENDIF} + exit; + end; + if ft = mftConstructor then + p := TPSDelphiClassItemConstructor.Create(Self) + else + p := TPSDelphiClassItemMethod.Create(self); + p.OrgName := DOrgName; + p.Decl.Assign(DDecl); + p.MethodNo := InvalidVal; + FClassItems.Add(p); + Result := True; + finally + DDecl.Free; + end; +end; + +procedure TPSCompileTimeClass.RegisterProperty(const PropertyName, + PropertyType: tbtString; PropAC: TPSPropType); +var + FType: TPSType; + Param: TPSParameterDecl; + p: TPSDelphiClassItemProperty; + PT: tbtString; +begin + pt := PropertyType; + p := TPSDelphiClassItemProperty.Create(Self); + p.AccessType := PropAC; + p.ReadProcNo := InvalidVal; + p.WriteProcNo := InvalidVal; + p.OrgName := PropertyName; + repeat + FType := FOwner.FindType(FastUpperCase(grfw(pt))); + if FType = nil then + begin + p.Free; + Exit; + end; + if p.Decl.Result = nil then p.Decl.Result := FType else + begin + param := p.Decl.AddParam; + Param.OrgName := 'param'+IntToStr(p.Decl.ParamCount); + Param.aType := FType; + end; + until pt = ''; + FClassItems.Add(p); +end; + + +procedure TPSCompileTimeClass.RegisterPublishedProperties; +var + p: PPropList; + i, Count: Longint; + a: TPSPropType; +begin + if (Fclass = nil) or (Fclass.ClassInfo = nil) then exit; + Count := GetTypeData(fclass.ClassInfo)^.PropCount; + GetMem(p, Count * SizeOf(Pointer)); + GetPropInfos(fclass.ClassInfo, p); + for i := Count -1 downto 0 do + begin + if p^[i]^.PropType^.Kind in [tkLString, tkInteger, tkChar, tkEnumeration, tkFloat, tkString, tkSet, tkClass, tkMethod{$IFNDEF PS_NOWIDESTRING}, tkWString{$ENDIF}] then + begin + if (p^[i]^.GetProc <> nil) then + begin + if p^[i]^.SetProc = nil then + a := iptr + else + a := iptrw; + end else + begin + a := iptW; + if p^[i]^.SetProc = nil then continue; + end; + RegisterProperty(p^[i]^.Name, p^[i]^.PropType^.Name, a); + end; + end; + FreeMem(p); +end; + +function TPSCompileTimeClass.RegisterPublishedProperty(const Name: tbtString): Boolean; +var + p: PPropInfo; + a: TPSPropType; +begin + if (Fclass = nil) or (Fclass.ClassInfo = nil) then begin Result := False; exit; end; + p := GetPropInfo(fclass.ClassInfo, string(Name)); + if p = nil then begin Result := False; exit; end; + if (p^.GetProc <> nil) then + begin + if p^.SetProc = nil then + a := iptr + else + a := iptrw; + end else + begin + a := iptW; + if p^.SetProc = nil then begin result := False; exit; end; + end; + RegisterProperty(p^.Name, p^.PropType^.Name, a); + Result := True; +end; + + +procedure TPSCompileTimeClass.SetDefaultPropery(const Name: tbtString); +var + i,h: Longint; + p: TPSDelphiClassItem; + s: tbtString; + +begin + s := FastUppercase(name); + h := MakeHash(s); + for i := FClassItems.Count -1 downto 0 do + begin + p := FClassItems[i]; + if (p.NameHash = h) and (p.Name = s) then + begin + if p is TPSDelphiClassItemProperty then + begin + if p.Decl.ParamCount = 0 then + Raise EPSCompilerException.Create(RPS_NotArrayProperty); + FDefaultProperty := I; + exit; + end else Raise EPSCompilerException.Create(RPS_NotProperty); + end; + end; + raise EPSCompilerException.Create(RPS_UnknownProperty); +end; + +function TPSCompileTimeClass.SetNil(var ProcNo: Cardinal): Boolean; +var + P: TPSExternalProcedure; + +begin + if FNilProc <> InvalidVal then + begin + Procno := FNilProc; + Result := True; + exit; + end; + ProcNo := FOwner.AddUsedFunction2(P); + P.RegProc := FOwner.AddFunction(ProcHDR); + P.RegProc.Name := ''; + with P.RegProc.Decl.AddParam do + begin + OrgName := 'VarNo'; + aType := FOwner.at2ut(FType); + end; + P.RegProc.ImportDecl := 'class:-'; + FNilProc := Procno; + Result := True; +end; + +{ TPSSetType } + +function TPSSetType.GetBitSize: Longint; +begin + case SetType.BaseType of + btEnum: begin Result := TPSEnumType(setType).HighValue+1; end; + btChar, btU8: Result := 256; + else + Result := 0; + end; +end; + +function TPSSetType.GetByteSize: Longint; +var + r: Longint; +begin + r := BitSize; + if r mod 8 <> 0 then inc(r, 7); + Result := r div 8; +end; + + +{ TPSBlockInfo } + +procedure TPSBlockInfo.Clear; +var + i: Longint; +begin + for i := WithList.Count -1 downto 0 do + begin + TPSValue(WithList[i]).Free; + WithList.Delete(i); + end; +end; + +constructor TPSBlockInfo.Create(Owner: TPSBlockInfo); +begin + inherited Create; + FOwner := Owner; + FWithList := TPSList.Create; + if FOwner <> nil then + begin + FProcNo := FOwner.ProcNo; + FProc := FOwner.Proc; + end; +end; + +destructor TPSBlockInfo.Destroy; +begin + Clear; + FWithList.Free; + inherited Destroy; +end; + +{ TPSAttributeTypeField } +procedure TPSAttributeTypeField.SetFieldOrgName(const Value: tbtString); +begin + FFieldOrgName := Value; + FFieldName := FastUpperCase(Value); + FFieldNameHash := MakeHash(FFieldName); +end; + +constructor TPSAttributeTypeField.Create(AOwner: TPSAttributeType); +begin + inherited Create; + FOwner := AOwner; +end; + +{ TPSAttributeType } + +function TPSAttributeType.GetField(I: Longint): TPSAttributeTypeField; +begin + Result := TPSAttributeTypeField(FFields[i]); +end; + +function TPSAttributeType.GetFieldCount: Longint; +begin + Result := FFields.Count; +end; + +procedure TPSAttributeType.SetName(const s: tbtString); +begin + FOrgname := s; + FName := FastUppercase(s); + FNameHash := MakeHash(FName); +end; + +constructor TPSAttributeType.Create; +begin + inherited Create; + FFields := TPSList.Create; +end; + +destructor TPSAttributeType.Destroy; +var + i: Longint; +begin + for i := FFields.Count -1 downto 0 do + begin + TPSAttributeTypeField(FFields[i]).Free; + end; + FFields.Free; + inherited Destroy; +end; + +function TPSAttributeType.AddField: TPSAttributeTypeField; +begin + Result := TPSAttributeTypeField.Create(self); + FFields.Add(Result); +end; + +procedure TPSAttributeType.DeleteField(I: Longint); +var + Fld: TPSAttributeTypeField; +begin + Fld := FFields[i]; + FFields.Delete(i); + Fld.Free; +end; + +{ TPSAttribute } +function TPSAttribute.GetValueCount: Longint; +begin + Result := FValues.Count; +end; + +function TPSAttribute.GetValue(I: Longint): PIfRVariant; +begin + Result := FValues[i]; +end; + +constructor TPSAttribute.Create(AttribType: TPSAttributeType); +begin + inherited Create; + FValues := TPSList.Create; + FAttribType := AttribType; +end; + +procedure TPSAttribute.DeleteValue(i: Longint); +var + Val: PIfRVariant; +begin + Val := FValues[i]; + FValues.Delete(i); + DisposeVariant(Val); +end; + +function TPSAttribute.AddValue(v: PIFRVariant): Longint; +begin + Result := FValues.Add(v); +end; + + +destructor TPSAttribute.Destroy; +var + i: Longint; +begin + for i := FValues.Count -1 downto 0 do + begin + DisposeVariant(FValues[i]); + end; + FValues.Free; + inherited Destroy; +end; + + +procedure TPSAttribute.Assign(Item: TPSAttribute); +var + i: Longint; + p: PIfRVariant; +begin + for i := FValues.Count -1 downto 0 do + begin + DisposeVariant(FValues[i]); + end; + FValues.Clear; + FAttribType := Item.FAttribType; + for i := 0 to Item.FValues.Count -1 do + begin + p := DuplicateVariant(Item.FValues[i]); + FValues.Add(p); + end; +end; + +{ TPSAttributes } + +function TPSAttributes.GetCount: Longint; +begin + Result := FItems.Count; +end; + +function TPSAttributes.GetItem(I: Longint): TPSAttribute; +begin + Result := TPSAttribute(FItems[i]); +end; + +procedure TPSAttributes.Delete(i: Longint); +var + item: TPSAttribute; +begin + item := TPSAttribute(FItems[i]); + FItems.Delete(i); + Item.Free; +end; + +function TPSAttributes.Add(AttribType: TPSAttributeType): TPSAttribute; +begin + Result := TPSAttribute.Create(AttribType); + FItems.Add(Result); +end; + +constructor TPSAttributes.Create; +begin + inherited Create; + FItems := TPSList.Create; +end; + +destructor TPSAttributes.Destroy; +var + i: Longint; +begin + for i := FItems.Count -1 downto 0 do + begin + TPSAttribute(FItems[i]).Free; + end; + FItems.Free; + inherited Destroy; +end; + +procedure TPSAttributes.Assign(attr: TPSAttributes; Move: Boolean); +var + newitem, item: TPSAttribute; + i: Longint; +begin + for i := ATtr.FItems.Count -1 downto 0 do + begin + Item := Attr.Fitems[i]; + if Move then + begin + FItems.Add(Item); + Attr.FItems.Delete(i); + end else + begin + newitem := TPSAttribute.Create(Item.FAttribType ); + newitem.Assign(item); + FItems.Add(NewItem); + end; + end; + +end; + + +function TPSAttributes.FindAttribute( + const Name: tbtString): TPSAttribute; +var + h, i: Longint; + +begin + h := MakeHash(name); + for i := FItems.Count -1 downto 0 do + begin + Result := FItems[i]; + if (Result.FAttribType.NameHash = h) and (Result.FAttribType.Name = Name) then + exit; + end; + result := nil; +end; + +{ TPSParameterDecl } +procedure TPSParameterDecl.SetName(const s: tbtString); +begin + FOrgName := s; + FName := FastUppercase(s); +end; + + +{ TPSParametersDecl } + +procedure TPSParametersDecl.Assign(Params: TPSParametersDecl); +var + i: Longint; + np, orgp: TPSParameterDecl; +begin + for i := FParams.Count -1 downto 0 do + begin + TPSParameterDecl(Fparams[i]).Free; + end; + FParams.Clear; + FResult := Params.Result; + + for i := 0 to Params.FParams.count -1 do + begin + orgp := Params.FParams[i]; + np := AddParam; + np.OrgName := orgp.OrgName; + np.Mode := orgp.Mode; + np.aType := orgp.aType; + np.DeclarePos:=orgp.DeclarePos; + np.DeclareRow:=orgp.DeclareRow; + np.DeclareCol:=orgp.DeclareCol; + end; +end; + + +function TPSParametersDecl.GetParam(I: Longint): TPSParameterDecl; +begin + Result := FParams[i]; +end; + +function TPSParametersDecl.GetParamCount: Longint; +begin + Result := FParams.Count; +end; + +function TPSParametersDecl.AddParam: TPSParameterDecl; +begin + Result := TPSParameterDecl.Create; + FParams.Add(Result); +end; + +procedure TPSParametersDecl.DeleteParam(I: Longint); +var + param: TPSParameterDecl; +begin + param := FParams[i]; + FParams.Delete(i); + Param.Free; +end; + +constructor TPSParametersDecl.Create; +begin + inherited Create; + FParams := TPSList.Create; +end; + +destructor TPSParametersDecl.Destroy; +var + i: Longint; +begin + for i := FParams.Count -1 downto 0 do + begin + TPSParameterDecl(Fparams[i]).Free; + end; + FParams.Free; + inherited Destroy; +end; + +function TPSParametersDecl.Same(d: TPSParametersDecl): boolean; +var + i: Longint; +begin + if (d = nil) or (d.ParamCount <> ParamCount) or (d.Result <> Self.Result) then + Result := False + else begin + for i := 0 to d.ParamCount -1 do + begin + if (d.Params[i].Mode <> Params[i].Mode) or (d.Params[i].aType <> Params[i].aType) then + begin + Result := False; + exit; + end; + end; + Result := True; + end; +end; + +{ TPSProceduralType } + +constructor TPSProceduralType.Create; +begin + inherited Create; + FProcDef := TPSParametersDecl.Create; + +end; + +destructor TPSProceduralType.Destroy; +begin + FProcDef.Free; + inherited Destroy; +end; + +{ TPSDelphiClassItem } + +procedure TPSDelphiClassItem.SetName(const s: tbtString); +begin + FOrgName := s; + FName := FastUpperCase(s); + FNameHash := MakeHash(FName); +end; + +constructor TPSDelphiClassItem.Create(Owner: TPSCompileTimeClass); +begin + inherited Create; + FOwner := Owner; + FDecl := TPSParametersDecl.Create; +end; + +destructor TPSDelphiClassItem.Destroy; +begin + FDecl.Free; + inherited Destroy; +end; + +{$IFNDEF PS_NOINTERFACES} +{ TPSInterface } + +function TPSInterface.CastToType(IntoType: TPSType; + var ProcNo: Cardinal): Boolean; +var + P: TPSExternalProcedure; +begin + if (IntoType <> nil) and (IntoType.BaseType <> btInterface) then + begin + Result := False; + exit; + end; + if FCastProc <> InvalidVal then + begin + ProcNo := FCastProc; + Result := True; + exit; + end; + ProcNo := FOwner.AddUsedFunction2(P); + P.RegProc := FOwner.AddFunction(ProcHDR); + P.RegProc.Name := ''; + with P.RegProc.Decl.AddParam do + begin + OrgName := 'Org'; + aType := Self.FType; + end; + with P.RegProc.Decl.AddParam do + begin + OrgName := 'TypeNo'; + aType := FOwner.at2ut(FOwner.FindBaseType(btU32)); + end; + P.RegProc.Decl.Result := FOwner.at2ut(IntoType); + + P.RegProc.ImportDecl := 'class:+'; + FCastProc := ProcNo; + Result := True; +end; + +constructor TPSInterface.Create(Owner: TPSPascalCompiler; InheritedFrom: TPSInterface; Guid: TGuid; const Name: tbtString; aType: TPSType); +begin + inherited Create; + FCastProc := InvalidVal; + FNilProc := InvalidVal; + + FType := aType; + FOWner := Owner; + FGuid := GUID; + Self.InheritedFrom := InheritedFrom; + + FItems := TPSList.Create; + FName := Name; + FNameHash := MakeHash(Name); +end; + +procedure TPSInterface.SetInheritedFrom(p: TPSInterface); +begin + FInheritedFrom := p; +end; + +destructor TPSInterface.Destroy; +var + i: Longint; +begin + for i := FItems.Count -1 downto 0 do + begin + TPSInterfaceMethod(FItems[i]).Free; + end; + FItems.Free; + inherited Destroy; +end; + +function TPSInterface.Func_Call(Index: Cardinal; + var ProcNo: Cardinal): Boolean; +var + c: TPSInterfaceMethod; + P: TPSExternalProcedure; + s: tbtString; + i: Longint; +begin + c := TPSInterfaceMethod(Index); + if c.FScriptProcNo <> InvalidVal then + begin + Procno := c.FScriptProcNo; + Result := True; + exit; + end; + ProcNo := FOwner.AddUsedFunction2(P); + P.RegProc := FOwner.AddFunction(ProcHDR); + P.RegProc.Name := ''; + FOwner.UseProc(C.Decl); + P.RegProc.Decl.Assign(c.Decl); + s := tbtstring('intf:.') + PS_mi2s(c.AbsoluteProcOffset) + tbtchar(ord(c.CC)); + if c.Decl.Result = nil then + s := s + #0 + else + s := s + #1; + for i := 0 to C.Decl.ParamCount -1 do + begin + if c.Decl.Params[i].Mode <> pmIn then + s := s + #1 + else + s := s + #0; + end; + P.RegProc.ImportDecl := s; + C.FScriptProcNo := ProcNo; + Result := True; +end; + +function TPSInterface.Func_Find(const Name: tbtString; + var Index: Cardinal): Boolean; +var + H: Longint; + I: Longint; + CurrClass: TPSInterface; + C: TPSInterfaceMethod; +begin + H := MakeHash(Name); + CurrClass := Self; + while CurrClass <> nil do + begin + for i := CurrClass.FItems.Count -1 downto 0 do + begin + C := CurrClass.FItems[I]; + if (C.NameHash = H) and (C.Name = Name) then + begin + Index := Cardinal(c); + Result := True; + exit; + end; + end; + CurrClass := CurrClass.FInheritedFrom; + end; + Result := False; +end; + +function TPSInterface.IsCompatibleWith(aType: TPSType): Boolean; +var + Temp: TPSInterface; +begin + if (atype.BaseType = btClass) then // just support it, we'll see what happens + begin + Result := true; + exit; + end; + if atype.BaseType <> btInterface then + begin + Result := False; + exit; + end; + temp := TPSInterfaceType(atype).FIntf; + while Temp <> nil do + begin + if Temp = Self then + begin + Result := True; + exit; + end; + Temp := Temp.FInheritedFrom; + end; + Result := False; +end; + +procedure TPSInterface.RegisterDummyMethod; +begin + FItems.Add(TPSInterfaceMethod.Create(self)); +end; + +function TPSInterface.RegisterMethod(const Declaration: tbtString; + const cc: TPSCallingConvention): Boolean; +var + M: TPSInterfaceMethod; + DOrgName: tbtString; + Func: TPMFuncType; +begin + M := TPSInterfaceMethod.Create(Self); + if not ParseMethod(FOwner, '', Declaration, DOrgname, m.Decl, Func) then + begin + FItems.Add(m); // in any case, add a dummy item + Result := False; + exit; + end; + m.FName := FastUppercase(DOrgName); + m.FOrgName := DOrgName; + m.FNameHash := MakeHash(m.FName); + m.FCC := CC; + m.FScriptProcNo := InvalidVal; + FItems.Add(M); + Result := True; +end; + + +function TPSInterface.SetNil(var ProcNo: Cardinal): Boolean; +var + P: TPSExternalProcedure; + +begin + if FNilProc <> InvalidVal then + begin + Procno := FNilProc; + Result := True; + exit; + end; + ProcNo := FOwner.AddUsedFunction2(P); + P.RegProc := FOwner.AddFunction(ProcHDR); + P.RegProc.Name := ''; + with p.RegProc.Decl.AddParam do + begin + Mode := pmInOut; + OrgName := 'VarNo'; + aType := FOwner.at2ut(Self.FType); + end; + P.RegProc.ImportDecl := 'class:-'; + FNilProc := Procno; + Result := True; +end; + +{ TPSInterfaceMethod } + +constructor TPSInterfaceMethod.Create(Owner: TPSInterface); +begin + inherited Create; + FDecl := TPSParametersDecl.Create; + FOwner := Owner; + FOffsetCache := InvalidVal; +end; + +function TPSInterfaceMethod.GetAbsoluteProcOffset: Cardinal; +var + ps: TPSInterface; +begin + if FOffsetCache = InvalidVal then + begin + FOffsetCache := FOwner.FItems.IndexOf(Self); + ps := FOwner.FInheritedFrom; + while ps <> nil do + begin + FOffsetCache := FOffsetCache + ps.FItems.Count; + ps := ps.FInheritedFrom; + end; + end; + result := FOffsetCache; +end; + + +destructor TPSInterfaceMethod.Destroy; +begin + FDecl.Free; + inherited Destroy; +end; +{$ENDIF} + +{ TPSVariantType } + +function TPSVariantType.GetDynInvokeParamType(Owner: TPSPascalCompiler) : TPSType; +begin + Result := Owner.at2ut(FindAndAddType(owner, '!OPENARRAYOFVARIANT', 'array of variant')); +end; + +function TPSVariantType.GetDynInvokeProcNo(Owner: TPSPascalCompiler; const Name: tbtString; + Params: TPSParameters): Cardinal; +begin + Result := Owner.FindProc('IDISPATCHINVOKE'); +end; + +function TPSVariantType.GetDynIvokeResulType( + Owner: TPSPascalCompiler): TPSType; +begin + Result := Owner.FindType('VARIANT'); +end; + +function TPSVariantType.GetDynIvokeSelfType(Owner: TPSPascalCompiler): TPSType; +begin + Result := Owner.at2ut(Owner.FindType('IDISPATCH')); +end; + + +{ TPSExternalClass } +function TPSExternalClass.SetNil(var ProcNo: Cardinal): Boolean; +begin + Result := False; +end; + +constructor TPSExternalClass.Create(Se: TIFPSPascalCompiler; TypeNo: TPSType); +begin + inherited Create; + Self.SE := se; + Self.FTypeNo := TypeNo; +end; + +function TPSExternalClass.Func_Call(Index: Cardinal; + var ProcNo: Cardinal): Boolean; +begin + Result := False; +end; + +function TPSExternalClass.Func_Find(const Name: tbtString; + var Index: Cardinal): Boolean; +begin + Result := False; +end; + +function TPSExternalClass.IsCompatibleWith( + Cl: TPSExternalClass): Boolean; +begin + Result := False; +end; + +function TPSExternalClass.SelfType: TPSType; +begin + Result := nil; +end; + +function TPSExternalClass.CastToType(IntoType: TPSType; + var ProcNo: Cardinal): Boolean; +begin + Result := False; +end; + +function TPSExternalClass.CompareClass(OtherTypeNo: TPSType; + var ProcNo: Cardinal): Boolean; +begin + Result := false; +end; + +function TPSExternalClass.ClassFunc_Find(const Name: tbtString; var Index: Cardinal): Boolean; +begin + result := false; +end; + +function TPSExternalClass.ClassFunc_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; +begin + result := false; +end; + + +{ TPSValueProcVal } + +destructor TPSValueProcVal.Destroy; +begin + FProcNo.Free; + inherited; +end; + + +{ + +Internal error counter: 00020 (increase and then use) + +} +end. diff --git a/Units/PascalScript/uPSComponent.pas b/Units/PascalScript/uPSComponent.pas new file mode 100644 index 0000000..fbb608e --- /dev/null +++ b/Units/PascalScript/uPSComponent.pas @@ -0,0 +1,1511 @@ +unit uPSComponent; +{$I PascalScript.inc} +interface + +uses + SysUtils, Classes, uPSRuntime, uPSDebugger, uPSUtils, + uPSCompiler, uPSC_dll, uPSR_dll, uPSPreProcessor; + +const + {alias to @link(ifps3.cdRegister)} + cdRegister = uPSRuntime.cdRegister; + {alias to @link(ifps3.cdPascal)} + cdPascal = uPSRuntime.cdPascal; + + CdCdecl = uPSRuntime.CdCdecl; + + CdStdCall = uPSRuntime.CdStdCall; + +type + TPSScript = class; + + TDelphiCallingConvention = uPSRuntime.TPSCallingConvention; + {Alias to @link(ifps3.TPSRuntimeClassImporter)} + TPSRuntimeClassImporter = uPSRuntime.TPSRuntimeClassImporter; + + TPSPlugin = class(TComponent) + public + procedure CompOnUses(CompExec: TPSScript); virtual; + + procedure ExecOnUses(CompExec: TPSScript); virtual; + + procedure CompileImport1(CompExec: TPSScript); virtual; + + procedure CompileImport2(CompExec: TPSScript); virtual; + + procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); virtual; + + procedure ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); virtual; + end; + + TIFPS3Plugin = class(TPSPlugin); + + TPSDllPlugin = class(TPSPlugin) + public + procedure CompOnUses(CompExec: TPSScript); override; + procedure ExecOnUses(CompExec: TPSScript); override; + end; + + TIFPS3DllPlugin = class(TPSDllPlugin); + + + TPSPluginItem = class(TCollectionItem) + private + FPlugin: TPSPlugin; + procedure SetPlugin(const Value: TPSPlugin); + protected + function GetDisplayName: string; override; + public + procedure Assign(Source: TPersistent); override; //Birb + published + property Plugin: TPSPlugin read FPlugin write SetPlugin; + end; + + + TIFPS3CEPluginItem = class(TPSPluginItem); + + + TPSPlugins = class(TCollection) + private + FCompExec: TPSScript; + protected + + function GetOwner: TPersistent; override; + public + + constructor Create(CE: TPSScript); + end; + + TIFPS3CEPlugins = class(TPSPlugins); + + + TPSOnGetNotVariant = function (Sender: TPSScript; const Name: tbtstring): Variant of object; + TPSOnSetNotVariant = procedure (Sender: TPSScript; const Name: tbtstring; V: Variant) of object; + TPSCompOptions = set of (icAllowNoBegin, icAllowUnit, icAllowNoEnd, icBooleanShortCircuit); + + TPSVerifyProc = procedure (Sender: TPSScript; Proc: TPSInternalProcedure; const Decl: tbtstring; var Error: Boolean) of object; + + TPSEvent = procedure (Sender: TPSScript) of object; + + TPSOnCompImport = procedure (Sender: TObject; x: TPSPascalCompiler) of object; + + TPSOnExecImport = procedure (Sender: TObject; se: TPSExec; x: TPSRuntimeClassImporter) of object; + {Script engine event function} + TPSOnNeedFile = function (Sender: TObject; const OrginFileName: tbtstring; var FileName, Output: tbtstring): Boolean of object; + + TPSOnProcessDirective = procedure ( + Sender: TPSPreProcessor; + Parser: TPSPascalPreProcessorParser; + const Active: Boolean; + const DirectiveName, DirectiveParam: tbtstring; + Var Continue: Boolean) of Object; // jgv + + TPSScript = class(TComponent) + private + FOnGetNotificationVariant: TPSOnGetNotVariant; + FOnSetNotificationVariant: TPSOnSetNotVariant; + FCanAdd: Boolean; + FComp: TPSPascalCompiler; + FCompOptions: TPSCompOptions; + FExec: TPSDebugExec; + FSuppressLoadData: Boolean; + FScript: TStrings; + FOnLine: TNotifyEvent; + FUseDebugInfo: Boolean; + FOnAfterExecute, FOnCompile, FOnExecute: TPSEvent; + FOnCompImport: TPSOnCompImport; + FOnExecImport: TPSOnExecImport; + RI: TPSRuntimeClassImporter; + FPlugins: TPSPlugins; + FPP: TPSPreProcessor; + FMainFileName: tbtstring; + FOnNeedFile: TPSOnNeedFile; + FUsePreProcessor: Boolean; + FDefines: TStrings; + FOnVerifyProc: TPSVerifyProc; + FOnProcessDirective: TPSOnProcessDirective; + FOnProcessUnknowDirective: TPSOnProcessDirective; + FOnFindUnknownFile: TPSOnNeedFile; + function GetRunning: Boolean; + procedure SetScript(const Value: TStrings); + function GetCompMsg(i: Integer): TPSPascalCompilerMessage; + function GetCompMsgCount: Longint; + function GetAbout: tbtstring; + function ScriptUses(Sender: TPSPascalCompiler; const Name: tbtstring): Boolean; + function GetExecErrorByteCodePosition: Cardinal; + function GetExecErrorCode: TIFError; + function GetExecErrorParam: tbtstring; + function GetExecErrorProcNo: Cardinal; + function GetExecErrorString: tbtstring; + function GetExecErrorPosition: Cardinal; + function GetExecErrorCol: Cardinal; + function GetExecErrorRow: Cardinal; + function GetExecErrorFileName: tbtstring; + procedure SetDefines(const Value: TStrings); + protected + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + + protected + //jgv move where private before - not very usefull + procedure OnLineEvent; virtual; + procedure SetMainFileName(const Value: tbtstring); virtual; + + //--jgv new + function DoOnNeedFile (Sender: TObject; const OrginFileName: tbtstring; var FileName, Output: tbtstring): Boolean; virtual; + function DoOnUnknowUses (Sender: TPSPascalCompiler; const Name: tbtstring): Boolean; virtual; // return true if processed + procedure DoOnCompImport; virtual; + procedure DoOnCompile; virtual; + function DoVerifyProc (Sender: TPSScript; Proc: TPSInternalProcedure; const Decl: tbtstring): Boolean; virtual; + + procedure DoOnExecImport (RunTimeImporter: TPSRuntimeClassImporter); virtual; + procedure DoOnExecute (RunTimeImporter: TPSRuntimeClassImporter); virtual; + procedure DoAfterExecute; virtual; + function DoOnGetNotificationVariant (const Name: tbtstring): Variant; virtual; + procedure DoOnSetNotificationVariant (const Name: tbtstring; V: Variant); virtual; + + procedure DoOnProcessDirective (Sender: TPSPreProcessor; + Parser: TPSPascalPreProcessorParser; + const Active: Boolean; + const DirectiveName, DirectiveParam: tbtstring; + Var Continue: Boolean); virtual; + procedure DoOnProcessUnknowDirective (Sender: TPSPreProcessor; + Parser: TPSPascalPreProcessorParser; + const Active: Boolean; + const DirectiveName, DirectiveParam: tbtstring; + Var Continue: Boolean); virtual; + public + property RuntimeImporter: TPSRuntimeClassImporter read RI; + + function FindNamedType(const Name: tbtstring): TPSTypeRec; + + function FindBaseType(Bt: TPSBaseType): TPSTypeRec; + + property SuppressLoadData: Boolean read FSuppressLoadData write FSuppressLoadData; + + function LoadExec: Boolean; + + procedure Stop; virtual; + + constructor Create(AOwner: TComponent); override; + + destructor Destroy; override; + + function Compile: Boolean; virtual; + + function Execute: Boolean; virtual; + + property Running: Boolean read GetRunning; + + procedure GetCompiled(var data: tbtstring); + + procedure SetCompiled(const Data: tbtstring); + + property Comp: TPSPascalCompiler read FComp; + + property Exec: TPSDebugExec read FExec; + + property CompilerMessageCount: Longint read GetCompMsgCount; + + property CompilerMessages[i: Longint]: TPSPascalCompilerMessage read GetCompMsg; + + function CompilerErrorToStr(I: Longint): tbtstring; + + property ExecErrorCode: TIFError read GetExecErrorCode; + + property ExecErrorParam: tbtstring read GetExecErrorParam; + + property ExecErrorToString: tbtstring read GetExecErrorString; + + property ExecErrorProcNo: Cardinal read GetExecErrorProcNo; + + property ExecErrorByteCodePosition: Cardinal read GetExecErrorByteCodePosition; + + property ExecErrorPosition: Cardinal read GetExecErrorPosition; + + property ExecErrorRow: Cardinal read GetExecErrorRow; + + property ExecErrorCol: Cardinal read GetExecErrorCol; + + property ExecErrorFileName: tbtstring read GetExecErrorFileName; + + function AddFunctionEx(Ptr: Pointer; const Decl: tbtstring; CallingConv: TDelphiCallingConvention): Boolean; + + function AddFunction(Ptr: Pointer; const Decl: tbtstring): Boolean; + + + function AddMethodEx(Slf, Ptr: Pointer; const Decl: tbtstring; CallingConv: TDelphiCallingConvention): Boolean; + + function AddMethod(Slf, Ptr: Pointer; const Decl: tbtstring): Boolean; + + function AddRegisteredVariable(const VarName, VarType: tbtstring): Boolean; + function AddNotificationVariant(const VarName: tbtstring): Boolean; + + function AddRegisteredPTRVariable(const VarName, VarType: tbtstring): Boolean; + + function GetVariable(const Name: tbtstring): PIFVariant; + + function SetVarToInstance(const VarName: tbtstring; cl: TObject): Boolean; + + procedure SetPointerToData(const VarName: tbtstring; Data: Pointer; aType: TIFTypeRec); + + function TranslatePositionPos(Proc, Position: Cardinal; var Pos: Cardinal; var fn: tbtstring): Boolean; + + function TranslatePositionRC(Proc, Position: Cardinal; var Row, Col: Cardinal; var fn: tbtstring): Boolean; + + function GetProcMethod(const ProcName: tbtstring): TMethod; + + function ExecuteFunction(const Params: array of Variant; const ProcName: tbtstring): Variant; + published + + property About: tbtstring read GetAbout stored false; + + property Script: TStrings read FScript write SetScript; + + property CompilerOptions: TPSCompOptions read FCompOptions write FCompOptions; + + property OnLine: TNotifyEvent read FOnLine write FOnLine; + + property OnCompile: TPSEvent read FOnCompile write FOnCompile; + + property OnExecute: TPSEvent read FOnExecute write FOnExecute; + + property OnAfterExecute: TPSEvent read FOnAfterExecute write FOnAfterExecute; + + property OnCompImport: TPSOnCompImport read FOnCompImport write FOnCompImport; + + property OnExecImport: TPSOnExecImport read FOnExecImport write FOnExecImport; + + property UseDebugInfo: Boolean read FUseDebugInfo write FUseDebugInfo default True; + + property Plugins: TPSPlugins read FPlugins write FPlugins; + + property MainFileName: tbtstring read FMainFileName write SetMainFileName; + + property UsePreProcessor: Boolean read FUsePreProcessor write FUsePreProcessor; + + property OnNeedFile: TPSOnNeedFile read FOnNeedFile write FOnNeedFile; + + property Defines: TStrings read FDefines write SetDefines; + + property OnVerifyProc: TPSVerifyProc read FOnVerifyProc write FOnVerifyProc; + property OnGetNotificationVariant: TPSOnGetNotVariant read FOnGetNotificationVariant write FOnGetNotificationVariant; + property OnSetNotificationVariant: TPSOnSetNotVariant read FOnSetNotificationVariant write FOnSetNotificationVariant; + property OnFindUnknownFile: TPSOnNeedFile read FOnFindUnknownFile write FOnFindUnknownFile; + + published + //-- jgv + property OnProcessDirective: TPSOnProcessDirective read FOnProcessDirective write FOnProcessDirective; + property OnProcessUnknowDirective: TPSOnProcessDirective read FOnProcessUnknowDirective write FOnProcessUnknowDirective; + end; + + TIFPS3CompExec = class(TPSScript); + + + TPSBreakPointInfo = class + private + FLine: Longint; + FFileNameHash: Longint; + FFileName: tbtstring; + procedure SetFileName(const Value: tbtstring); + public + + property FileName: tbtstring read FFileName write SetFileName; + + property FileNameHash: Longint read FFileNameHash; + + property Line: Longint read FLine write FLine; + end; + + TPSOnLineInfo = procedure (Sender: TObject; const FileName: tbtstring; Position, Row, Col: Cardinal) of object; + + TPSScriptDebugger = class(TPSScript) + private + FOnIdle: TNotifyEvent; + FBreakPoints: TIFList; + FOnLineInfo: TPSOnLineInfo; + FLastRow: Cardinal; + FOnBreakpoint: TPSOnLineInfo; + function GetBreakPoint(I: Integer): TPSBreakPointInfo; + function GetBreakPointCount: Longint; + protected + procedure SetMainFileName(const Value: tbtstring); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + + procedure Pause; virtual; + + procedure Resume; virtual; + + + procedure StepInto; virtual; + + procedure StepOver; virtual; + + procedure SetBreakPoint(const Fn: tbtstring; Line: Longint); + + procedure ClearBreakPoint(const Fn: tbtstring; Line: Longint); + + property BreakPointCount: Longint read GetBreakPointCount; + + property BreakPoint[I: Longint]: TPSBreakPointInfo read GetBreakPoint; + + function HasBreakPoint(const Fn: tbtstring; Line: Longint): Boolean; + + procedure ClearBreakPoints; + + function GetVarContents(const Name: tbtstring): tbtstring; + published + + property OnIdle: TNotifyEvent read FOnIdle write FOnIdle; + + property OnLineInfo: TPSOnLineInfo read FOnLineInfo write FOnLineInfo; + + property OnBreakpoint: TPSOnLineInfo read FOnBreakpoint write FOnBreakpoint; + end; + + TIFPS3DebugCompExec = class(TPSScriptDebugger); + + TPSCustumPlugin = class(TPSPlugin) + private + FOnCompileImport2: TPSEvent; + FOnExecOnUses: TPSEvent; + FOnCompOnUses: TPSEvent; + FOnCompileImport1: TPSEvent; + FOnExecImport1: TPSOnExecImport; + FOnExecImport2: TPSOnExecImport; + public + procedure CompOnUses(CompExec: TPSScript); override; + procedure ExecOnUses(CompExec: TPSScript); override; + procedure CompileImport1(CompExec: TPSScript); override; + procedure CompileImport2(CompExec: TPSScript); override; + procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override; + + procedure ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override; + public + published + property OnCompOnUses : TPSEvent read FOnCompOnUses write FOnCompOnUses; + property OnExecOnUses: TPSEvent read FOnExecOnUses write FOnExecOnUses; + property OnCompileImport1: TPSEvent read FOnCompileImport1 write FOnCompileImport1; + property OnCompileImport2: TPSEvent read FOnCompileImport2 write FOnCompileImport2; + property OnExecImport1: TPSOnExecImport read FOnExecImport1 write FOnExecImport1; + property OnExecImport2: TPSOnExecImport read FOnExecImport2 write FOnExecImport2; + end; + +implementation + + +{$IFDEF DELPHI3UP } +resourceString +{$ELSE } +const +{$ENDIF } + + RPS_UnableToReadVariant = 'Unable to read variant'; + RPS_UnableToWriteVariant = 'Unable to write variant'; + RPS_ScripEngineAlreadyRunning = 'Script engine already running'; + RPS_ScriptNotCompiled = 'Script is not compiled'; + RPS_NotRunning = 'Not running'; + RPS_UnableToFindVariable = 'Unable to find variable'; + RPS_UnknownIdentifier = 'Unknown Identifier'; + RPS_NoScript = 'No script'; + +function MyGetVariant(Sender: TPSExec; const Name: tbtstring): Variant; +begin + Result := TPSScript (Sender.Id).DoOnGetNotificationVariant(Name); +end; + +procedure MySetVariant(Sender: TPSExec; const Name: tbtstring; V: Variant); +begin + TPSScript (Sender.Id).DoOnSetNotificationVariant(Name, V); +end; + +function CompScriptUses(Sender: TPSPascalCompiler; const Name: tbtstring): Boolean; +begin + Result := TPSScript(Sender.ID).ScriptUses(Sender, Name); +end; + +procedure ExecOnLine(Sender: TPSExec); +begin + if assigned(TPSScript(Sender.ID).FOnLine) then + begin + TPSScript(Sender.ID).OnLineEvent; + end; +end; + +function CompExportCheck(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure; const ProcDecl: tbtstring): Boolean; +begin + Result := TPSScript(Sender.ID).DoVerifyProc (Sender.ID, Proc, ProcDecl); +end; + + +procedure callObjectOnProcessDirective ( + Sender: TPSPreProcessor; + Parser: TPSPascalPreProcessorParser; + const Active: Boolean; + const DirectiveName, DirectiveParam: tbtstring; + Var Continue: Boolean); +begin + TPSScript (Sender.ID).DoOnProcessUnknowDirective(Sender, Parser, Active, DirectiveName, DirectiveParam, Continue); +end; + +procedure callObjectOnProcessUnknowDirective ( + Sender: TPSPreProcessor; + Parser: TPSPascalPreProcessorParser; + const Active: Boolean; + const DirectiveName, DirectiveParam: tbtstring; + Var Continue: Boolean); +begin + TPSScript (Sender.ID).DoOnProcessDirective(Sender, Parser, Active, DirectiveName, DirectiveParam, Continue); +end; + + +{ TPSPlugin } +procedure TPSPlugin.CompileImport1(CompExec: TPSScript); +begin + // do nothing +end; + +procedure TPSPlugin.CompileImport2(CompExec: TPSScript); +begin + // do nothing +end; + +procedure TPSPlugin.CompOnUses(CompExec: TPSScript); +begin + // do nothing +end; + +procedure TPSPlugin.ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); +begin + // do nothing +end; + +procedure TPSPlugin.ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); +begin + // do nothing +end; + +procedure TPSPlugin.ExecOnUses(CompExec: TPSScript); +begin + // do nothing +end; + + +{ TPSScript } + +function TPSScript.AddFunction(Ptr: Pointer; + const Decl: tbtstring): Boolean; +begin + Result := AddFunctionEx(Ptr, Decl, cdRegister); +end; + +function TPSScript.AddFunctionEx(Ptr: Pointer; const Decl: tbtstring; + CallingConv: TDelphiCallingConvention): Boolean; +var + P: TPSRegProc; +begin + if not FCanAdd then begin Result := False; exit; end; + p := Comp.AddDelphiFunction(Decl); + if p <> nil then + begin + Exec.RegisterDelphiFunction(Ptr, p.Name, CallingConv); + Result := True; + end else Result := False; +end; + +function TPSScript.AddRegisteredVariable(const VarName, + VarType: tbtstring): Boolean; +var + FVar: TPSVar; +begin + if not FCanAdd then begin Result := False; exit; end; + FVar := FComp.AddUsedVariableN(varname, vartype); + if fvar = nil then + result := False + else begin + fvar.exportname := fvar.Name; + Result := True; + end; +end; + +function CENeedFile(Sender: TPSPreProcessor; const callingfilename: tbtstring; var FileName, Output: tbtstring): Boolean; +begin + Result := TPSScript (Sender.ID).DoOnNeedFile(Sender.ID, CallingFileName, FileName, Output); +end; + +procedure CompTranslateLineInfo(Sender: TPSPascalCompiler; var Pos, Row, Col: Cardinal; var Name: tbtstring); +var + res: TPSLineInfoResults; +begin + if TPSScript(Sender.ID).FPP.CurrentLineInfo.GetLineInfo(Name, Pos, Res) then + begin + Pos := Res.Pos; + Row := Res.Row; + Col := Res.Col; + Name := Res.Name; + end; +end; + +function TPSScript.Compile: Boolean; +var + i: Longint; + dta: tbtstring; +begin + FExec.Clear; + FExec.CMD_Err(erNoError); + FExec.ClearspecialProcImports; + FExec.ClearFunctionList; + if ri <> nil then + begin + RI.Free; + RI := nil; + end; + RI := TPSRuntimeClassImporter.Create; + for i := 0 to FPlugins.Count -1 do + begin + if (TPSPluginItem(FPlugins.Items[i]) <> nil) and (TPSPluginItem(FPlugins.Items[i]).Plugin <> nil) then + TPSPluginItem(FPlugins.Items[i]).Plugin.ExecImport1(Self, ri); + end; + + DoOnExecImport (RI); + + for i := 0 to FPlugins.Count -1 do + begin + if (TPSPluginItem(FPlugins.Items[i]) <> nil)and (TPSPluginItem(FPlugins.Items[i]).Plugin <> nil) then + TPSPluginItem(FPlugins.Items[i]).Plugin.ExecImport2(Self, ri); + end; + RegisterClassLibraryRuntime(Exec, RI); + for i := 0 to FPlugins.Count -1 do + begin + if (TPSPluginItem(FPlugins.Items[i]) <> nil)and (TPSPluginItem(FPlugins.Items[i]).Plugin <> nil) then + TPSPluginItem(FPlugins.Items[i]).Plugin.ExecOnUses(Self); + end; + FCanAdd := True; + FComp.BooleanShortCircuit := icBooleanShortCircuit in FCompOptions; + FComp.AllowNoBegin := icAllowNoBegin in FCompOptions; + FComp.AllowUnit := icAllowUnit in FCompOptions; + FComp.AllowNoEnd := icAllowNoEnd in FCompOptions; + if FUsePreProcessor then + begin + FPP.Clear; + FPP.Defines.Assign(FDefines); + FComp.OnTranslateLineInfo := CompTranslateLineInfo; + Fpp.OnProcessDirective := callObjectOnProcessDirective; + Fpp.OnProcessUnknowDirective := callObjectOnProcessUnknowDirective; + Fpp.MainFile := FScript.Text; + Fpp.MainFileName := FMainFileName; + Fpp.PreProcess(FMainFileName, dta); + if FComp.Compile(dta) then + begin + FCanAdd := False; + if (not SuppressLoadData) and (not LoadExec) then + begin + Result := False; + end else + Result := True; + end else Result := False; + Fpp.AdjustMessages(Comp); + end else + begin + FComp.OnTranslateLineInfo := nil; + if FComp.Compile(FScript.Text) then + begin + FCanAdd := False; + if not LoadExec then + begin + Result := False; + end else + Result := True; + end else Result := False; + end; +end; + +function TPSScript.CompilerErrorToStr(I: Integer): tbtstring; +begin + Result := CompilerMessages[i].MessageToString; +end; + +constructor TPSScript.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FComp := TPSPascalCompiler.Create; + FExec := TPSDebugExec.Create; + FScript := TStringList.Create; + FPlugins := TPSPlugins.Create(self); + + FComp.ID := Self; + FComp.OnUses := CompScriptUses; + FComp.OnExportCheck := CompExportCheck; + FExec.Id := Self; + FExec.OnRunLine:= ExecOnLine; + FExec.OnGetNVariant := MyGetVariant; + FExec.OnSetNVariant := MySetVariant; + + FUseDebugInfo := True; + + FPP := TPSPreProcessor.Create; + FPP.Id := Self; + FPP.OnNeedFile := CENeedFile; + + FDefines := TStringList.Create; +end; + +destructor TPSScript.Destroy; +begin + FDefines.Free; + + FPP.Free; + RI.Free; + FPlugins.Free; + FPlugins := nil; + FScript.Free; + FExec.Free; + FComp.Free; + inherited Destroy; +end; + +function TPSScript.Execute: Boolean; +begin + if Running then raise Exception.Create(RPS_ScripEngineAlreadyRunning); + if SuppressLoadData then + LoadExec; + + DoOnExecute (RI); + + FExec.DebugEnabled := FUseDebugInfo; + Result := FExec.RunScript and (FExec.ExceptionCode = erNoError) ; + + DoAfterExecute; +end; + +function TPSScript.GetAbout: tbtstring; +begin + Result := TPSExec.About; +end; + +procedure TPSScript.GetCompiled(var data: tbtstring); +begin + if not FComp.GetOutput(Data) then + raise Exception.Create(RPS_ScriptNotCompiled); +end; + +function TPSScript.GetCompMsg(i: Integer): TPSPascalCompilerMessage; +begin + Result := FComp.Msg[i]; +end; + +function TPSScript.GetCompMsgCount: Longint; +begin + Result := FComp.MsgCount; +end; + +function TPSScript.GetExecErrorByteCodePosition: Cardinal; +begin + Result := Exec.ExceptionPos; +end; + +function TPSScript.GetExecErrorCode: TIFError; +begin + Result := Exec.ExceptionCode; +end; + +function TPSScript.GetExecErrorParam: tbtstring; +begin + Result := Exec.ExceptionString; +end; + +function TPSScript.GetExecErrorPosition: Cardinal; +begin + Result := FExec.TranslatePosition(Exec.ExceptionProcNo, Exec.ExceptionPos); +end; + +function TPSScript.GetExecErrorProcNo: Cardinal; +begin + Result := Exec.ExceptionProcNo; +end; + +function TPSScript.GetExecErrorString: tbtstring; +begin + Result := TIFErrorToString(Exec.ExceptionCode, Exec.ExceptionString); +end; + +function TPSScript.GetVariable(const Name: tbtstring): PIFVariant; +begin + Result := FExec.GetVar2(name); +end; + +function TPSScript.LoadExec: Boolean; +var + s: tbtstring; +begin + if (not FComp.GetOutput(s)) or (not FExec.LoadData(s)) then + begin + Result := False; + exit; + end; + if FUseDebugInfo then + begin + FComp.GetDebugOutput(s); + FExec.LoadDebugData(s); + end; + Result := True; +end; + +function TPSScript.ScriptUses(Sender: TPSPascalCompiler; + const Name: tbtstring): Boolean; +var + i: Longint; +begin + if Name = 'SYSTEM' then + begin + for i := 0 to FPlugins.Count -1 do + begin + if (TPSPluginItem(FPlugins.Items[i]) <> nil)and (TPSPluginItem(FPlugins.Items[i]).Plugin <> nil) then + TPSPluginItem(FPlugins.Items[i]).Plugin.CompOnUses(Self); + end; + for i := 0 to FPlugins.Count -1 do + begin + if (TPSPluginItem(FPlugins.Items[i]) <> nil)and (TPSPluginItem(FPlugins.Items[i]).Plugin <> nil) then + TPSPluginItem(FPlugins.Items[i]).Plugin.CompileImport1(self); + end; + + DoOnCompImport; + + for i := 0 to FPlugins.Count -1 do + begin + if (TPSPluginItem(FPlugins.Items[i]) <> nil)and (TPSPluginItem(FPlugins.Items[i]).Plugin <> nil) then + TPSPluginItem(FPlugins.Items[i]).Plugin.CompileImport2(Self); + end; + + DoOnCompile; + + Result := true; + for i := 0 to Sender.MsgCount -1 do begin + if Sender.Msg[i] is TPSPascalCompilerError then Result := false; + end; + end + else begin + Result := DoOnUnknowUses (Sender, Name); +{ If Not Result then + Sender.MakeError('', ecUnknownIdentifier, Name);} + end; +end; + +procedure TPSScript.SetCompiled(const Data: tbtstring); +var + i: Integer; +begin + FExec.Clear; + FExec.ClearspecialProcImports; + FExec.ClearFunctionList; + if ri <> nil then + begin + RI.Free; + RI := nil; + end; + RI := TPSRuntimeClassImporter.Create; + for i := 0 to FPlugins.Count -1 do + begin + if (TPSPluginItem(FPlugins.Items[i]) <> nil)and (TPSPluginItem(FPlugins.Items[i]).Plugin <> nil) then + TPSPluginItem(FPlugins.Items[i]).Plugin.ExecImport1(Self, ri); + end; + + DoOnExecImport(RI); + + for i := 0 to FPlugins.Count -1 do + begin + if (TPSPluginItem(FPlugins.Items[i]) <> nil)and (TPSPluginItem(FPlugins.Items[i]).Plugin <> nil) then + TPSPluginItem(FPlugins.Items[i]).Plugin.ExecImport2(Self, ri); + end; + RegisterClassLibraryRuntime(Exec, RI); + for i := 0 to FPlugins.Count -1 do + begin + if (TPSPluginItem(FPlugins.Items[i]) <> nil)and (TPSPluginItem(FPlugins.Items[i]).Plugin <> nil) then + TPSPluginItem(FPlugins.Items[i]).Plugin.ExecOnUses(Self); + end; + if not FExec.LoadData(Data) then + raise Exception.Create(GetExecErrorString); +end; + +function TPSScript.SetVarToInstance(const VarName: tbtstring; cl: TObject): Boolean; +var + p: PIFVariant; +begin + p := GetVariable(VarName); + if p <> nil then + begin + SetVariantToClass(p, cl); + result := true; + end else result := false; +end; + +procedure TPSScript.SetScript(const Value: TStrings); +begin + FScript.Assign(Value); +end; + + +function TPSScript.AddMethod(Slf, Ptr: Pointer; + const Decl: tbtstring): Boolean; +begin + Result := AddMethodEx(Slf, Ptr, Decl, cdRegister); +end; + +function TPSScript.AddMethodEx(Slf, Ptr: Pointer; const Decl: tbtstring; + CallingConv: TDelphiCallingConvention): Boolean; +var + P: TPSRegProc; +begin + if not FCanAdd then begin Result := False; exit; end; + p := Comp.AddDelphiFunction(Decl); + if p <> nil then + begin + Exec.RegisterDelphiMethod(Slf, Ptr, p.Name, CallingConv); + Result := True; + end else Result := False; +end; + +procedure TPSScript.OnLineEvent; +begin + if @FOnLine <> nil then FOnLine(Self); +end; + +function TPSScript.GetRunning: Boolean; +begin + Result := FExec.Status = isRunning; +end; + +function TPSScript.GetExecErrorCol: Cardinal; +var + s: tbtstring; + D1: Cardinal; +begin + if not TranslatePositionRC(Exec.ExceptionProcNo, Exec.ExceptionPos, D1, Result, s) then + Result := 0; +end; + +function TPSScript.TranslatePositionPos(Proc, Position: Cardinal; + var Pos: Cardinal; var fn: tbtstring): Boolean; +var + D1, D2: Cardinal; +begin + Result := Exec.TranslatePositionEx(Exec.ExceptionProcNo, Exec.ExceptionPos, Pos, D1, D2, fn); +end; + +function TPSScript.TranslatePositionRC(Proc, Position: Cardinal; + var Row, Col: Cardinal; var fn: tbtstring): Boolean; +var + d1: Cardinal; +begin + Result := Exec.TranslatePositionEx(Proc, Position, d1, Row, Col, fn); +end; + + +function TPSScript.GetExecErrorRow: Cardinal; +var + D1: Cardinal; + s: tbtstring; +begin + if not TranslatePositionRC(Exec.ExceptionProcNo, Exec.ExceptionPos, Result, D1, s) then + Result := 0; +end; + +procedure TPSScript.Stop; +begin + if (FExec.Status = isRunning) or (Fexec.Status = isPaused) then + FExec.Stop + else + raise Exception.Create(RPS_NotRunning); +end; + +function TPSScript.GetProcMethod(const ProcName: tbtstring): TMethod; +begin + Result := FExec.GetProcAsMethodN(ProcName) +end; + +procedure TPSScript.SetMainFileName(const Value: tbtstring); +begin + FMainFileName := Value; +end; + +function TPSScript.GetExecErrorFileName: tbtstring; +var + D1, D2: Cardinal; +begin + if not TranslatePositionRC(Exec.ExceptionProcNo, Exec.ExceptionPos, D1, D2, Result) then + Result := ''; +end; + +procedure TPSScript.SetPointerToData(const VarName: tbtstring; + Data: Pointer; aType: TIFTypeRec); +var + v: PIFVariant; + t: TPSVariantIFC; +begin + v := GetVariable(VarName); + if (Atype = nil) or (v = nil) then raise Exception.Create(RPS_UnableToFindVariable); + t.Dta := @PPSVariantData(v).Data; + t.aType := v.FType; + t.VarParam := false; + VNSetPointerTo(t, Data, aType); +end; + +function TPSScript.AddRegisteredPTRVariable(const VarName, + VarType: tbtstring): Boolean; +var + FVar: TPSVar; +begin + if not FCanAdd then begin Result := False; exit; end; + FVar := FComp.AddUsedVariableN(varname, vartype); + if fvar = nil then + result := False + else begin + fvar.exportname := fvar.Name; + fvar.SaveAsPointer := true; + Result := True; + end; +end; + +procedure TPSScript.SetDefines(const Value: TStrings); +begin + FDefines.Assign(Value); +end; + +function TPSScript.ExecuteFunction(const Params: array of Variant; + const ProcName: tbtstring): Variant; +begin + if SuppressLoadData then + LoadExec; + + DoOnExecute (RI); + + FExec.DebugEnabled := FUseDebugInfo; + + Result := Exec.RunProcPN(Params, ProcName); + + DoAfterExecute; +end; + +function TPSScript.FindBaseType(Bt: TPSBaseType): TPSTypeRec; +begin + Result := Exec.FindType2(Bt); +end; + +function TPSScript.FindNamedType(const Name: tbtstring): TPSTypeRec; +begin + Result := Exec.GetTypeNo(Exec.GetType(Name)); +end; + +procedure TPSScript.Notification(AComponent: TComponent; + Operation: TOperation); +var + i: Longint; +begin + inherited Notification(AComponent, Operation); + if (Operation = opRemove) and (aComponent is TPSPlugin) then + begin + for i := Plugins.Count -1 downto 0 do + begin + if (Plugins.Items[i] as TPSPluginItem).Plugin = aComponent then + {$IFDEF FPC_COL_NODELETE} + TCollectionItem(Plugins.Items[i]).Free; + {$ELSE} + Plugins.Delete(i); + {$ENDIF} + end; + end; +end; + +function TPSScript.AddNotificationVariant(const VarName: tbtstring): Boolean; +begin + Result := AddRegisteredVariable(VarName, '!NOTIFICATIONVARIANT'); +end; + +procedure TPSScript.DoOnProcessDirective(Sender: TPSPreProcessor; + Parser: TPSPascalPreProcessorParser; const Active: Boolean; + const DirectiveName, DirectiveParam: tbtstring; var Continue: Boolean); +begin + If Assigned (OnProcessDirective) then + OnProcessDirective (Sender, Parser, Active, DirectiveName, DirectiveParam, Continue); +end; + +procedure TPSScript.DoOnProcessUnknowDirective(Sender: TPSPreProcessor; + Parser: TPSPascalPreProcessorParser; const Active: Boolean; + const DirectiveName, DirectiveParam: tbtstring; var Continue: Boolean); +begin + If Assigned (OnProcessUnknowDirective) then + OnProcessUnknowDirective (Sender, Parser, Active, DirectiveName, DirectiveParam, Continue); +end; + +function TPSScript.DoOnNeedFile(Sender: TObject; + const OrginFileName: tbtstring; var FileName, Output: tbtstring): Boolean; +begin + If Assigned (OnNeedFile) then + Result := OnNeedFile(Sender, OrginFileName, FileName, Output) + else + Result := False; +end; + +function TPSScript.DoOnUnknowUses(Sender: TPSPascalCompiler; + const Name: tbtstring): Boolean; +var + lPrevAllowUnit: Boolean; + lData, lName: tbtstring; +begin + if assigned(FOnFindUnknownFile) then begin + lName := Name; + if FOnFindUnknownFile(self, '', lName, lData) then begin + lPrevAllowUnit := FComp.AllowUnit; + FComp.AllowUnit := true; + if FUsePreProcessor then + begin + FPP.Defines.Assign(FDefines); + Fpp.MainFile := lData; + Fpp.MainFileName := lName; + Fpp.PreProcess(lName, lData); + Result := FComp.Compile(lData); + Fpp.AdjustMessages(FComp); + end else + begin + FComp.OnTranslateLineInfo := nil; + Result := FComp.Compile(lData); + end; + FComp.AllowUnit := lPrevAllowUnit; + end else begin + FComp.MakeError(FComp.UnitName, ecUnknownIdentifier, lName); + Result := false; + end; + end else begin + FComp.MakeError(FComp.UnitName, ecUnknownIdentifier, lName); + result := false; + end; +end; + +procedure TPSScript.DoOnCompImport; +begin + if assigned(OnCompImport) then + OnCompImport(Self, Comp); +end; + +procedure TPSScript.DoOnCompile; +begin + if assigned(OnCompile) then + OnCompile(Self); +end; + +procedure TPSScript.DoOnExecute; +begin + If Assigned (OnExecute) then + OnExecute (Self); +end; + +procedure TPSScript.DoAfterExecute; +begin + if Assigned (OnAfterExecute) then + OnAfterExecute(Self); +end; + +function TPSScript.DoVerifyProc(Sender: TPSScript; + Proc: TPSInternalProcedure; const Decl: tbtstring): Boolean; +begin + if Assigned(OnVerifyProc) then begin + Result := false; + OnVerifyProc(Sender, Proc, Decl, Result); + Result := not Result; + end + else + Result := True; +end; + +procedure TPSScript.DoOnExecImport( + RunTimeImporter: TPSRuntimeClassImporter); +begin + if assigned(OnExecImport) then + OnExecImport(Self, FExec, RunTimeImporter); +end; + +function TPSScript.DoOnGetNotificationVariant(const Name: tbtstring): Variant; +begin + if Not Assigned (OnGetNotificationVariant) then + raise Exception.Create(RPS_UnableToReadVariant); + Result := OnGetNotificationVariant(Self, Name); +end; + +procedure TPSScript.DoOnSetNotificationVariant(const Name: tbtstring; + V: Variant); +begin + if Not Assigned (OnSetNotificationVariant) then + raise Exception.Create(RPS_UnableToWriteVariant); + OnSetNotificationVariant(Self, Name, v); +end; + +{ TPSDllPlugin } + +procedure TPSDllPlugin.CompOnUses; +begin + CompExec.Comp.OnExternalProc := DllExternalProc; +end; + +procedure TPSDllPlugin.ExecOnUses; +begin + RegisterDLLRuntime(CompExec.Exec); +end; + + + +{ TPS3DebugCompExec } + +procedure LineInfo(Sender: TPSDebugExec; const FileName: tbtstring; Position, Row, Col: Cardinal); +var + Dc: TPSScriptDebugger; + h, i: Longint; + bi: TPSBreakPointInfo; + lFileName: tbtstring; +begin + Dc := Sender.Id; + if FileName = '' then + lFileName := dc.MainFileName + else + lFileName := FileName; + + if @dc.FOnLineInfo <> nil then dc.FOnLineInfo(dc, lFileName, Position, Row, Col); + if row = dc.FLastRow then exit; + dc.FLastRow := row; + h := MakeHash(lFileName); + bi := nil; + for i := DC.FBreakPoints.Count -1 downto 0 do + begin + bi := Dc.FBreakpoints[i]; + if (h = bi.FileNameHash) and (lFileName = bi.FileName) and (Cardinal(bi.Line) = Row) then + begin + Break; + end; + Bi := nil; + end; + if bi <> nil then + begin + if @dc.FOnBreakpoint <> nil then dc.FOnBreakpoint(dc, lFileName, Position, Row, Col); + dc.Pause; + end; +end; + +procedure IdleCall(Sender: TPSDebugExec); +var + Dc: TPSScriptDebugger; +begin + Dc := Sender.Id; + if @dc.FOnIdle <> nil then + dc.FOnIdle(DC) + else + dc.Exec.Run; +end; + +procedure TPSScriptDebugger.ClearBreakPoint(const Fn: tbtstring; Line: Integer); +var + h, i: Longint; + bi: TPSBreakPointInfo; +begin + h := MakeHash(Fn); + for i := FBreakPoints.Count -1 downto 0 do + begin + bi := FBreakpoints[i]; + if (h = bi.FileNameHash) and (Fn = bi.FileName) and (bi.Line = Line) then + begin + FBreakPoints.Delete(i); + bi.Free; + Break; + end; + end; +end; + +procedure TPSScriptDebugger.ClearBreakPoints; +var + i: Longint; +begin + for i := FBreakPoints.Count -1 downto 0 do + TPSBreakPointInfo(FBreakPoints[i]).Free; + FBreakPoints.Clear;; +end; + +constructor TPSScriptDebugger.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FBreakPoints := TIFList.Create; + FExec.OnSourceLine := LineInfo; + FExec.OnIdleCall := IdleCall; +end; + +destructor TPSScriptDebugger.Destroy; +var + i: Longint; +begin + for i := FBreakPoints.Count -1 downto 0 do + begin + TPSBreakPointInfo(FBreakPoints[i]).Free; + end; + FBreakPoints.Free; + inherited Destroy; +end; + +function TPSScriptDebugger.GetBreakPoint(I: Integer): TPSBreakPointInfo; +begin + Result := FBreakPoints[i]; +end; + +function TPSScriptDebugger.GetBreakPointCount: Longint; +begin + Result := FBreakPoints.Count; +end; + +function TPSScriptDebugger.GetVarContents(const Name: tbtstring): tbtstring; +var + i: Longint; + pv: PIFVariant; + s1, s: tbtstring; +begin + s := Uppercase(Name); + if pos('.', s) > 0 then + begin + s1 := copy(s,1,pos('.', s) -1); + delete(s,1,pos('.', Name)); + end else begin + s1 := s; + s := ''; + end; + pv := nil; + for i := 0 to Exec.CurrentProcVars.Count -1 do + begin + if Uppercase(Exec.CurrentProcVars[i]) = s1 then + begin + pv := Exec.GetProcVar(i); + break; + end; + end; + if pv = nil then + begin + for i := 0 to Exec.CurrentProcParams.Count -1 do + begin + if Uppercase(Exec.CurrentProcParams[i]) = s1 then + begin + pv := Exec.GetProcParam(i); + break; + end; + end; + end; + if pv = nil then + begin + for i := 0 to Exec.GlobalVarNames.Count -1 do + begin + if Uppercase(Exec.GlobalVarNames[i]) = s1 then + begin + pv := Exec.GetGlobalVar(i); + break; + end; + end; + end; + if pv = nil then + Result := RPS_UnknownIdentifier + else + Result := PSVariantToString(NewTPSVariantIFC(pv, False), s); +end; + +function TPSScriptDebugger.HasBreakPoint(const Fn: tbtstring; Line: Integer): Boolean; +var + h, i: Longint; + bi: TPSBreakPointInfo; +begin + h := MakeHash(Fn); + for i := FBreakPoints.Count -1 downto 0 do + begin + bi := FBreakpoints[i]; + if (h = bi.FileNameHash) and (Fn = bi.FileName) and (bi.Line = Line) then + begin + Result := true; + exit; + end; + end; + Result := False; +end; + +procedure TPSScriptDebugger.Pause; +begin + if FExec.Status = isRunning then + FExec.Pause + else + raise Exception.Create(RPS_NotRunning); +end; + +procedure TPSScriptDebugger.Resume; +begin + if FExec.Status = isRunning then + FExec.Run + else + raise Exception.Create(RPS_NotRunning); +end; + +procedure TPSScriptDebugger.SetBreakPoint(const fn: tbtstring; Line: Integer); +var + i, h: Longint; + BI: TPSBreakPointInfo; +begin + h := MakeHash(fn); + for i := FBreakPoints.Count -1 downto 0 do + begin + bi := FBreakpoints[i]; + if (h = bi.FileNameHash) and (fn = bi.FileName) and (bi.Line = Line) then + exit; + end; + bi := TPSBreakPointInfo.Create; + FBreakPoints.Add(bi); + bi.FileName := fn; + bi.Line := Line; +end; + +procedure TPSScriptDebugger.SetMainFileName(const Value: tbtstring); +var + OldFn: tbtstring; + h1, h2,i: Longint; + bi: TPSBreakPointInfo; +begin + OldFn := FMainFileName; + inherited SetMainFileName(Value); + h1 := MakeHash(OldFn); + h2 := MakeHash(Value); + if OldFn <> Value then + begin + for i := FBreakPoints.Count -1 downto 0 do + begin + bi := FBreakPoints[i]; + if (bi.FileNameHash = h1) and (bi.FileName = OldFn) then + begin + bi.FFileNameHash := h2; + bi.FFileName := Value; + end else if (bi.FileNameHash = h2) and (bi.FileName = Value) then + begin + // It's already the new filename, that can't be right, so remove all the breakpoints there + FBreakPoints.Delete(i); + bi.Free; + end; + end; + end; +end; + +procedure TPSScriptDebugger.StepInto; +begin + if (FExec.Status = isRunning) or (FExec.Status = isLoaded) then + FExec.StepInto + else + raise Exception.Create(RPS_NoScript); +end; + +procedure TPSScriptDebugger.StepOver; +begin + if (FExec.Status = isRunning) or (FExec.Status = isLoaded) then + FExec.StepOver + else + raise Exception.Create(RPS_NoScript); +end; + + + +{ TPSPluginItem } + +procedure TPSPluginItem.Assign(Source: TPersistent); //Birb +begin + if Source is TPSPluginItem then + plugin:=((source as TPSPluginItem).plugin) + else + inherited; +end; + +function TPSPluginItem.GetDisplayName: string; +begin + if FPlugin <> nil then + Result := string(FPlugin.Name) + else + Result := '<nil>'; +end; + +procedure TPSPluginItem.SetPlugin(const Value: TPSPlugin); +begin + FPlugin := Value; + If Value <> nil then + Value.FreeNotification(TPSPlugins(Collection).FCompExec); + Changed(False); +end; + +{ TPSPlugins } + +constructor TPSPlugins.Create(CE: TPSScript); +begin + inherited Create(TPSPluginItem); + FCompExec := CE; +end; + +function TPSPlugins.GetOwner: TPersistent; +begin + Result := FCompExec; +end; + +{ TPSBreakPointInfo } + +procedure TPSBreakPointInfo.SetFileName(const Value: tbtstring); +begin + FFileName := Value; + FFileNameHash := MakeHash(Value); +end; + +{ TPSCustomPlugin } +procedure TPSCustumPlugin.CompileImport1(CompExec: TPSScript); +begin + IF @FOnCompileImport1 <> nil then + FOnCompileImport1(CompExec) + else + inherited; +end; + +procedure TPSCustumPlugin.CompileImport2(CompExec: TPSScript); +begin + IF @FOnCompileImport2 <> nil then + FOnCompileImport2(CompExec) + else + inherited; +end; + +procedure TPSCustumPlugin.CompOnUses(CompExec: TPSScript); +begin + IF @FOnCompOnUses <> nil then + FOnCompOnUses(CompExec) + else + inherited; +end; + +procedure TPSCustumPlugin.ExecImport1(CompExec: TPSScript; + const ri: TPSRuntimeClassImporter); +begin + IF @FOnExecImport1 <> nil then + FOnExecImport1(CompExec, compExec.Exec, ri) + else + inherited; +end; + +procedure TPSCustumPlugin.ExecImport2(CompExec: TPSScript; + const ri: TPSRuntimeClassImporter); +begin + IF @FOnExecImport2 <> nil then + FOnExecImport1(CompExec, compExec.Exec, ri) + else + inherited; +end; + +procedure TPSCustumPlugin.ExecOnUses(CompExec: TPSScript); +begin + IF @FOnExecOnUses <> nil then + FOnExecOnUses(CompExec) + else + inherited; +end; + +end. diff --git a/Units/PascalScript/uPSComponentExt.pas b/Units/PascalScript/uPSComponentExt.pas new file mode 100644 index 0000000..1ffe82d --- /dev/null +++ b/Units/PascalScript/uPSComponentExt.pas @@ -0,0 +1,1010 @@ +{ +@abstract(Component wrapper for IFPS3 compiler and executer) +A component wrapper for IFPS3, including debugging support. + +} +{$I PascalScript.inc} + +unit uPSComponentExt; + +interface + +uses + {$IFNDEF LINUX} Windows, {$ENDIF} SysUtils, Classes, uPSRuntime, uPSDebugger, uPSUtils, uPSComponent, + contnrs, uPSCompiler, uPSC_dll, uPSR_dll, uPSPreProcessor, typInfo; + +const + {alias to @link(ifps3.cdRegister)} + cdRegister = uPSRuntime.cdRegister; + {alias to @link(ifps3.cdPascal)} + cdPascal = uPSRuntime.cdPascal; + { alias to ifps3.cdCdecl } + CdCdecl = uPSRuntime.CdCdecl; + {alias to @link(ifps3.cdStdcall)} + CdStdCall = uPSRuntime.CdStdCall; + +type + {Alias to @link(ifps3.TPSCallingConvention)} + TDelphiCallingConvention = uPSRuntime.TPSCallingConvention; + {Alias to @link(ifps3.TPSRuntimeClassImporter)} + TPSRuntimeClassImporter = uPSRuntime.TPSRuntimeClassImporter; + + TPSScriptExtension = class; + + {Base class for all plugins for the component} + TPSOnCompCleanup = Function (Sender: TObject; aComp: TPSPascalCompiler):Boolean of object; + TPSOnInsertProcedure = Procedure (Sender: TObject; aProc: tbtstring; OnTop: Boolean) of object; + TPSOnException = procedure (Sender: TPSExec; ExError: TPSError; const ExParam: tbtstring; + ExObject: TObject; ProcNo, Position: Cardinal) of object; + + TMethodList = class; + TProcObj = Class + private + FName : tbtstring; + fOwner : TMethodList; + procedure SetName(const Value: tbtstring); + public + ProcType : TStringList; + Method : TMethod; + constructor create(aOwner: TMethodList); + destructor Destroy; override; + property Name: tbtstring read FName write SetName; + end; + + TMethodObj = Class + Instance : TPersistent; + PropName : tbtstring; + ProcName : tbtstring; + end; + + TMethodList = class + private + fOwner : TPSScriptExtension; + fProcList : TObjectList; + fEventList : TObjectList; + function GetObject(Index: Integer): TMethodObj; virtual; + function GetProcObj(Index: Integer): TProcObj; + function GetMethodName(Instance: TObject; PropName: tbtstring): tbtstring; + procedure SetMethodName(Instance: TObject; PropName: tbtstring; const Value: tbtstring); + procedure CreateProc(ProcName: tbtstring; aPropType: TTypeData); + public + constructor create(aOwner: TPSScriptExtension); + destructor Destroy; override; + function methodIndexOf(Instance: TObject; PropName: tbtstring):Integer; + Function ProcIndexOf(Name: tbtstring): Integer; + Procedure ListEventsName(EventType:tbtstring; List : TStrings); + + Procedure AddProcedure(ProcName, ProcType:tbtstring); + procedure InsertMethod(NewProc: tbtstring; OnTop: Boolean = false); + + Procedure FillMethods; + procedure ClearProcList; + Procedure ClearAll; + function ProcCount :Integer; + Function MethodCount :Integer; + property Procs[Index: Integer]: TProcObj read GetProcObj ; + property Methods[Index: Integer]: TMethodObj read GetObject; + property ProcName[Instance: TObject; PropName:tbtstring]: tbtstring read GetMethodName write SetMethodName; + end; + + TPSScriptExtension = class(TPSScriptDebugger) + private + FOnBeforeCleanUp: TPSOnCompCleanup; + FMethodList : TMethodList; + FOnInsertMethod: TPSOnInsertProcedure; + FNeedCompiling :Boolean; + FOnScriptChance: TNotifyEvent; + FOnException: TPSOnException; + + fItems, fInserts: TStrings; + fScriptPos : Cardinal; + fObjectNest: tbtstring; + + Procedure GetCodeProps ; + function GetProcName(Instance: TObject; PropName: tbtstring): tbtstring; + procedure SetProcName(Instance: TObject; PropName: tbtstring; const Value: tbtstring); + + protected + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + + procedure DoVerifyProc(Sender: TPSScript; Proc: TPSInternalProcedure; + const Decl: tbtstring; var Error: Boolean); reintroduce; + Function DoBeforeCleanup(Sender: TObject; aComp: TPSPascalCompiler):Boolean; + procedure DoScriptChance(sender:TObject); + + + public + {Create an instance of the CompExec component} + constructor Create(AOwner: TComponent); override; + {Destroy the CompExec component} + destructor Destroy; override; + + function Compile: Boolean; Override; + function Execute: Boolean; Override; + { Create a list of all var's, const's, Type's and functions } + Procedure GetValueDefs(aItems, aInserts: TStrings; Const aObjectNest: tbtstring=''; aScriptPos: Integer = 0); + + {Compile the source only when the source is modified} + procedure CompileIfNeeded; + {Is the source modified} + Property NeedCompiling : Boolean read FNeedCompiling; + + {Fills all function in the script to there connected Events. + This is called automatic after a succesfull Compilition} + Procedure FillMethods; + + {Removes all events from the Objects Fills all function in the script to there connected Events. + This function is automatic called before a Compilition} + procedure ClearProcList; + Procedure RemoveObjEvents(Obj: TObject); + + {This property helps you set the events that must becalled from within the script + Instance is the object where the Propname must be set. + You need te create the function yopur self in the script. + When the new Procname dose not exists in the script, it is automatic created for you.} + property ProcName[Instance: TObject; PropName:tbtstring]: tbtstring read GetProcName write SetProcName; + property MethodList : TMethodList read FMethodList; + + published + + property OnBeforeCleanUp: TPSOnCompCleanup read FOnBeforeCleanUp write FOnBeforeCleanUp; //<NVDS> + property OnInsertMethod : TPSOnInsertProcedure read FOnInsertMethod write FOnInsertMethod; + Property OnScriptChance : TNotifyEvent read FOnScriptChance write fOnScriptChance; + property OnException : TPSOnException read FOnException write FOnException; + end; + + +implementation + +resourcestring + sMissingEndStatment = 'Missing some ''End'' statments'; + + +function CompExportCheck(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure; const ProcDecl: tbtstring): Boolean; +begin + TPSScriptExtension(Sender.ID).DoVerifyProc(Sender.Id, Proc, ProcDecl, Result); + Result := not Result; +end; + +Function BeforeCleanup(Sender: TPSPascalCompiler):Boolean; +begin + result := TPSScriptExtension(Sender.ID).DoBeforeCleanUp(Sender.ID,Sender); +end; + +procedure CEException(Sender: TPSExec; ExError: TIFError; const ExParam: tbtstring; ExObject: TObject; ProcNo, Position: Cardinal); +begin + if @TPSScriptExtension(Sender.ID).FOnException <> nil then + TPSScriptExtension(Sender.ID).FOnException(Sender, ExError, ExParam, ExObject, ProcNo, Position); +end; + +{ TPSScriptExtension } + +function TPSScriptExtension.Compile: Boolean; +begin + ClearProcList; + + result := inherited Compile; + if result then FillMethods; + + + FNeedCompiling := not result; +end; + +constructor TPSScriptExtension.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + Comp.OnBeforeCleanup := BeforeCleanup; + Comp.OnExportCheck := CompExportCheck; + Exec.OnException := CEException; + + TStringList(script).OnChange := DoScriptChance; + FMethodList := TMethodList.create(Self); + FNeedCompiling := True; +end; + +destructor TPSScriptExtension.Destroy; +begin + FMethodList.Free; + FMethodList := nil; + inherited Destroy; +end; + +procedure TPSScriptExtension.DoVerifyProc(Sender: TPSScript; + Proc: TPSInternalProcedure; const Decl: tbtstring; var Error: Boolean); +var + n{,m,p} : Integer; + tstType : TPSProceduralType; +begin + Error := False; + for n := 0 to sender.comp.GetTypeCount -1 do begin + If comp.GetType(n) is TPSProceduralType then begin + tstType := comp.GetType(n) as TPSProceduralType; + If tstType.ProcDef.Same(Proc.Decl) then begin + MethodList.addprocedure(Proc.OriginalName, tstType.Name); +// Proc. aExport := etExportDecl; + end; + end; + end; + if assigned(OnVerifyProc) then + begin + onVerifyProc(Sender, Proc, Decl, Error); + end; +end; + +type + TMyPascalCompiler = class(TPSPascalCompiler); +const + sIFPSParameterMode : array [pmIn..pmInOut] of tbtstring = ('','\style{+B}out\style{-B} ','\style{+B}Var\style{-B} '); + +Procedure TPSScriptExtension.GetCodeProps; + + Function existsItem(aName:tbtstring):Boolean; + Begin + result := FInserts.indexof(aName)<> -1; + end; + + Procedure addListItem(aType, aName:tbtstring; aDef:tbtstring=''); + var + x : LongInt; + begin + If not ((aName ='') or (aName[1]='!')) then begin + x := FInserts.Add(aName); + fItems.Insert(x, format('%s \column{}\style{+B}%s\style{-B} %s',[aType, aName, aDef])); + end; + end; + + procedure Getdecl(decl : TPSParametersDecl; var T,v :tbtstring); + var + m : Integer; + begin + v := ''; + for m := 0 to Decl.ParamCount-1 do begin + v := V +';'+sIFPSParameterMode[Decl.Params[m].Mode]+ + Decl.Params[m].OrgName; + if Decl.Params[m].aType <> nil then + v := v +':'+ Decl.Params[m].aType.OriginalName; + end; + delete(v,1,1); + If v <> '' then v := '('+ v +')'; + if Decl.Result<>nil then begin + v := v +':'+ Decl.Result.OriginalName; + t := 'Function'; + end else t := 'Procedure'; + + end; + + Function getTypeDef(xr: TPSType; aZoek:tbtstring = ''):Boolean; forward; + + Function getClassDef(xc: TPSCompileTimeClass; aZoek:tbtstring = ''):Boolean; + var + Show : Boolean; + Zoek,bZoek : tbtstring; + tci : TPSDelphiClassItem; + n : Integer; + T,v : tbtstring; + + begin + Show := aZoek=''; + Zoek := aZoek; + If Pos('.',aZoek)>0 then begin + Zoek := copy(aZoek, 1 ,Pos('.',aZoek)-1); + bZoek := copy(aZoek, Pos('.',aZoek)+1, 999); + end else bZoek := ''; + + result := (xc <> nil) and Show; + if XC<> nil then begin + For n := 0 to xc.Count-1 do begin + tci := xc.Items[n]; + If (tci = nil) or existsItem(tci.OrgName) then continue; + if tci is TPSDelphiClassItemConstructor then begin + Getdecl(tci.decl, T, V); + If Show then addListItem('Constructor',tci.OrgName, v); + end else + if tci is TPSDelphiClassItemMethod then begin + If Show then begin + Getdecl(tci.decl, T, V); + addListItem(T,tci.OrgName, v) + end else + If (tci.decl.Result <> nil) and (tci.Name = Zoek) then + result := getTypeDef(tci.decl.Result, bZoek); + end else + if tci is TPSDelphiClassItemProperty then begin + If Show then begin + t := ''; + If tci.Decl.Result<> nil then t := ': '+ tci.Decl.Result.OriginalName; + addListItem('Property',tci.OrgName, t); + end else + If (tci.decl.Result <> nil) and (tci.Name = Zoek) then + result := getTypeDef(tci.decl.Result, bZoek); + end; + If result and not show then exit; + end; + result := getClassDef(XC.ClassInheritsFrom, aZoek) or result; + end; + end; + + Function getTypeDef(xr: TPSType; aZoek:tbtstring = ''):Boolean; + var + Show : Boolean; + Zoek : tbtstring; + xri : PIFPSRecordFieldTypeDef; + n : Integer; + begin + Show := aZoek=''; + result := (xr <> nil) and Show; + if xr <> nil then begin + If xr is TPSRecordType then begin + Zoek := aZoek; + If Pos('.',aZoek)>0 then begin + Zoek := copy(aZoek, 1 ,Pos('.',aZoek)-1); + aZoek := copy(aZoek, Pos('.',aZoek)+1, 999); + end else aZoek := ''; + for n := 0 to (xr as TPSRecordType).RecValCount-1 do begin + xri := (xr as TPSRecordType).RecVal(n); + If Show then begin + addListItem('Var',xri.FieldOrgName,xri.aType.OriginalName) + end else + If (xri.aType <> nil) and (xri.FieldName = Zoek) then + result := getTypeDef(xri.aType, aZoek); + end; + end else + If (xr is TPSClassType) then begin + result := getClassDef((xr as TPSClassType).Cl, aZoek) + end else + result := False; + end; + end; + + Function FindVarProc(aVarName:tbtstring; aZoek : tbtstring= ''):Boolean; + var +// cv : tbtstring; + hh, h, i : Longint; + proc : TPSProcedure; + ip : TPSInternalProcedure; + ipv : PIFPSProcVar; + ipp : TPSParameterDecl; +// t : tbtstring; + begin + Hh := MakeHash(aVarName); + result := False; + If FScriptPos =0 then exit; + for i := Comp.GetProcCount -1 downto 0 do begin + Proc := Comp.GetProc(i); + If (Proc.ClassType = TPSInternalProcedure) and + ((Proc as TPSInternalProcedure).DeclarePos < FScriptPos) then begin + ip := Proc as TPSInternalProcedure; + for h := 0 to ip.ProcVars.Count-1 do begin + ipv := PIFPSProcVar(ip.ProcVars[h]); + If aVarName = '' then begin + addListItem('Var',ipv.OrgName, ': '+ipv.AType.OriginalName); + end else + If (ipv.NameHash = HH) and (ipv.Name = aVarName) then begin + result := getTypeDef(ipv.aType, aZoek); + exit; + end; + end; + for h := 0 to ip.Decl.ParamCount-1 do begin + ipp := TPSParameterDecl(ip.Decl.Params[h]); + If aVarName = '' then begin + addListItem('Var',ipp.OrgName, ': '+ipp.aType.OriginalName); + end else + If {(ipp.Hash = HH) and} (ipp.Name = aVarName) then begin + result := getTypeDef(ipp.aType, aZoek); + exit; + end; + end; + end; + end; + end; + + Function FindVarFunctType(aProcName:tbtstring): Boolean; + var + cv : tbtstring; + h, i : Longint; + proc : TPSProcedure; + xr : TPSRegProc; +// t : tbtstring; + begin + cv := aProcName; + If Pos('.',aProcName)>0 then begin + cv := copy(aProcName, 1 ,Pos('.',aProcName)-1); + aProcName := copy(aProcName, Pos('.',aProcName)+1, 999); + end else aProcName := ''; + H := MakeHash(Cv); +// Result := False; + for i :=0 to Comp.GetVarCount -1 do begin + if (Comp.GetVar(I).NameHash = H) and (Comp.GetVar(I).Name = CV) then begin + Result := getTypeDef(Comp.GetVar(I).aType, aProcName); + Exit; + end; + end; + for i :=0 to Comp.GetTypeCount -1 do begin + if (Comp.GetType(I).NameHash = H) and (Comp.GetType(I).Name = CV) then begin + Result := getTypeDef(Comp.GetType(I), aProcName); + Exit; + end; + end; + result := FindVarProc(cv, aProcName); + If result then exit; + for i :=0 to Comp.GetProcCount -1 do begin + Proc := Comp.GetProc(i); + If Proc.ClassType = TPSInternalProcedure then begin + if ((Proc as TPSInternalProcedure).NameHash = H) and + ((Proc as TPSInternalProcedure).Name = CV) then begin + Result := getTypeDef((Proc as TPSInternalProcedure).Decl.Result, aProcName); + exit; + end; + end; + end; + with TMyPascalCompiler(Comp) do begin + for i := 0 to FRegProcs.Count-1 do begin + xr := FRegProcs[i]; + if (xr.NameHash = H) and (xr.Name = CV) then begin + result := getTypeDef(xr.Decl.Result, aProcName); + exit; + end; + end; + end; + end; + +Var + n : Integer; + s, t, v : tbtstring; + proc : TPSProcedure; + xr : TPSRegProc; + +begin + If (fItems = nil) or (fInserts = Nil) then exit; + fItems.BeginUpdate; + fInserts.BeginUpdate; + tStringList(fInserts).Sorted := true; + tStringList(fInserts).Duplicates := dupAccept; + try + fInserts.Clear; + fItems.Clear; + + If (FObjectNest <> '') then begin + FindVarFunctType(FastUpperCase(FObjectNest)); + exit; + end; + + for n := 0 to Comp.GetTypeCount-1 do begin + addListItem('Type',Comp.GetType(n).OriginalName); + end; + for n := 0 to Comp.GetVarCount-1 do begin + addListItem('Var',Comp.GetVar(n).OrgName, ': '+Comp.Getvar(n).aType.OriginalName); + end; + with TMyPascalCompiler(Comp) do begin + for n := 0 to FConstants.Count-1 do begin + addListItem('Const', TPSConstant(FConstants[n]).OrgName ); + end; + for n := 0 to FRegProcs.Count-1 do begin + xr := FRegProcs[n]; + Getdecl(xr.decl, T, v); + addListItem(t,xr.OrgName, v ); + end; + end; + FindVarProc(''); + for n := 0 to Comp.GetProcCount-1 do begin + s := ''; + proc := Comp.GetProc(n); + If Proc.ClassType = TPSInternalProcedure then begin + s := (Proc as TPSInternalProcedure).OriginalName; + Getdecl((Proc as TPSInternalProcedure).decl, T, v); + end; + If s <> '' then begin + addListItem(t,s, v ); + end; + end; + Finally + fInserts.EndUpdate; + fItems.EndUpdate; + end; +end; + +procedure TPSScriptExtension.GetValueDefs(aItems, aInserts: TStrings; const aObjectNest: tbtstring; aScriptPos: Integer); +begin + fItems := aItems; + fInserts := aInserts; + FScriptPos := aScriptPos; + fObjectNest := aObjectNest; + Try + compile; + finally + fItems := Nil; + fInserts := Nil; + FScriptPos := 0; + fObjectNest := ''; + end; +end; + +function TPSScriptExtension.DoBeforeCleanup(Sender: TObject; + aComp: TPSPascalCompiler): Boolean; +begin + result := true; + If fItems <> nil then GetCodeProps; + If @FOnBeforeCleanUp<> nil then + result := FOnBeforeCleanUp(Sender, aComp); +end; + +function TPSScriptExtension.Execute: Boolean; +begin + CompileIfNeeded; + MethodList.FillMethods; + result := inherited Execute; +end; + + +procedure TPSScriptExtension.DoScriptChance(sender: TObject); +begin + FNeedCompiling := True; + self.ClearProcList; + If @FOnScriptChance <> NIL then + FOnScriptChance(sender); +end; + +procedure TPSScriptExtension.CompileIfNeeded; +begin + if FNeedCompiling then begin + Compile; + end; +end; + +procedure TPSScriptExtension.Notification(AComponent: TComponent; + Operation: TOperation); +begin + inherited; + If Operation = opRemove then begin + if MethodList <> nil then + MethodList.SetMethodName(aComponent,'',''); + end; +end; + +function TPSScriptExtension.GetProcName(Instance: TObject; PropName: tbtstring): tbtstring; +begin + Result := MethodList.ProcName[Instance, Propname]; +end; + +procedure TPSScriptExtension.SetProcName(Instance: TObject; PropName: tbtstring; const Value: tbtstring); +begin + MethodList.ProcName[Instance, Propname] := Value; +end; + +procedure TPSScriptExtension.ClearProcList; +begin + MethodList.ClearProcList; +end; + +procedure TPSScriptExtension.RemoveObjEvents(Obj: TObject); +begin + MethodList.SetMethodName(Obj, '', ''); +end; + +procedure TPSScriptExtension.FillMethods; +begin + MethodList.FillMethods; +end; + +{ TMethodList } + +procedure TMethodList.AddProcedure(ProcName, ProcType: tbtstring); +var + po : TProcObj; + x,y : Integer; + +begin + ProcType := Uppercase(ProcType); + x := ProcIndexOf(ProcName); + if x <> -1 then begin + y := Procs[x].ProcType.IndexOf(ProcType); + If y = -1 then TProcObj(fProcList.Items[x]).ProcType.add(ProcType); + end else begin + po := TProcObj.create(self); + po.Name := ProcName; + po.ProcType.add(ProcType); + fProcList.add(po); + end +end; + +procedure TMethodList.ClearProcList; +begin + fProcList.Clear; +end; + +constructor TMethodList.create(aOwner: TPSScriptExtension); +begin + inherited create; + fOwner := aOwner; + fProcList := TObjectList.create(true); + fEventList := TObjectList.create(true); +end; + +procedure TMethodList.CreateProc(ProcName:tbtstring; aPropType: TTypeData); +var + newProc: tbtstring; + P: PByte; + i: Integer; + pf : TParamFlags; + + {$IFDEF FPC} + // mh: TParamFlags(P^) doesn't compile in FPC, this function will "fix" it. + // yes it's ugly, but I don't know an other way to fix it + function GetParamFlags(P: Byte): TParamFlags; + begin + result := []; + if (Ord(pfVar) and P <> 0) then Include(result, pfVar); + if (Ord(pfConst) and P <> 0) then Include(result, pfConst); + if (Ord(pfArray) and P <> 0) then Include(result, pfArray); + if (Ord(pfAddress) and P <> 0) then Include(result, pfAddress); + if (Ord(pfReference) and P <> 0) then Include(result, pfReference); + if (Ord(pfOut) and P <> 0) then Include(result, pfOut); + end; + {$ENDIF} + +begin + WITH aPropType do begin + if MethodKind=mkProcedure then NewProc:='procedure ' + else NewProc:='function '; + NewProc:=NewProc + ProcName+'('; + P:=PByte(@ParamList); + for i:=0 to Pred(ParamCount) do + begin + {$IFDEF FPC} + pf:=GetParamFlags(P^); + {$ELSE} + pf:=TParamFlags(P^); + {$ENDIF} + if pfVar in pf then NewProc:=NewProc+'var '; + if pfConst in pf then NewProc:=NewProc+'const '; + Inc(P); + NewProc:=NewProc +PShortString(P)^ +' : '; + Inc(P,Succ(P^)); + if pfArray in pf then NewProc:=NewProc+'array of '; + NewProc := NewProc + PShortString(P)^; + Inc(P,Succ(P^)); + If i < Pred(ParamCount) then NewProc := NewProc + '; '; + end; + NewProc := NewProc +')' ; + if (MethodKind=mkFunction) then + NewProc := NewProc +':'+ PShortString(P)^; + NewProc:=NewProc+';'^m^j + +'Begin'^m^j^m^j + +'End;'^m^j; + If @fowner.FOnInsertMethod <> nil then begin + fowner.FOnInsertMethod(fOwner, NewProc, false); + end else begin + InsertMethod(NewProc); + end; + fowner.CompileIfNeeded; + end; +end; + +procedure TMethodList.InsertMethod(NewProc: tbtstring; OnTop: Boolean = false); +var + x : Integer; + sl : TStringList; + nBegins : Integer; + nProcs : Integer; + line, test : tbtstring; + + + function IsItem(line,item:tbtstring; First :Boolean = false):Boolean; + var + nPos : Integer; + begin + repeat + nPos := pos(item,line); + result := ((npos>0) and ((length(Line)-nPos<= length(item)) or not(line[nPos+length(item)] in ['0'..'9','A'..'Z','_'])) And + ((Npos = 1) or ((not first) and not(line[nPos-1] in ['0'..'9','A'..'Z','_'])))); + if nPos <> 0 then line := copy(line,nPos+Length(Item),Length(line)); + until (Result) or (nPos = 0); + end; + + function DelSpaces(AText: tbtstring): tbtstring; + var i: Integer; + begin + Result := ''; + for i := 1 to Length(AText) do + if AText[i] <> ' ' then + Result := Result + AText[i]; + end; + + function IsProcDecl(AnOriginalProcDecl: tbtstring): Boolean; + var + bIsFunc: Boolean; + iLineNo: Integer; + sProcKey: tbtstring; + sProcDecl: tbtstring; + begin + Result := false; + sProcDecl := Line; + iLineNo := x; + bIsFunc := isItem(AnOriginalProcDecl,'FUNCTION',true); + + if bIsFunc + then sProcKey := 'FUNCTION' + else sProcKey := 'PROCEDURE'; + + sProcDecl := copy(sProcDecl,Pos(sProcKey,sProcDecl),Length(sProcDecl)); + + while not IsItem(sProcDecl,'BEGIN') do + begin + inc(iLineNo); + if iLineNo > (fowner.script.Count - 1) then exit; + sProcDecl := sProcDecl + ' ' + uppercase(trim(fowner.script[iLineNo])) + ' '; + end; + + sProcDecl := DelSpaces(sProcDecl); + AnOriginalProcDecl := DelSpaces(AnOriginalProcDecl); + + sProcDecl := copy(sProcDecl,1,Length(AnOriginalProcDecl)); + + Result := sProcDecl = AnOriginalProcDecl; + + end; +begin + sl := TStringList.create; + Try + sl.Text := NewProc; + test := uppercase(trim(sl[0])); + finally + Sl.free; + end; + nProcs := 0; + nBegins := 0; + x := 0; + If Not Ontop Then begin + for x := 0 to fOwner.script.count -1 do begin + Line := fowner.script[x]; + Line := uppercase(trim(line)); + If IsItem(line,'PROCEDURE', true) or IsItem(line,'FUNCTION', true) then begin + If nBegins >0 then Raise exception.create('Missing some ''end'' statments'); + If (nProcs = 0) and IsProcDecl(test) and + (not IsItem(line,'FORWARD')) and (not IsItem(line,'EXTERNAL')) then + Exit; + Inc(nProcs); + end; + if IsItem(line,'FORWARD') or IsItem(line,'EXTERNAL') then + dec(nProcs); + If Pos('END',line) < Pos('BEGIN',line) then begin + If IsItem(line,'END') then begin + If (nBegins = 0) and (nProcs=0) then Break; + Dec(nBegins); + If nBegins = 0 then Dec(nProcs); + end; + If IsItem(line,'BEGIN') or IsItem(line,'TRY') or IsItem(line,'CASE') then begin + If nProcs = 0 then Break; + Inc(nBegins); + end; + end else begin + If IsItem(line,'BEGIN') or IsItem(line,'TRY') or IsItem(line,'CASE') then begin + If nProcs = 0 then Break; + Inc(nBegins); + end; + If IsItem(line,'END') then begin + If (nBegins = 0) and (nProcs=0) then Break; + Dec(nBegins); + If nBegins = 0 then Dec(nProcs); + end; + end; + end; + end; + FOwner.script.BeginUpdate; + Try + If (nProcs <> 0) or (nBegins<>0) then + Raise exception.create(sMissingEndStatment); + If (Not Ontop) and (x>0) and (Trim(FOwner.script[x-1])<>'') then begin + FOwner.script.Insert(x,''); + inc(x); + end; + FOwner.script.Insert(x,NewProc); + FOwner.script.text := FOwner.script.text; + finally + FOwner.script.EndUpdate; + end; +end; + +destructor TMethodList.Destroy; +begin + fProcList.Free; {<< Needs Eventlist for removing Methods} + fEventList.Free; + inherited; +end; + +procedure TMethodList.FillMethods; +var + x, y : Integer; + m : TMethod; +begin + for x := 0 to fEventList.Count-1 do begin + Y := ProcIndexOf(MethodS[x].ProcName); + If (Y >= 0) and assigned(Methods[x].Instance) then begin + m := Procs[Y].Method; + if m.Data = nil then begin + m := fOwner.Exec.GetProcAsMethodN(Procs[Y].name); + TProcObj(fProcList.Items[Y]).Method := m; + end; + SetMethodProp(Methods[x].Instance, Methods[x].propname, m ); + end; + end; +end; + +function TMethodList.GetMethodName(Instance: TObject; PropName: tbtstring): tbtstring; +var + x : Integer; +begin + fOwner.CompileIfNeeded; + x := methodIndexOf(Instance,PropName); + If x>=0 then result := Methods[x].ProcName + else result := ''; +end; + +function TMethodList.GetObject(Index: Integer): TMethodObj; +begin + result := TMethodObj(fEventList.items[Index]); +end; + +function TMethodList.GetProcObj(Index: Integer): TProcObj; +begin + result := TProcObj(fProcList.items[Index]); +end; + +procedure TMethodList.ListEventsName(EventType: tbtstring; List: TStrings); +var + x : Integer; +begin + If List = nil then exit; + EventType := Uppercase(EventType); + List.Clear; + fOwner.CompileIfNeeded; + for x := 0 to fProcList.count-1 do begin + If Procs[x].ProcType.indexof(EventType)<> -1 then + List.add(Procs[x].name); + end; +end; + +function TMethodList.MethodCount: Integer; +begin + result := fEventList.count; +end; + +function TMethodList.methodIndexOf(Instance: TObject; + PropName: tbtstring): Integer; +var x : integer; +begin + Result := -1; + for x := 0 to fEventList.count-1 do begin + if (TMethodObj(fEventList.Items[x]).Instance = Instance) and + ((propName='') or(TMethodObj(fEventList.Items[x]).PropName = PropName)) then begin + Result := x; + exit; + end; + end; +end; + +function TMethodList.ProcCount: Integer; +begin + result := fProcList.count; +end; + +function TMethodList.ProcIndexOf(Name: tbtstring): Integer; +var x : integer; +begin + result := -1; + Name := Uppercase(name); + For x := 0 to fProcList.count-1 do begin + If Uppercase(TProcObj(fProcList.Items[x]).name) = name then begin + Result := x; + exit; + end; + end; +end; + +procedure TMethodList.SetMethodName(Instance: TObject; PropName: tbtstring; + const Value: tbtstring); +var + x, y : Integer; + mo : TMethodObj; + function TypeData(Instance: TObject; const PropName: tbtstring):PTypeData; + var + PropInfo: PPropInfo; + begin + // assume failure + Result := Nil; + PropInfo := GetPropInfo(Instance, PropName); + if PropInfo <> nil then + begin + Result:= GetTypeData(PropInfo^.PropType{$IFNDEF FPC}^{$ENDIF}); + end + end; + +begin + If PropName = '' then begin + x := 0; + While x < MethodCount do begin + If (Methods[x].Instance = Instance) or (Instance = nil) then + fEventList.Delete(x) + else Inc(x); + end; + end else begin + x := methodIndexOf(Instance, PropName); + if value = '' then begin + if x >= 0 then fEventList.Delete(x); + end else begin + fOwner.CompileIfNeeded; + y := ProcIndexOf(Value); + If (Y = -1) then begin + CreateProc(Value, TypeData(Instance,propName)^); + y := 0; + end; + If (x = -1) then begin + If (Y <> -1) then begin + mo := TMethodObj.create; + mo.Instance := TPersistent(Instance); + mo.ProPName := Propname; + mo.procName := Value; + If (methodIndexOf(Instance,'')<>-1) and Instance.InheritsFrom(TComponent) then + fOwner.FreeNotification(TComponent(Instance)); + fEventList.add(mo); + end; + end else + begin + Methods[x].procname := Value; + end; + end; + end; +end; + +procedure TMethodList.ClearAll; +begin + fProclist.clear; + fEventList.Clear; +end; + +{ TProcObj } + +constructor TProcObj.create(aOwner: TMethodList); +begin + inherited create(); + fOwner := aOwner; + ProcType := TStringList.Create; +end; + +destructor TProcObj.Destroy; + +var x : Integer; + m :TMethod; +begin + m.Code := nil; + m.Data := nil; + If ((Method.Data <> nil) or (method.Code<> nil)) and (fOwner<>nil) and assigned(fOwner) then begin + for x := 0 to fOwner.MethodCount-1 do begin + If (name = fOwner.Methods[x].ProcName) and assigned(fOwner.Methods[x].Instance) then begin + Try + SetMethodProp(fOwner.Methods[x].Instance, fOwner.Methods[x].PropName,m); + except; end; + end; + end; + end; + ProcType.free; + inherited; +end; + +procedure TProcObj.SetName(const Value: tbtstring); +var + x : Integer; +begin + If FName <> Value then begin + If fName<>'' then begin + for x := 0 to fOwner.MethodCount-1 do begin + If Fname = fOwner.Methods[x].ProcName then begin + fOwner.Methods[x].ProcName := Value; + end; + end; + end; + FName := Value; + end; +end; + + +end. diff --git a/Units/PascalScript/uPSComponent_COM.pas b/Units/PascalScript/uPSComponent_COM.pas new file mode 100644 index 0000000..1ae3533 --- /dev/null +++ b/Units/PascalScript/uPSComponent_COM.pas @@ -0,0 +1,38 @@ + +unit uPSComponent_COM; + +interface +uses + SysUtils, Classes, uPSComponent, uPSCompiler, uPSRuntime; +type + + TPSImport_ComObj = class(TPSPlugin) + private + public + procedure CompileImport1(CompExec: TPSScript); override; + procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override; + end; + + TIFPS3CE_ComObj = class(TPSImport_ComObj); + +implementation +uses + uPSC_comobj, + uPSR_comobj; + + +{ TPSImport_ComObj } + +procedure TPSImport_ComObj.CompileImport1(CompExec: TPSScript); +begin + SIRegister_ComObj(CompExec.Comp); +end; + + +procedure TPSImport_ComObj.ExecImport1(CompExec: TPSScript; + const ri: TPSRuntimeClassImporter); +begin + RIRegister_ComObj(CompExec.Exec); +end; + +end. diff --git a/Units/PascalScript/uPSComponent_Controls.pas b/Units/PascalScript/uPSComponent_Controls.pas new file mode 100644 index 0000000..fce7b29 --- /dev/null +++ b/Units/PascalScript/uPSComponent_Controls.pas @@ -0,0 +1,65 @@ + unit uPSComponent_Controls; + +interface +uses + SysUtils, Classes, uPSComponent, uPSCompiler, uPSRuntime; +type + + TPSImport_Controls = class(TPSPlugin) + private + FEnableStreams: Boolean; + FEnableGraphics: Boolean; + FEnableControls: Boolean; + public + procedure CompileImport1(CompExec: TPSScript); override; + procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override; + public + constructor Create(AOwner: TComponent); override; + published + + property EnableStreams: Boolean read FEnableStreams write FEnableStreams; + + property EnableGraphics: Boolean read FEnableGraphics write FEnableGraphics; + + property EnableControls: Boolean read FEnableControls write FEnableControls; + end; + + TIFPS3CE_Controls = class(TPSImport_Controls); + +implementation +uses + uPSC_graphics, + uPSC_controls, + uPSR_graphics, + uPSR_controls; + + +{ TPSImport_Controls } + +procedure TPSImport_Controls.CompileImport1(CompExec: TPSScript); +begin + if FEnableGraphics then + SIRegister_Graphics(CompExec.Comp, FEnableStreams); + if FEnableControls then + SIRegister_Controls(CompExec.Comp); +end; + +constructor TPSImport_Controls.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FEnableStreams := True; + FEnableGraphics := True; + FEnableControls := True; +end; + +procedure TPSImport_Controls.ExecImport1(CompExec: TPSScript; + const ri: TPSRuntimeClassImporter); +begin + if FEnableGraphics then + RIRegister_Graphics(ri, FEnableStreams); + if FEnableControls then + RIRegister_Controls(ri); +end; + + +end. diff --git a/Units/PascalScript/uPSComponent_DB.pas b/Units/PascalScript/uPSComponent_DB.pas new file mode 100644 index 0000000..c60d06e --- /dev/null +++ b/Units/PascalScript/uPSComponent_DB.pas @@ -0,0 +1,36 @@ + unit uPSComponent_DB; + +interface +{$I PascalScript.inc} +uses + SysUtils, Classes, uPSComponent, uPSRuntime, uPSCompiler; +type + + TPSImport_DB = class(TPSPlugin) + public + procedure CompileImport1(CompExec: TPSScript); override; + procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override; + public + end; + + TIFPS3CE_DB = class(TPSImport_DB); + +implementation +uses + uPSC_DB, + uPSR_DB; + +{ TPSImport_DB } + +procedure TPSImport_DB.CompileImport1(CompExec: TPSScript); +begin + SIRegister_DB(CompExec.Comp); +end; + +procedure TPSImport_DB.ExecImport1(CompExec: TPSScript; + const ri: TPSRuntimeClassImporter); +begin + RIRegister_DB(RI); +end; + +end. diff --git a/Units/PascalScript/uPSComponent_Default.pas b/Units/PascalScript/uPSComponent_Default.pas new file mode 100644 index 0000000..e7508cf --- /dev/null +++ b/Units/PascalScript/uPSComponent_Default.pas @@ -0,0 +1,81 @@ + unit uPSComponent_Default; +{$I PascalScript.inc} +interface +uses + SysUtils, Classes, uPSComponent, uPSCompiler, uPSRuntime; + +type + + TPSImport_DateUtils = class(TPSPlugin) + public + procedure CompOnUses(CompExec: TPSScript); override; + procedure ExecOnUses(CompExec: TPSScript); override; + end; + + TPSImport_Classes = class(TPSPlugin) + private + FEnableStreams: Boolean; + FEnableClasses: Boolean; + public + procedure CompileImport1(CompExec: TPSScript); override; + procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override; + public + + constructor Create(AOwner: TComponent); override; + published + + property EnableStreams: Boolean read FEnableStreams write FEnableStreams; + + property EnableClasses: Boolean read FEnableClasses write FEnableClasses; + end; + + TIFPS3CE_Std = class(TPSImport_Classes); + + TIFPS3CE_DateUtils = class(TPSImport_DateUtils); + +implementation +uses + uPSC_std, + uPSR_std, + uPSC_classes, + uPSR_classes, + uPSC_dateutils, + uPSR_dateutils; + +{ TPSImport_Classes } + +procedure TPSImport_Classes.CompileImport1(CompExec: TPSScript); +begin + SIRegister_Std(CompExec.Comp); + if FEnableClasses then + SIRegister_Classes(CompExec.Comp, FEnableStreams); +end; + +procedure TPSImport_Classes.ExecImport1(CompExec: TPSScript; + const ri: TPSRuntimeClassImporter); +begin + RIRegister_Std(Ri); + if FEnableClasses then + RIRegister_Classes(ri, FEnableStreams); +end; + +constructor TPSImport_Classes.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FEnableStreams := True; + FEnableClasses := True; +end; + +{ TPSImport_DateUtils } + +procedure TPSImport_DateUtils.CompOnUses(CompExec: TPSScript); +begin + RegisterDateTimeLibrary_C(CompExec.Comp); +end; + +procedure TPSImport_DateUtils.ExecOnUses(CompExec: TPSScript); +begin + RegisterDateTimeLibrary_R(CompExec.Exec); +end; + +end. diff --git a/Units/PascalScript/uPSComponent_Forms.pas b/Units/PascalScript/uPSComponent_Forms.pas new file mode 100644 index 0000000..418fbb2 --- /dev/null +++ b/Units/PascalScript/uPSComponent_Forms.pas @@ -0,0 +1,65 @@ + +unit uPSComponent_Forms; + +interface +uses + SysUtils, Classes, uPSRuntime, uPSCompiler, uPSComponent; +type + + TPSImport_Forms = class(TPSPlugin) + private + FEnableForms: Boolean; + FEnableMenus: Boolean; + public + procedure CompileImport1(CompExec: TPSScript); override; + procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override; + public + constructor Create(AOwner: TComponent); override; + published + + property EnableForms: Boolean read FEnableForms write FEnableForms; + + property EnableMenus: Boolean read FEnableMenus write FEnableMenus; + end; + + TIFPS3CE_Forms = class(TPSImport_Forms); + +implementation +uses + uPSC_forms, + uPSC_menus, + uPSR_forms, + uPSR_menus; + +{ TPSImport_Forms } + +procedure TPSImport_Forms.CompileImport1(CompExec: TPSScript); +begin + if FEnableForms then + SIRegister_Forms(CompExec.comp); + if FEnableMenus then + SIRegister_Menus(CompExec.comp); +end; + +constructor TPSImport_Forms.Create(AOwner: TComponent); +begin + inherited Create(Aowner); + FEnableForms := True; + FEnableMenus := True; +end; + +procedure TPSImport_Forms.ExecImport1(CompExec: TPSScript; + const ri: TPSRuntimeClassImporter); +begin + if FEnableForms then + RIRegister_Forms(ri); + + if FEnableMenus then + begin + RIRegister_Menus(ri); + RIRegister_Menus_Routines(compexec.Exec); + end; + +end; + +end. diff --git a/Units/PascalScript/uPSComponent_StdCtrls.pas b/Units/PascalScript/uPSComponent_StdCtrls.pas new file mode 100644 index 0000000..9f92923 --- /dev/null +++ b/Units/PascalScript/uPSComponent_StdCtrls.pas @@ -0,0 +1,65 @@ + +unit uPSComponent_StdCtrls; + +interface +uses + SysUtils, Classes, uPSComponent, uPSCompiler, uPSRuntime; +type + + TPSImport_StdCtrls = class(TPSPlugin) + private + FEnableButtons: Boolean; + FEnableExtCtrls: Boolean; + public + procedure CompileImport1(CompExec: TPSScript); override; + procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override; + public + constructor Create(AOwner: TComponent); override; + published + + property EnableExtCtrls: Boolean read FEnableExtCtrls write FEnableExtCtrls; + + property EnableButtons: Boolean read FEnableButtons write FEnableButtons; + end; + + TIFPS3CE_StdCtrls = class(TPSImport_StdCtrls); + + +implementation +uses + uPSC_buttons, + uPSC_stdctrls, + uPSC_extctrls, + uPSR_buttons, + uPSR_stdctrls, + uPSR_extctrls; + +{ TPSImport_StdCtrls } + +procedure TPSImport_StdCtrls.CompileImport1(CompExec: TPSScript); +begin + SIRegister_stdctrls(CompExec.Comp); + if FEnableExtCtrls then + SIRegister_ExtCtrls(CompExec.Comp); + if FEnableButtons then + SIRegister_Buttons(CompExec.Comp); +end; + +constructor TPSImport_StdCtrls.Create(AOwner: TComponent); +begin + inherited Create(Aowner); + FEnableButtons := True; + FEnableExtCtrls := True; +end; + +procedure TPSImport_StdCtrls.ExecImport1(CompExec: TPSScript; + const ri: TPSRuntimeClassImporter); +begin + RIRegister_stdctrls(RI); + if FEnableExtCtrls then + RIRegister_ExtCtrls(RI); + if FEnableButtons then + RIRegister_Buttons(RI); +end; + +end. diff --git a/Units/PascalScript/uPSDebugger.pas b/Units/PascalScript/uPSDebugger.pas new file mode 100644 index 0000000..3b58393 --- /dev/null +++ b/Units/PascalScript/uPSDebugger.pas @@ -0,0 +1,654 @@ + +unit uPSDebugger; +{$I PascalScript.inc} +interface +uses + SysUtils, uPSRuntime, uPSUtils; + +type + + TDebugMode = (dmRun + , dmStepOver + , dmStepInto + , dmPaused + ); + + TPSCustomDebugExec = class(TPSExec) + protected + FDebugDataForProcs: TIfList; + FLastProc: TPSProcRec; + FCurrentDebugProc: Pointer; + FProcNames: TIFStringList; + FGlobalVarNames: TIfStringList; + FCurrentSourcePos, FCurrentRow, FCurrentCol: Cardinal; + FCurrentFile: tbtstring; + + function GetCurrentProcParams: TIfStringList; + + function GetCurrentProcVars: TIfStringList; + protected + + procedure ClearDebug; virtual; + public + + function GetCurrentProcNo: Cardinal; + + function GetCurrentPosition: Cardinal; + + function TranslatePosition(Proc, Position: Cardinal): Cardinal; + + function TranslatePositionEx(Proc, Position: Cardinal; var Pos, Row, Col: Cardinal; var Fn: tbtstring): Boolean; + + procedure LoadDebugData(const Data: tbtstring); + + procedure Clear; override; + + property GlobalVarNames: TIfStringList read FGlobalVarNames; + + property ProcNames: TIfStringList read FProcNames; + + property CurrentProcVars: TIfStringList read GetCurrentProcVars; + + property CurrentProcParams: TIfStringList read GetCurrentProcParams; + + function GetGlobalVar(I: Cardinal): PIfVariant; + + function GetProcVar(I: Cardinal): PIfVariant; + + function GetProcParam(I: Cardinal): PIfVariant; + + constructor Create; + + destructor Destroy; override; + end; + TPSDebugExec = class; + + TOnSourceLine = procedure (Sender: TPSDebugExec; const Name: tbtstring; Position, Row, Col: Cardinal); + + TOnIdleCall = procedure (Sender: TPSDebugExec); + + TPSDebugExec = class(TPSCustomDebugExec) + private + FDebugMode: TDebugMode; + FStepOverProc: TPSInternalProcRec; + FStepOverStackBase: Cardinal; + FOnIdleCall: TOnIdleCall; + FOnSourceLine: TOnSourceLine; + FDebugEnabled: Boolean; + protected + + procedure SourceChanged; + procedure ClearDebug; override; + procedure RunLine; override; + public + constructor Create; + + function LoadData(const s: tbtstring): Boolean; override; + + procedure Pause; override; + + procedure Run; + + procedure StepInto; + + procedure StepOver; + + procedure Stop; override; + + property DebugMode: TDebugMode read FDebugMode; + + property OnSourceLine: TOnSourceLine read FOnSourceLine write FOnSourceLine; + + property OnIdleCall: TOnIdleCall read FOnIdleCall write FOnIdleCall; + + property DebugEnabled: Boolean read FDebugEnabled write FDebugEnabled; + end; + TIFPSDebugExec = TPSDebugExec; + +implementation + +{$IFDEF DELPHI3UP } +resourceString +{$ELSE } +const +{$ENDIF } + + RPS_ExpectedReturnAddressStackBase = 'Expected return address at stack base'; + +type + PPositionData = ^TPositionData; + TPositionData = packed record + FileName: tbtstring; + Position, + Row, + Col, + SourcePosition: Cardinal; + end; + PFunctionInfo = ^TFunctionInfo; + TFunctionInfo = packed record + Func: TPSProcRec; + FParamNames: TIfStringList; + FVariableNames: TIfStringList; + FPositionTable: TIfList; + end; + +{ TPSCustomDebugExec } + +procedure TPSCustomDebugExec.Clear; +begin + inherited Clear; + if FGlobalVarNames <> nil then ClearDebug; +end; + +procedure TPSCustomDebugExec.ClearDebug; +var + i, j: Longint; + p: PFunctionInfo; +begin + FCurrentDebugProc := nil; + FLastProc := nil; + FProcNames.Clear; + FGlobalVarNames.Clear; + FCurrentSourcePos := 0; + FCurrentRow := 0; + FCurrentCol := 0; + FCurrentFile := ''; + for i := 0 to FDebugDataForProcs.Count -1 do + begin + p := FDebugDataForProcs[I]; + for j := 0 to p^.FPositionTable.Count -1 do + begin + Dispose(PPositionData(P^.FPositionTable[J])); + end; + p^.FPositionTable.Free; + p^.FParamNames.Free; + p^.FVariableNames.Free; + Dispose(p); + end; + FDebugDataForProcs.Clear; +end; + +constructor TPSCustomDebugExec.Create; +begin + inherited Create; + FCurrentSourcePos := 0; + FCurrentRow := 0; + FCurrentCol := 0; + FCurrentFile := ''; + FDebugDataForProcs := TIfList.Create; + FLastProc := nil; + FCurrentDebugProc := nil; + FProcNames := TIFStringList.Create; + FGlobalVarNames := TIfStringList.Create; +end; + +destructor TPSCustomDebugExec.Destroy; +begin + Clear; + FDebugDataForProcs.Free; + FProcNames.Free; + FGlobalVarNames.Free; + FGlobalVarNames := nil; + inherited Destroy; +end; + +function TPSCustomDebugExec.GetCurrentPosition: Cardinal; +begin + Result := TranslatePosition(GetCurrentProcNo, 0); +end; + +function TPSCustomDebugExec.GetCurrentProcNo: Cardinal; +var + i: Longint; +begin + for i := 0 to FProcs.Count -1 do + begin + if FProcs[i]= FCurrProc then + begin + Result := I; + Exit; + end; + end; + Result := Cardinal(-1); +end; + +function TPSCustomDebugExec.GetCurrentProcParams: TIfStringList; +begin + if FCurrentDebugProc <> nil then + begin + Result := PFunctionInfo(FCurrentDebugProc)^.FParamNames; + end else Result := nil; +end; + +function TPSCustomDebugExec.GetCurrentProcVars: TIfStringList; +begin + if FCurrentDebugProc <> nil then + begin + Result := PFunctionInfo(FCurrentDebugProc)^.FVariableNames; + end else Result := nil; +end; + +function TPSCustomDebugExec.GetGlobalVar(I: Cardinal): PIfVariant; +begin + Result := FGlobalVars[I]; +end; + +function TPSCustomDebugExec.GetProcParam(I: Cardinal): PIfVariant; +begin + Result := FStack[Cardinal(Longint(FCurrStackBase) - Longint(I) - 1)]; +end; + +function TPSCustomDebugExec.GetProcVar(I: Cardinal): PIfVariant; +begin + Result := FStack[Cardinal(Longint(FCurrStackBase) + Longint(I) + 1)]; +end; + +function GetProcDebugInfo(FProcs: TIFList; Proc: TPSProcRec): PFunctionInfo; +var + i: Longint; + c: PFunctionInfo; +begin + if Proc = nil then + begin + Result := nil; + exit; + end; + for i := FProcs.Count -1 downto 0 do + begin + c := FProcs.Data^[I]; + if c^.Func = Proc then + begin + Result := c; + exit; + end; + end; + new(c); + c^.Func := Proc; + c^.FPositionTable := TIfList.Create; + c^.FVariableNames := TIfStringList.Create; + c^.FParamNames := TIfStringList.Create; + FProcs.Add(c); + REsult := c; +end; + +procedure TPSCustomDebugExec.LoadDebugData(const Data: tbtstring); +var + CP, I: Longint; + c: tbtchar; + CurrProcNo, LastProcNo: Cardinal; + LastProc: PFunctionInfo; + NewLoc: PPositionData; + s: tbtstring; +begin + ClearDebug; + if FStatus = isNotLoaded then exit; + CP := 1; + LastProcNo := Cardinal(-1); + LastProc := nil; + while CP <= length(Data) do + begin + c := Data[CP]; + inc(cp); + case c of + #0: + begin + i := cp; + if i > length(data) then exit; + while Data[i] <> #0 do + begin + if Data[i] = #1 then + begin + FProcNames.Add(Copy(Data, cp, i-cp)); + cp := I + 1; + end; + inc(I); + if I > length(data) then exit; + end; + cp := i + 1; + end; + #1: + begin + i := cp; + if i > length(data) then exit; + while Data[i] <> #0 do + begin + if Data[i] = #1 then + begin + FGlobalVarNames.Add(Copy(Data, cp, i-cp)); + cp := I + 1; + end; + inc(I); + if I > length(data) then exit; + end; + cp := i + 1; + end; + #2: + begin + if cp + 4 > Length(data) then exit; + CurrProcNo := Cardinal((@Data[cp])^); + if CurrProcNo = Cardinal(-1) then Exit; + if CurrProcNo <> LastProcNo then + begin + LastProcNo := CurrProcNo; + LastProc := GetProcDebugInfo(FDebugDataForProcs, FProcs[CurrProcNo]); + if LastProc = nil then exit; + end; + inc(cp, 4); + + i := cp; + if i > length(data) then exit; + while Data[i] <> #0 do + begin + if Data[i] = #1 then + begin + LastProc^.FParamNames.Add(Copy(Data, cp, i-cp)); + cp := I + 1; + end; + inc(I); + if I > length(data) then exit; + end; + cp := i + 1; + end; + #3: + begin + if cp + 4 > Length(data) then exit; + CurrProcNo := Cardinal((@Data[cp])^); + if CurrProcNo = Cardinal(-1) then Exit; + if CurrProcNo <> LastProcNo then + begin + LastProcNo := CurrProcNo; + LastProc := GetProcDebugInfo(FDebugDataForProcs, FProcs[CurrProcNo]); + if LastProc = nil then exit; + end; + inc(cp, 4); + + i := cp; + if i > length(data) then exit; + while Data[i] <> #0 do + begin + if Data[i] = #1 then + begin + LastProc^.FVariableNames.Add(Copy(Data, cp, i-cp)); + cp := I + 1; + end; + inc(I); + if I > length(data) then exit; + end; + cp := i + 1; + end; + #4: + begin + i := cp; + if i > length(data) then exit; + while Data[i] <> #0 do + begin + if Data[i] = #1 then + begin + s := Copy(Data, cp, i-cp); + cp := I + 1; + Break; + end; + inc(I); + if I > length(data) then exit; + end; + if cp + 4 > Length(data) then exit; + CurrProcNo := Cardinal((@Data[cp])^); + if CurrProcNo = Cardinal(-1) then Exit; + if CurrProcNo <> LastProcNo then + begin + LastProcNo := CurrProcNo; + LastProc := GetProcDebugInfo(FDebugDataForProcs, FProcs[CurrProcNo]); + if LastProc = nil then exit; + end; + inc(cp, 4); + if cp + 16 > Length(data) then exit; + new(NewLoc); + NewLoc^.Position := Cardinal((@Data[Cp])^); + NewLoc^.FileName := s; + NewLoc^.SourcePosition := Cardinal((@Data[Cp+4])^); + NewLoc^.Row := Cardinal((@Data[Cp+8])^); + NewLoc^.Col := Cardinal((@Data[Cp+12])^); + inc(cp, 16); + LastProc^.FPositionTable.Add(NewLoc); + end; + else + begin + ClearDebug; + Exit; + end; + end; + + end; +end; + + + + + + +function TPSCustomDebugExec.TranslatePosition(Proc, Position: Cardinal): Cardinal; +var + D1, D2: Cardinal; + s: tbtstring; +begin + if not TranslatePositionEx(Proc, Position, Result, D1, D2, s) then + Result := 0; +end; + +function TPSCustomDebugExec.TranslatePositionEx(Proc, Position: Cardinal; + var Pos, Row, Col: Cardinal; var Fn: tbtstring): Boolean; +// Made by Martijn Laan (mlaan@wintax.nl) +var + i: LongInt; + fi: PFunctionInfo; + pt: TIfList; + r: PPositionData; + lastfn: tbtstring; + LastPos, LastRow, LastCol: Cardinal; + pp: TPSProcRec; +begin + fi := nil; + pp := FProcs[Proc]; + for i := 0 to FDebugDataForProcs.Count -1 do + begin + fi := FDebugDataForProcs[i]; + if fi^.Func = pp then + Break; + fi := nil; + end; + LastPos := 0; + LastRow := 0; + LastCol := 0; + if fi <> nil then begin + pt := fi^.FPositionTable; + for i := 0 to pt.Count -1 do + begin + r := pt[I]; + if r^.Position >= Position then + begin + if r^.Position = Position then + begin + Pos := r^.SourcePosition; + Row := r^.Row; + Col := r^.Col; + Fn := r^.Filename; + end + else + begin + Pos := LastPos; + Row := LastRow; + Col := LastCol; + Fn := LastFn; + end; + Result := True; + exit; + end else + begin + LastPos := r^.SourcePosition; + LastRow := r^.Row; + LastCol := r^.Col; + LastFn := r^.FileName; + end; + end; + Pos := LastPos; + Row := LastRow; + Col := LastCol; + Result := True; + end else + begin + Result := False; + end; +end; + +{ TPSDebugExec } +procedure TPSDebugExec.ClearDebug; +begin + inherited; + FDebugMode := dmRun; +end; + +function TPSDebugExec.LoadData(const s: tbtstring): Boolean; +begin + Result := inherited LoadData(s); + FDebugMode := dmRun; +end; + +procedure TPSDebugExec.RunLine; +var + i: Longint; + pt: TIfList; + r: PPositionData; +begin + inherited RunLine; + if not DebugEnabled then exit; + if FCurrProc <> FLastProc then + begin + FLastProc := FCurrProc; + FCurrentDebugProc := nil; + for i := 0 to FDebugDataForProcs.Count -1 do + begin + if PFunctionInfo(FDebugDataForProcs[I])^.Func = FLastProc then + begin + FCurrentDebugProc := FDebugDataForProcs[I]; + break; + end; + end; + end; + if FCurrentDebugProc <> nil then + begin + pt := PFunctionInfo(FCurrentDebugProc)^.FPositionTable; + for i := 0 to pt.Count -1 do + begin + r := pt[I]; + if r^.Position = FCurrentPosition then + begin + FCurrentSourcePos := r^.SourcePosition; + FCurrentRow := r^.Row; + FCurrentCol := r^.Col; + FCurrentFile := r^.FileName; + SourceChanged; + break; + end; + end; + end else + begin + FCurrentSourcePos := 0; + FCurrentRow := 0; + FCurrentCol := 0; + FCurrentFile := ''; + end; + while FDebugMode = dmPaused do + begin + if @FOnIdleCall <> nil then + begin + FOnIdleCall(Self); + end else break; // endless loop + end; +end; + + +procedure TPSDebugExec.SourceChanged; + + function StepOverShouldPause: Boolean; + var + I: Cardinal; + V: PPSVariant; + begin + if (FCurrProc <> FStepOverProc) or (FCurrStackBase <> FStepOverStackBase) then + begin + { We're not inside the function being stepped, so scan the call stack to + see if we're inside a function called by the function being stepped } + I := FCurrStackBase; + while Longint(I) > Longint(FStepOverStackBase) do + begin + V := FStack.Items[I]; + if (V = nil) or (V.FType <> FReturnAddressType) then + raise Exception.Create(RPS_ExpectedReturnAddressStackBase); + if (PPSVariantReturnAddress(V).Addr.ProcNo = FStepOverProc) and + (PPSVariantReturnAddress(V).Addr.StackBase = FStepOverStackBase) then + begin + { We are, so don't pause } + Result := False; + Exit; + end; + I := PPSVariantReturnAddress(V).Addr.StackBase; + end; + end; + Result := True; + end; + +begin + case FDebugMode of + dmStepInto: + begin + FDebugMode := dmPaused; + end; + dmStepOver: + begin + if StepOverShouldPause then + begin + FDebugMode := dmPaused; + end; + end; + end; + if @FOnSourceLine <> nil then + FOnSourceLine(Self, FCurrentFile, FCurrentSourcePos, FCurrentRow, FCurrentCol); +end; + + +procedure TPSDebugExec.Pause; +begin + FDebugMode := dmPaused; +end; + +procedure TPSDebugExec.Stop; +begin + FDebugMode := dmRun; + inherited Stop; +end; + +procedure TPSDebugExec.Run; +begin + FDebugMode := dmRun; +end; + +procedure TPSDebugExec.StepInto; +begin + FDebugMode := dmStepInto; +end; + +procedure TPSDebugExec.StepOver; +begin + FStepOverProc := FCurrProc; + FStepOverStackBase := FCurrStackBase; + FDebugMode := dmStepOver; +end; + + +constructor TPSDebugExec.Create; +begin + inherited Create; + FDebugEnabled := True; +end; + +end. diff --git a/Units/PascalScript/uPSDisassembly.pas b/Units/PascalScript/uPSDisassembly.pas new file mode 100644 index 0000000..5e19d71 --- /dev/null +++ b/Units/PascalScript/uPSDisassembly.pas @@ -0,0 +1,499 @@ + + +unit uPSDisassembly; +{$I PascalScript.inc} + +interface +uses + uPSRuntime, uPSUtils, sysutils; + +function IFPS3DataToText(const Input: tbtstring; var Output: string): Boolean; +implementation + +type + TMyPSExec = class(TPSExec) + function ImportProc(const Name: ShortString; proc: TIFExternalProcRec): Boolean; override; + end; + +function Debug2Str(const s: string): string; +var + i: Integer; +begin + result := ''; + for i := 1 to length(s) do + begin + if (s[i] < #32) or (s[i] > #128) then + result := result + '\'+inttohex(ord(s[i]), 2) + else if s[i] = '\' then + result := result + '\\' + else + result := result + s[i]; + end; + +end; + +function SpecImportProc(Sender: TObject; p: TIFExternalProcRec): Boolean; forward; + +function FloatToStr(Value: Extended): string; +begin + try + Result := SysUtils.FloatToStr(Value); + except + Result := 'NaNa'; + end; +end; + + +function IFPS3DataToText(const Input: tbtstring; var Output: string): Boolean; +var + I: TMyPSExec; + + procedure Writeln(const s: string); + begin + Output := Output + s + #13#10; + end; + function BT2S(P: PIFTypeRec): string; + var + i: Longint; + begin + case p.BaseType of + btU8: Result := 'U8'; + btS8: Result := 'S8'; + btU16: Result := 'U16'; + btS16: Result := 'S16'; + btU32: Result := 'U32'; + btS32: Result := 'S32'; + {$IFNDEF PS_NOINT64}bts64: Result := 'S64'; {$ENDIF} + btChar: Result := {$IFDEF UNICODE}'AnsiChar'{$ELSE}'Char'{$ENDIF}; + {$IFNDEF PS_NOWIDESTRING} + btWideChar: Result := 'WideChar'; + btWideString: Result := 'WideString'; + {$ENDIF} + btSet: Result := 'Set'; + btSingle: Result := 'Single'; + btDouble: Result := 'Double'; + btExtended: Result := 'Extended'; + btString: Result := 'String'; + btRecord: + begin + Result := 'Record('; + for i := 0 to TPSTypeRec_Record(p).FieldTypes.Count-1 do + begin + if i <> 0 then Result := Result+','; + Result := Result + BT2S(PIFTypeRec(TPSTypeRec_Record(p).FieldTypes[i])); + end; + Result := Result + ')'; + end; + btArray: Result := 'Array of '+BT2S(TPSTypeRec_Array(p).ArrayType); + btResourcePointer: Result := 'ResourcePointer'; + btPointer: Result := 'Pointer'; + btVariant: Result := 'Variant'; + btClass: Result := 'Class'; + btProcPtr: Result := 'ProcPtr'; + btStaticArray: Result := 'StaticArray['+inttostR(TPSTypeRec_StaticArray(p).Size)+'] of '+BT2S(TPSTypeRec_Array(p).ArrayType); + else + Result := 'Unknown '+inttostr(p.BaseType); + end; + end; + procedure WriteTypes; + var + T: Longint; + begin + Writeln('[TYPES]'); + for T := 0 to i.FTypes.Count -1 do + begin + if PIFTypeRec(i.FTypes[t]).ExportName <> '' then + Writeln('Type ['+inttostr(t)+']: '+bt2s(PIFTypeRec(i.FTypes[t]))+' Export: '+PIFTypeRec(i.FTypes[t]).ExportName) + else + Writeln('Type ['+inttostr(t)+']: '+bt2s(PIFTypeRec(i.FTypes[t]))); + end; + end; + procedure WriteVars; + var + T: Longint; + function FindType(p: Pointer): Cardinal; + var + T: Longint; + begin + Result := Cardinal(-1); + for T := 0 to i.FTypes.Count -1 do + begin + if p = i.FTypes[t] then begin + result := t; + exit; + end; + end; + end; + begin + Writeln('[VARS]'); + for t := 0 to i.FGlobalVars.count -1 do + begin + Writeln('Var ['+inttostr(t)+']: '+ IntToStr(FindType(PIFVariant(i.FGlobalVars[t])^.FType)) + ' '+ bt2s(PIFVariant(i.FGlobalVars[t])^.Ftype) + ' '+ PIFVariant(i.FGlobalVars[t])^.Ftype.ExportName); + end; + end; + + procedure WriteProcs; + var + t: Longint; + procedure WriteProc(proc: TPSProcRec); + var + sc, CP: Cardinal; + function ReadData(var Data; Len: Cardinal): Boolean; + begin + if CP + Len <= TPSInternalProcRec(PROC).Length then begin + Move(TPSInternalProcRec(Proc).Data[CP], Data, Len); + CP := CP + Len; + Result := True; + end else Result := False; + end; + function ReadByte(var B: Byte): Boolean; + begin + if CP < TPSInternalProcRec(Proc).Length then begin + b := TPSInternalProcRec(Proc).Data^[cp]; + Inc(CP); + Result := True; + end else Result := False; + end; + + function ReadLong(var B: Cardinal): Boolean; + begin + if CP + 3 < TPSInternalProcRec(Proc).Length then begin + b := Cardinal((@TPSInternalProcRec(Proc).Data[CP])^); + Inc(CP, 4); + Result := True; + end else Result := False; + end; + function ReadWriteVariable: string; + var + VarType: byte; + L1, L2: Cardinal; + function ReadVar(FType: Cardinal): string; + var + F: PIFTypeRec; + b: byte; + w: word; + l: Cardinal; + {$IFNDEF PS_NOINT64}ff: Int64;{$ENDIF} + e: extended; + ss: single; + d: double; + s: ansistring; + c: char; + {$IFNDEF PS_NOWIDESTRING} + wc: WideChar; + ws: WideString; + {$ENDIF} + + begin + result := ''; + F:= i.FTypes[Ftype]; + if f = nil then exit; + case f.BaseType of + btProcPtr: begin if not ReadData(l, 4) then exit; Result := 'PROC: '+inttostr(l); end; + btU8: begin if not ReadData(b, 1) then exit; Result := IntToStr(tbtu8(B)); end; + btS8: begin if not ReadData(b, 1) then exit; Result := IntToStr(tbts8(B)); end; + btU16: begin if not ReadData(w, 2) then exit; Result := IntToStr(tbtu16(w)); end; + btS16: begin if not ReadData(w, 2) then exit; Result := IntToStr(tbts16(w)); end; + btU32: begin if not ReadData(l, 4) then exit; Result := IntToStr(tbtu32(l)); end; + btS32: begin if not ReadData(l, 4) then exit; Result := IntToStr(tbts32(l)); end; + {$IFNDEF PS_NOINT64}bts64: begin if not ReadData(ff, 8) then exit; Result := IntToStr(ff); end;{$ENDIF} + btSingle: begin if not ReadData(ss, Sizeof(tbtsingle)) then exit; Result := FloatToStr(ss); end; + btDouble: begin if not ReadData(d, Sizeof(tbtdouble)) then exit; Result := FloatToStr(d); end; + btExtended: begin if not ReadData(e, Sizeof(tbtextended)) then exit; Result := FloatToStr(e); end; + btPChar, btString: begin if not ReadData(l, 4) then exit; SetLength(s, l); if not readData(s[1], l) then exit; Result := MakeString(s); end; + btSet: + begin + SetLength(s, TPSTypeRec_Set(f).aByteSize); + if not ReadData(s[1], length(s)) then exit; + result := MakeString(s); + + end; + btChar: begin if not ReadData(c, 1) then exit; Result := '#'+IntToStr(ord(c)); end; + {$IFNDEF PS_NOWIDESTRING} + btWideChar: begin if not ReadData(wc, 2) then exit; Result := '#'+IntToStr(ord(wc)); end; + btWideString: begin if not ReadData(l, 4) then exit; SetLength(ws, l); if not readData(ws[1], l*2) then exit; Result := MakeWString(ws); end; + {$ENDIF} + end; + end; + function AddressToStr(a: Cardinal): String; + begin + if a < PSAddrNegativeStackStart then + Result := 'GlobalVar['+inttostr(a)+']' + else + Result := 'Base['+inttostr(Longint(A-PSAddrStackStart))+']'; + end; + + begin + Result := ''; + if not ReadByte(VarType) then Exit; + case VarType of + 0: + begin + + if not ReadLong(L1) then Exit; + Result := AddressToStr(L1); + end; + 1: + begin + if not ReadLong(L1) then Exit; + Result := '['+ReadVar(l1)+']'; + end; + 2: + begin + if not ReadLong(L1) then Exit; + if not ReadLong(L2) then Exit; + Result := AddressToStr(L1)+'.['+inttostr(l2)+']'; + end; + 3: + begin + if not ReadLong(l1) then Exit; + if not ReadLong(l2) then Exit; + Result := AddressToStr(L1)+'.'+AddressToStr(l2); + end; + end; + end; + + var + b: Byte; + s: string; + DP, D1, D2, d3, d4: Cardinal; + + begin + CP := 0; + sc := 0; + while true do + begin + DP := cp; + if not ReadByte(b) then Exit; + case b of + CM_A: + begin + {$IFDEF FPC} + Output := Output + ' ['+inttostr(dp)+'] ASSIGN '+ ReadWriteVariable; + Output := Output + ', ' + ReadWriteVariable + #13#10; + {$ELSE} + Writeln(' ['+inttostr(dp)+'] ASSIGN '+ReadWriteVariable+ ', ' + ReadWriteVariable); + {$ENDIF} + end; + CM_CA: + begin + if not ReadByte(b) then exit; + case b of + 0: s:= '+'; + 1: s := '-'; + 2: s := '*'; + 3: s:= '/'; + 4: s:= 'MOD'; + 5: s:= 'SHL'; + 6: s:= 'SHR'; + 7: s:= 'AND'; + 8: s:= 'OR'; + 9: s:= 'XOR'; + else + exit; + end; + Writeln(' ['+inttostr(dp)+'] CALC '+ReadWriteVariable+ ' '+s+' ' + ReadWriteVariable); + end; + CM_P: + begin + Inc(sc); + Writeln(' ['+inttostr(dp)+'] PUSH '+ReadWriteVariable + ' // '+inttostr(sc)); + end; + CM_PV: + begin + Inc(sc); + Writeln(' ['+inttostr(dp)+'] PUSHVAR '+ReadWriteVariable + ' // '+inttostr(sc)); + end; + CM_PO: + begin + Dec(Sc); + Writeln(' ['+inttostr(dp)+'] POP // '+inttostr(sc)); + end; + Cm_C: + begin + if not ReadLong(D1) then exit; + Writeln(' ['+inttostr(dp)+'] CALL '+inttostr(d1)); + end; + Cm_PG: + begin + if not ReadLong(D1) then exit; + Writeln(' ['+inttostr(dp)+'] POP/GOTO currpos + '+IntToStr(d1)+' ['+IntToStr(CP+d1)+']'); + end; + Cm_P2G: + begin + if not ReadLong(D1) then exit; + Writeln(' ['+inttostr(dp)+'] POP2/GOTO currpos + '+IntToStr(d1)+' ['+IntToStr(CP+d1)+']'); + end; + Cm_G: + begin + if not ReadLong(D1) then exit; + Writeln(' ['+inttostr(dp)+'] GOTO currpos + '+IntToStr(d1)+' ['+IntToStr(CP+d1)+']'); + end; + Cm_CG: + begin + if not ReadLong(D1) then exit; + Writeln(' ['+inttostr(dp)+'] COND_GOTO currpos + '+IntToStr(d1)+' '+ReadWriteVariable+' ['+IntToStr(CP+d1)+']'); + end; + Cm_CNG: + begin + if not ReadLong(D1) then exit; + Writeln(' ['+inttostr(dp)+'] COND_NOT_GOTO currpos + '+IntToStr(d1)+' '+ReadWriteVariable+' ['+IntToStr(CP+d1)+']'); + end; + Cm_R: Writeln(' ['+inttostr(dp)+'] RET'); + Cm_ST: + begin + if not ReadLong(d1) or not readLong(d2) then exit; + Writeln(' ['+inttostr(dp)+'] SETSTACKTYPE Base['+inttostr(d1)+'] '+inttostr(d2)); + end; + Cm_Pt: + begin + Inc(sc); + if not ReadLong(D1) then exit; + Writeln(' ['+inttostr(dp)+'] PUSHTYPE '+inttostr(d1) + '('+BT2S(TPSTypeRec(I.FTypes[d1]))+') // '+inttostr(sc)); + end; + CM_CO: + begin + if not readByte(b) then exit; + case b of + 0: s := '>='; + 1: s := '<='; + 2: s := '>'; + 3: s := '<'; + 4: s := '<>'; + 5: s := '='; + else exit; + end; + Writeln(' ['+inttostr(dp)+'] COMPARE into '+ReadWriteVariable+': '+ReadWriteVariable+' '+s+' '+ReadWriteVariable); + end; + Cm_cv: + begin + Writeln(' ['+inttostr(dp)+'] CALLVAR '+ReadWriteVariable); + end; + Cm_inc: + begin + Writeln(' ['+inttostr(dp)+'] INC '+ReadWriteVariable); + end; + Cm_dec: + begin + Writeln(' ['+inttostr(dp)+'] DEC '+ReadWriteVariable); + end; + cm_sp: + begin + Writeln(' ['+inttostr(dp)+'] SETPOINTER '+ReadWriteVariable+': '+ReadWriteVariable); + end; + cm_spc: + begin + Writeln(' ['+inttostr(dp)+'] SETCOPYPOINTER '+ReadWriteVariable+': '+ReadWriteVariable); + end; + cm_in: + begin + Writeln(' ['+inttostr(dp)+'] INOT '+ReadWriteVariable); + end; + cm_bn: + begin + Writeln(' ['+inttostr(dp)+'] BNOT '+ReadWriteVariable); + end; + cm_vm: + begin + Writeln(' ['+inttostr(dp)+'] MINUS '+ReadWriteVariable); + end; + cm_sf: + begin + s := ReadWriteVariable; + if not ReadByte(b) then exit; + if b = 0 then + Writeln(' ['+inttostr(dp)+'] SETFLAG '+s) + else + Writeln(' ['+inttostr(dp)+'] SETFLAG NOT '+s); + end; + cm_fg: + begin + if not ReadLong(D1) then exit; + Writeln(' ['+inttostr(dp)+'] FLAGGOTO currpos + '+IntToStr(d1)+' ['+IntToStr(CP+d1)+']'); + end; + cm_puexh: + begin + if not ReadLong(D1) then exit; + if not ReadLong(D2) then exit; + if not ReadLong(D3) then exit; + if not ReadLong(D4) then exit; + Writeln(' ['+inttostr(dp)+'] PUSHEXCEPTION '+inttostr(d1)+' '+inttostr(d2)+' '+inttostr(d3)+' '+inttostr(d4)); + end; + cm_poexh: + begin + if not ReadByte(b) then exit; + Writeln(' ['+inttostr(dp)+'] POPEXCEPTION '+inttostr(b)); + end; + else + begin + Writeln(' Disasm Error'); + Break; + end; + end; + end; + end; + + begin + Writeln('[PROCS]'); + for t := 0 to i.FProcs.Count -1 do + begin + if TPSProcRec(i.FProcs[t]).ClassType = TIFExternalProcRec then + begin + if TPSExternalProcRec(i.FProcs[t]). Decl = '' then + Writeln('Proc ['+inttostr(t)+']: External: '+TPSExternalProcRec(i.FProcs[t]).Name) + else + Writeln('Proc ['+inttostr(t)+']: External Decl: '+Debug2Str(TIFExternalProcRec(i.FProcs[t]).Decl) + ' ' + TIFExternalProcRec(i.FProcs[t]).Name); + end else begin + if TPSInternalProcRec(i.FProcs[t]).ExportName <> '' then + begin + Writeln('Proc ['+inttostr(t)+'] Export: '+TPSInternalProcRec(i.FProcs[t]).ExportName+' '+TPSInternalProcRec(i.FProcs[t]).ExportDecl); + end else + Writeln('Proc ['+inttostr(t)+']'); + Writeproc(i.FProcs[t]); + end; + end; + end; + +begin + Result := False; + try + I := TMyPSExec.Create; + I.AddSpecialProcImport('', @SpecImportProc, nil); + + if not I.LoadData(Input) then begin + I.Free; + Exit; + end; + Output := ''; + WriteTypes; + WriteVars; + WriteProcs; + I.Free; + except + exit; + end; + result := true; +end; + +{ TMyIFPSExec } + +function MyDummyProc(Caller: TPSExec; p: TIFExternalProcRec; Global, Stack: TPSStack): Boolean; +begin + Result := False; +end; + + +function TMyPSExec.ImportProc(const Name: ShortString; + proc: TIFExternalProcRec): Boolean; +begin + Proc.ProcPtr := MyDummyProc; + result := true; +end; + +function SpecImportProc(Sender: TObject; p: TIFExternalProcRec): Boolean; +begin + p.ProcPtr := MyDummyProc; + Result := True; +end; + +end. diff --git a/Units/PascalScript/uPSI_Dialogs.pas b/Units/PascalScript/uPSI_Dialogs.pas new file mode 100644 index 0000000..d93f226 --- /dev/null +++ b/Units/PascalScript/uPSI_Dialogs.pas @@ -0,0 +1,741 @@ +unit uPSI_Dialogs; +{ +This file has been generated by UnitParser v0.5, written by M. Knight +and updated by NP. v/d Spek. +Source Code from Carlo Kok has been used to implement various sections of +UnitParser. Components of ifps3 are used in the construction of UnitParser, +code implementing the class wrapper is taken from Carlo Kok''s conv unility +} +interface + +uses + SysUtils, Classes, uPSComponent, uPSCompiler, uPSRuntime; + +type +(*----------------------------------------------------------------------------*) + TPSImport_Dialogs = class(TPSPlugin) + protected + procedure CompOnUses(CompExec: TPSScript); override; + procedure ExecOnUses(CompExec: TPSScript); override; + procedure CompileImport1(CompExec: TPSScript); override; + procedure CompileImport2(CompExec: TPSScript); override; + procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override; + procedure ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override; + end; + +implementation + +uses + Windows ,Messages ,CommDlg ,Graphics ,Controls ,Forms ,StdCtrls ,Dialogs; + +(* === compile-time registration functions === *) +(*----------------------------------------------------------------------------*) +procedure SIRegister_TReplaceDialog(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TFindDialog', 'TReplaceDialog') do + with CL.AddClassN(CL.FindClass('TFindDialog'),'TReplaceDialog') do + begin + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TFindDialog(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TCommonDialog', 'TFindDialog') do + with CL.AddClassN(CL.FindClass('TCommonDialog'),'TFindDialog') do + begin + RegisterMethod('Procedure CloseDialog'); + RegisterProperty('Left', 'Integer', iptrw); + RegisterProperty('Position', 'TPoint', iptrw); + RegisterProperty('Top', 'Integer', iptrw); + RegisterProperty('FindText', 'string', iptrw); + RegisterProperty('Options', 'TFindOptions', iptrw); + RegisterProperty('OnFind', 'TNotifyEvent', iptrw); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TPrintDialog(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TCommonDialog', 'TPrintDialog') do + with CL.AddClassN(CL.FindClass('TCommonDialog'),'TPrintDialog') do + begin + RegisterProperty('Collate', 'Boolean', iptrw); + RegisterProperty('Copies', 'Integer', iptrw); + RegisterProperty('FromPage', 'Integer', iptrw); + RegisterProperty('MinPage', 'Integer', iptrw); + RegisterProperty('MaxPage', 'Integer', iptrw); + RegisterProperty('Options', 'TPrintDialogOptions', iptrw); + RegisterProperty('PrintToFile', 'Boolean', iptrw); + RegisterProperty('PrintRange', 'TPrintRange', iptrw); + RegisterProperty('ToPage', 'Integer', iptrw); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TPrinterSetupDialog(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TCommonDialog', 'TPrinterSetupDialog') do + with CL.AddClassN(CL.FindClass('TCommonDialog'),'TPrinterSetupDialog') do + begin + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TFontDialog(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TCommonDialog', 'TFontDialog') do + with CL.AddClassN(CL.FindClass('TCommonDialog'),'TFontDialog') do + begin + RegisterProperty('Font', 'TFont', iptrw); + RegisterProperty('Device', 'TFontDialogDevice', iptrw); + RegisterProperty('MinFontSize', 'Integer', iptrw); + RegisterProperty('MaxFontSize', 'Integer', iptrw); + RegisterProperty('Options', 'TFontDialogOptions', iptrw); + RegisterProperty('OnApply', 'TFDApplyEvent', iptrw); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TColorDialog(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TCommonDialog', 'TColorDialog') do + with CL.AddClassN(CL.FindClass('TCommonDialog'),'TColorDialog') do + begin + RegisterProperty('Color', 'TColor', iptrw); + RegisterProperty('CustomColors', 'TStrings', iptrw); + RegisterProperty('Options', 'TColorDialogOptions', iptrw); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TSaveDialog(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TOpenDialog', 'TSaveDialog') do + with CL.AddClassN(CL.FindClass('TOpenDialog'),'TSaveDialog') do + begin + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TOpenDialog(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TCommonDialog', 'TOpenDialog') do + with CL.AddClassN(CL.FindClass('TCommonDialog'),'TOpenDialog') do + begin + RegisterProperty('FileEditStyle', 'TFileEditStyle', iptrw); + RegisterProperty('Files', 'TStrings', iptr); + RegisterProperty('HistoryList', 'TStrings', iptrw); + RegisterProperty('DefaultExt', 'string', iptrw); + RegisterProperty('FileName', 'TFileName', iptrw); + RegisterProperty('Filter', 'string', iptrw); + RegisterProperty('FilterIndex', 'Integer', iptrw); + RegisterProperty('InitialDir', 'string', iptrw); + RegisterProperty('Options', 'TOpenOptions', iptrw); + RegisterProperty('Title', 'string', iptrw); + RegisterProperty('OnCanClose', 'TCloseQueryEvent', iptrw); + RegisterProperty('OnFolderChange', 'TNotifyEvent', iptrw); + RegisterProperty('OnSelectionChange', 'TNotifyEvent', iptrw); + RegisterProperty('OnTypeChange', 'TNotifyEvent', iptrw); + RegisterProperty('OnIncludeItem', 'TIncludeItemEvent', iptrw); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TCommonDialog(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TComponent', 'TCommonDialog') do + with CL.AddClassN(CL.FindClass('TComponent'),'TCommonDialog') do + begin + RegisterProperty('Handle', 'HWnd', iptr); + RegisterProperty('Ctl3D', 'Boolean', iptrw); + RegisterProperty('HelpContext', 'THelpContext', iptrw); + RegisterProperty('OnClose', 'TNotifyEvent', iptrw); + RegisterProperty('OnShow', 'TNotifyEvent', iptrw); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_Dialogs(CL: TPSPascalCompiler); +begin + CL.AddConstantN('MaxCustomColors','LongInt').SetInt( 16); + SIRegister_TCommonDialog(CL); + CL.AddTypeS('TOpenOption', '( ofReadOnly, ofOverwritePrompt, ofHideReadOnly, ' + +'ofNoChangeDir, ofShowHelp, ofNoValidate, ofAllowMultiSelect, ofExtensionDi' + +'fferent, ofPathMustExist, ofFileMustExist, ofCreatePrompt, ofShareAware, o' + +'fNoReadOnlyReturn, ofNoTestFileCreate, ofNoNetworkButton, ofNoLongNames, o' + +'fOldStyleDialog, ofNoDereferenceLinks, ofEnableIncludeNotify, ofEnableSizi' + +'ng )'); + CL.AddTypeS('TOpenOptions', 'set of TOpenOption'); + CL.AddTypeS('TFileEditStyle', '( fsEdit, fsComboBox )'); + CL.AddTypeS('TIncludeItemEvent', 'Procedure ( const OFN : TOFNotifyEx; var In' + +'clude : Boolean)'); + SIRegister_TOpenDialog(CL); + SIRegister_TSaveDialog(CL); + CL.AddTypeS('TColorDialogOption', '( cdFullOpen, cdPreventFullOpen, cdShowHel' + +'p, cdSolidColor, cdAnyColor )'); + CL.AddTypeS('TColorDialogOptions', 'set of TColorDialogOption'); + SIRegister_TColorDialog(CL); + CL.AddTypeS('TFontDialogOption', '( fdAnsiOnly, fdTrueTypeOnly, fdEffects, fd' + +'FixedPitchOnly, fdForceFontExist, fdNoFaceSel, fdNoOEMFonts, fdNoSimulatio' + +'ns, fdNoSizeSel, fdNoStyleSel, fdNoVectorFonts, fdShowHelp, fdWysiwyg, fdL' + +'imitSize, fdScalableOnly, fdApplyButton )'); + CL.AddTypeS('TFontDialogOptions', 'set of TFontDialogOption'); + CL.AddTypeS('TFontDialogDevice', '( fdScreen, fdPrinter, fdBoth )'); + CL.AddTypeS('TFDApplyEvent', 'Procedure ( Sender : TObject; Wnd : HWND)'); + SIRegister_TFontDialog(CL); + SIRegister_TPrinterSetupDialog(CL); + CL.AddTypeS('TPrintRange', '( prAllPages, prSelection, prPageNums )'); + CL.AddTypeS('TPrintDialogOption', '( poPrintToFile, poPageNums, poSelection, ' + +'poWarning, poHelp, poDisablePrintToFile )'); + CL.AddTypeS('TPrintDialogOptions', 'set of TPrintDialogOption'); + SIRegister_TPrintDialog(CL); + CL.AddTypeS('TFindOption', '( frDown, frFindNext, frHideMatchCase, frHideWhol' + +'eWord, frHideUpDown, frMatchCase, frDisableMatchCase, frDisableUpDown, frD' + +'isableWholeWord, frReplace, frReplaceAll, frWholeWord, frShowHelp )'); + CL.AddTypeS('TFindOptions', 'set of TFindOption'); + SIRegister_TFindDialog(CL); + SIRegister_TReplaceDialog(CL); + CL.AddTypeS('TMsgDlgType', '( mtWarning, mtError, mtInformation, mtConfirmati' + +'on, mtCustom )'); + CL.AddTypeS('TMsgDlgBtn', '( mbYes, mbNo, mbOK, mbCancel, mbAbort, mbRetry, m' + +'bIgnore, mbAll, mbNoToAll, mbYesToAll, mbHelp )'); + CL.AddTypeS('TMsgDlgButtons', 'set of TMsgDlgBtn'); + CL.AddConstantN('mbYesNoCancel','LongInt').Value.ts32 := ord(mbYes) or ord(mbNo) or ord(mbCancel); + CL.AddConstantN('mbOKCancel','LongInt').Value.ts32 := ord(mbOK) or ord(mbCancel); + CL.AddConstantN('mbAbortRetryIgnore','LongInt').Value.ts32 := ord(mbAbort) or ord(mbRetry) or ord(mbIgnore); + CL.AddDelphiFunction('Function CreateMessageDialog( const Msg : string; DlgType : TMsgDlgType; Buttons : TMsgDlgButtons) : TForm'); + CL.AddDelphiFunction('Function MessageDlg( const Msg : string; DlgType : TMsgDlgType; Buttons : TMsgDlgButtons; HelpCtx : Longint) : Integer'); + CL.AddDelphiFunction('Function MessageDlgPos( const Msg : string; DlgType : TMsgDlgType; Buttons : TMsgDlgButtons; HelpCtx : Longint; X, Y : Integer) : Integer'); + CL.AddDelphiFunction('Function MessageDlgPosHelp( const Msg : string; DlgType : TMsgDlgType; Buttons : TMsgDlgButtons; HelpCtx : Longint; X, Y : Integer; const HelpFileName : string) : Integer'); + CL.AddDelphiFunction('Procedure ShowMessage( const Msg : string)'); + CL.AddDelphiFunction('Procedure ShowMessagePos( const Msg : string; X, Y : Integer)'); + CL.AddDelphiFunction('Function InputBox( const ACaption, APrompt, ADefault : string) : string'); + CL.AddDelphiFunction('Function InputQuery( const ACaption, APrompt : string; var Value : string) : Boolean'); +end; + +(* === run-time registration functions === *) +(*----------------------------------------------------------------------------*) +procedure TFindDialogOnFind_W(Self: TFindDialog; const T: TNotifyEvent); +begin Self.OnFind := T; end; + +(*----------------------------------------------------------------------------*) +procedure TFindDialogOnFind_R(Self: TFindDialog; var T: TNotifyEvent); +begin T := Self.OnFind; end; + +(*----------------------------------------------------------------------------*) +procedure TFindDialogOptions_W(Self: TFindDialog; const T: TFindOptions); +begin Self.Options := T; end; + +(*----------------------------------------------------------------------------*) +procedure TFindDialogOptions_R(Self: TFindDialog; var T: TFindOptions); +begin T := Self.Options; end; + +(*----------------------------------------------------------------------------*) +procedure TFindDialogFindText_W(Self: TFindDialog; const T: string); +begin Self.FindText := T; end; + +(*----------------------------------------------------------------------------*) +procedure TFindDialogFindText_R(Self: TFindDialog; var T: string); +begin T := Self.FindText; end; + +(*----------------------------------------------------------------------------*) +procedure TFindDialogTop_W(Self: TFindDialog; const T: Integer); +begin Self.Top := T; end; + +(*----------------------------------------------------------------------------*) +procedure TFindDialogTop_R(Self: TFindDialog; var T: Integer); +begin T := Self.Top; end; + +(*----------------------------------------------------------------------------*) +procedure TFindDialogPosition_W(Self: TFindDialog; const T: TPoint); +begin Self.Position := T; end; + +(*----------------------------------------------------------------------------*) +procedure TFindDialogPosition_R(Self: TFindDialog; var T: TPoint); +begin T := Self.Position; end; + +(*----------------------------------------------------------------------------*) +procedure TFindDialogLeft_W(Self: TFindDialog; const T: Integer); +begin Self.Left := T; end; + +(*----------------------------------------------------------------------------*) +procedure TFindDialogLeft_R(Self: TFindDialog; var T: Integer); +begin T := Self.Left; end; + +(*----------------------------------------------------------------------------*) +procedure TPrintDialogToPage_W(Self: TPrintDialog; const T: Integer); +begin Self.ToPage := T; end; + +(*----------------------------------------------------------------------------*) +procedure TPrintDialogToPage_R(Self: TPrintDialog; var T: Integer); +begin T := Self.ToPage; end; + +(*----------------------------------------------------------------------------*) +procedure TPrintDialogPrintRange_W(Self: TPrintDialog; const T: TPrintRange); +begin Self.PrintRange := T; end; + +(*----------------------------------------------------------------------------*) +procedure TPrintDialogPrintRange_R(Self: TPrintDialog; var T: TPrintRange); +begin T := Self.PrintRange; end; + +(*----------------------------------------------------------------------------*) +procedure TPrintDialogPrintToFile_W(Self: TPrintDialog; const T: Boolean); +begin Self.PrintToFile := T; end; + +(*----------------------------------------------------------------------------*) +procedure TPrintDialogPrintToFile_R(Self: TPrintDialog; var T: Boolean); +begin T := Self.PrintToFile; end; + +(*----------------------------------------------------------------------------*) +procedure TPrintDialogOptions_W(Self: TPrintDialog; const T: TPrintDialogOptions); +begin Self.Options := T; end; + +(*----------------------------------------------------------------------------*) +procedure TPrintDialogOptions_R(Self: TPrintDialog; var T: TPrintDialogOptions); +begin T := Self.Options; end; + +(*----------------------------------------------------------------------------*) +procedure TPrintDialogMaxPage_W(Self: TPrintDialog; const T: Integer); +begin Self.MaxPage := T; end; + +(*----------------------------------------------------------------------------*) +procedure TPrintDialogMaxPage_R(Self: TPrintDialog; var T: Integer); +begin T := Self.MaxPage; end; + +(*----------------------------------------------------------------------------*) +procedure TPrintDialogMinPage_W(Self: TPrintDialog; const T: Integer); +begin Self.MinPage := T; end; + +(*----------------------------------------------------------------------------*) +procedure TPrintDialogMinPage_R(Self: TPrintDialog; var T: Integer); +begin T := Self.MinPage; end; + +(*----------------------------------------------------------------------------*) +procedure TPrintDialogFromPage_W(Self: TPrintDialog; const T: Integer); +begin Self.FromPage := T; end; + +(*----------------------------------------------------------------------------*) +procedure TPrintDialogFromPage_R(Self: TPrintDialog; var T: Integer); +begin T := Self.FromPage; end; + +(*----------------------------------------------------------------------------*) +procedure TPrintDialogCopies_W(Self: TPrintDialog; const T: Integer); +begin Self.Copies := T; end; + +(*----------------------------------------------------------------------------*) +procedure TPrintDialogCopies_R(Self: TPrintDialog; var T: Integer); +begin T := Self.Copies; end; + +(*----------------------------------------------------------------------------*) +procedure TPrintDialogCollate_W(Self: TPrintDialog; const T: Boolean); +begin Self.Collate := T; end; + +(*----------------------------------------------------------------------------*) +procedure TPrintDialogCollate_R(Self: TPrintDialog; var T: Boolean); +begin T := Self.Collate; end; + +(*----------------------------------------------------------------------------*) +procedure TFontDialogOnApply_W(Self: TFontDialog; const T: TFDApplyEvent); +begin Self.OnApply := T; end; + +(*----------------------------------------------------------------------------*) +procedure TFontDialogOnApply_R(Self: TFontDialog; var T: TFDApplyEvent); +begin T := Self.OnApply; end; + +(*----------------------------------------------------------------------------*) +procedure TFontDialogOptions_W(Self: TFontDialog; const T: TFontDialogOptions); +begin Self.Options := T; end; + +(*----------------------------------------------------------------------------*) +procedure TFontDialogOptions_R(Self: TFontDialog; var T: TFontDialogOptions); +begin T := Self.Options; end; + +(*----------------------------------------------------------------------------*) +procedure TFontDialogMaxFontSize_W(Self: TFontDialog; const T: Integer); +begin Self.MaxFontSize := T; end; + +(*----------------------------------------------------------------------------*) +procedure TFontDialogMaxFontSize_R(Self: TFontDialog; var T: Integer); +begin T := Self.MaxFontSize; end; + +(*----------------------------------------------------------------------------*) +procedure TFontDialogMinFontSize_W(Self: TFontDialog; const T: Integer); +begin Self.MinFontSize := T; end; + +(*----------------------------------------------------------------------------*) +procedure TFontDialogMinFontSize_R(Self: TFontDialog; var T: Integer); +begin T := Self.MinFontSize; end; + +(*----------------------------------------------------------------------------*) +procedure TFontDialogDevice_W(Self: TFontDialog; const T: TFontDialogDevice); +begin Self.Device := T; end; + +(*----------------------------------------------------------------------------*) +procedure TFontDialogDevice_R(Self: TFontDialog; var T: TFontDialogDevice); +begin T := Self.Device; end; + +(*----------------------------------------------------------------------------*) +procedure TFontDialogFont_W(Self: TFontDialog; const T: TFont); +begin Self.Font := T; end; + +(*----------------------------------------------------------------------------*) +procedure TFontDialogFont_R(Self: TFontDialog; var T: TFont); +begin T := Self.Font; end; + +(*----------------------------------------------------------------------------*) +procedure TColorDialogOptions_W(Self: TColorDialog; const T: TColorDialogOptions); +begin Self.Options := T; end; + +(*----------------------------------------------------------------------------*) +procedure TColorDialogOptions_R(Self: TColorDialog; var T: TColorDialogOptions); +begin T := Self.Options; end; + +(*----------------------------------------------------------------------------*) +procedure TColorDialogCustomColors_W(Self: TColorDialog; const T: TStrings); +begin Self.CustomColors := T; end; + +(*----------------------------------------------------------------------------*) +procedure TColorDialogCustomColors_R(Self: TColorDialog; var T: TStrings); +begin T := Self.CustomColors; end; + +(*----------------------------------------------------------------------------*) +procedure TColorDialogColor_W(Self: TColorDialog; const T: TColor); +begin Self.Color := T; end; + +(*----------------------------------------------------------------------------*) +procedure TColorDialogColor_R(Self: TColorDialog; var T: TColor); +begin T := Self.Color; end; + +(*----------------------------------------------------------------------------*) +procedure TOpenDialogOnIncludeItem_W(Self: TOpenDialog; const T: TIncludeItemEvent); +begin Self.OnIncludeItem := T; end; + +(*----------------------------------------------------------------------------*) +procedure TOpenDialogOnIncludeItem_R(Self: TOpenDialog; var T: TIncludeItemEvent); +begin T := Self.OnIncludeItem; end; + +(*----------------------------------------------------------------------------*) +procedure TOpenDialogOnTypeChange_W(Self: TOpenDialog; const T: TNotifyEvent); +begin Self.OnTypeChange := T; end; + +(*----------------------------------------------------------------------------*) +procedure TOpenDialogOnTypeChange_R(Self: TOpenDialog; var T: TNotifyEvent); +begin T := Self.OnTypeChange; end; + +(*----------------------------------------------------------------------------*) +procedure TOpenDialogOnSelectionChange_W(Self: TOpenDialog; const T: TNotifyEvent); +begin Self.OnSelectionChange := T; end; + +(*----------------------------------------------------------------------------*) +procedure TOpenDialogOnSelectionChange_R(Self: TOpenDialog; var T: TNotifyEvent); +begin T := Self.OnSelectionChange; end; + +(*----------------------------------------------------------------------------*) +procedure TOpenDialogOnFolderChange_W(Self: TOpenDialog; const T: TNotifyEvent); +begin Self.OnFolderChange := T; end; + +(*----------------------------------------------------------------------------*) +procedure TOpenDialogOnFolderChange_R(Self: TOpenDialog; var T: TNotifyEvent); +begin T := Self.OnFolderChange; end; + +(*----------------------------------------------------------------------------*) +procedure TOpenDialogOnCanClose_W(Self: TOpenDialog; const T: TCloseQueryEvent); +begin Self.OnCanClose := T; end; + +(*----------------------------------------------------------------------------*) +procedure TOpenDialogOnCanClose_R(Self: TOpenDialog; var T: TCloseQueryEvent); +begin T := Self.OnCanClose; end; + +(*----------------------------------------------------------------------------*) +procedure TOpenDialogTitle_W(Self: TOpenDialog; const T: string); +begin Self.Title := T; end; + +(*----------------------------------------------------------------------------*) +procedure TOpenDialogTitle_R(Self: TOpenDialog; var T: string); +begin T := Self.Title; end; + +(*----------------------------------------------------------------------------*) +procedure TOpenDialogOptions_W(Self: TOpenDialog; const T: TOpenOptions); +begin Self.Options := T; end; + +(*----------------------------------------------------------------------------*) +procedure TOpenDialogOptions_R(Self: TOpenDialog; var T: TOpenOptions); +begin T := Self.Options; end; + +(*----------------------------------------------------------------------------*) +procedure TOpenDialogInitialDir_W(Self: TOpenDialog; const T: string); +begin Self.InitialDir := T; end; + +(*----------------------------------------------------------------------------*) +procedure TOpenDialogInitialDir_R(Self: TOpenDialog; var T: string); +begin T := Self.InitialDir; end; + +(*----------------------------------------------------------------------------*) +procedure TOpenDialogFilterIndex_W(Self: TOpenDialog; const T: Integer); +begin Self.FilterIndex := T; end; + +(*----------------------------------------------------------------------------*) +procedure TOpenDialogFilterIndex_R(Self: TOpenDialog; var T: Integer); +begin T := Self.FilterIndex; end; + +(*----------------------------------------------------------------------------*) +procedure TOpenDialogFilter_W(Self: TOpenDialog; const T: string); +begin Self.Filter := T; end; + +(*----------------------------------------------------------------------------*) +procedure TOpenDialogFilter_R(Self: TOpenDialog; var T: string); +begin T := Self.Filter; end; + +(*----------------------------------------------------------------------------*) +procedure TOpenDialogFileName_W(Self: TOpenDialog; const T: TFileName); +begin Self.FileName := T; end; + +(*----------------------------------------------------------------------------*) +procedure TOpenDialogFileName_R(Self: TOpenDialog; var T: TFileName); +begin T := Self.FileName; end; + +(*----------------------------------------------------------------------------*) +procedure TOpenDialogDefaultExt_W(Self: TOpenDialog; const T: string); +begin Self.DefaultExt := T; end; + +(*----------------------------------------------------------------------------*) +procedure TOpenDialogDefaultExt_R(Self: TOpenDialog; var T: string); +begin T := Self.DefaultExt; end; + +(*----------------------------------------------------------------------------*) +procedure TOpenDialogHistoryList_W(Self: TOpenDialog; const T: TStrings); +begin Self.HistoryList := T; end; + +(*----------------------------------------------------------------------------*) +procedure TOpenDialogHistoryList_R(Self: TOpenDialog; var T: TStrings); +begin T := Self.HistoryList; end; + +(*----------------------------------------------------------------------------*) +procedure TOpenDialogFiles_R(Self: TOpenDialog; var T: TStrings); +begin T := Self.Files; end; + +(*----------------------------------------------------------------------------*) +procedure TOpenDialogFileEditStyle_W(Self: TOpenDialog; const T: TFileEditStyle); +begin Self.FileEditStyle := T; end; + +(*----------------------------------------------------------------------------*) +procedure TOpenDialogFileEditStyle_R(Self: TOpenDialog; var T: TFileEditStyle); +begin T := Self.FileEditStyle; end; + +(*----------------------------------------------------------------------------*) +procedure TCommonDialogOnShow_W(Self: TCommonDialog; const T: TNotifyEvent); +begin Self.OnShow := T; end; + +(*----------------------------------------------------------------------------*) +procedure TCommonDialogOnShow_R(Self: TCommonDialog; var T: TNotifyEvent); +begin T := Self.OnShow; end; + +(*----------------------------------------------------------------------------*) +procedure TCommonDialogOnClose_W(Self: TCommonDialog; const T: TNotifyEvent); +begin Self.OnClose := T; end; + +(*----------------------------------------------------------------------------*) +procedure TCommonDialogOnClose_R(Self: TCommonDialog; var T: TNotifyEvent); +begin T := Self.OnClose; end; + +(*----------------------------------------------------------------------------*) +procedure TCommonDialogHelpContext_W(Self: TCommonDialog; const T: THelpContext); +begin Self.HelpContext := T; end; + +(*----------------------------------------------------------------------------*) +procedure TCommonDialogHelpContext_R(Self: TCommonDialog; var T: THelpContext); +begin T := Self.HelpContext; end; + +(*----------------------------------------------------------------------------*) +procedure TCommonDialogCtl3D_W(Self: TCommonDialog; const T: Boolean); +begin Self.Ctl3D := T; end; + +(*----------------------------------------------------------------------------*) +procedure TCommonDialogCtl3D_R(Self: TCommonDialog; var T: Boolean); +begin T := Self.Ctl3D; end; + +(*----------------------------------------------------------------------------*) +procedure TCommonDialogHandle_R(Self: TCommonDialog; var T: HWnd); +begin T := Self.Handle; end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_Dialogs_Routines(S: TPSExec); +begin + S.RegisterDelphiFunction(@CreateMessageDialog, 'CreateMessageDialog', cdRegister); + S.RegisterDelphiFunction(@MessageDlg, 'MessageDlg', cdRegister); + S.RegisterDelphiFunction(@MessageDlgPos, 'MessageDlgPos', cdRegister); + S.RegisterDelphiFunction(@MessageDlgPosHelp, 'MessageDlgPosHelp', cdRegister); + S.RegisterDelphiFunction(@ShowMessage, 'ShowMessage', cdRegister); + S.RegisterDelphiFunction(@ShowMessagePos, 'ShowMessagePos', cdRegister); + S.RegisterDelphiFunction(@InputBox, 'InputBox', cdRegister); + S.RegisterDelphiFunction(@InputQuery, 'InputQuery', cdRegister); +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TReplaceDialog(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TReplaceDialog) do + begin + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TFindDialog(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TFindDialog) do + begin + RegisterMethod(@TFindDialog.CloseDialog, 'CloseDialog'); + RegisterPropertyHelper(@TFindDialogLeft_R,@TFindDialogLeft_W,'Left'); + RegisterPropertyHelper(@TFindDialogPosition_R,@TFindDialogPosition_W,'Position'); + RegisterPropertyHelper(@TFindDialogTop_R,@TFindDialogTop_W,'Top'); + RegisterPropertyHelper(@TFindDialogFindText_R,@TFindDialogFindText_W,'FindText'); + RegisterPropertyHelper(@TFindDialogOptions_R,@TFindDialogOptions_W,'Options'); + RegisterPropertyHelper(@TFindDialogOnFind_R,@TFindDialogOnFind_W,'OnFind'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TPrintDialog(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TPrintDialog) do + begin + RegisterPropertyHelper(@TPrintDialogCollate_R,@TPrintDialogCollate_W,'Collate'); + RegisterPropertyHelper(@TPrintDialogCopies_R,@TPrintDialogCopies_W,'Copies'); + RegisterPropertyHelper(@TPrintDialogFromPage_R,@TPrintDialogFromPage_W,'FromPage'); + RegisterPropertyHelper(@TPrintDialogMinPage_R,@TPrintDialogMinPage_W,'MinPage'); + RegisterPropertyHelper(@TPrintDialogMaxPage_R,@TPrintDialogMaxPage_W,'MaxPage'); + RegisterPropertyHelper(@TPrintDialogOptions_R,@TPrintDialogOptions_W,'Options'); + RegisterPropertyHelper(@TPrintDialogPrintToFile_R,@TPrintDialogPrintToFile_W,'PrintToFile'); + RegisterPropertyHelper(@TPrintDialogPrintRange_R,@TPrintDialogPrintRange_W,'PrintRange'); + RegisterPropertyHelper(@TPrintDialogToPage_R,@TPrintDialogToPage_W,'ToPage'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TPrinterSetupDialog(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TPrinterSetupDialog) do + begin + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TFontDialog(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TFontDialog) do + begin + RegisterPropertyHelper(@TFontDialogFont_R,@TFontDialogFont_W,'Font'); + RegisterPropertyHelper(@TFontDialogDevice_R,@TFontDialogDevice_W,'Device'); + RegisterPropertyHelper(@TFontDialogMinFontSize_R,@TFontDialogMinFontSize_W,'MinFontSize'); + RegisterPropertyHelper(@TFontDialogMaxFontSize_R,@TFontDialogMaxFontSize_W,'MaxFontSize'); + RegisterPropertyHelper(@TFontDialogOptions_R,@TFontDialogOptions_W,'Options'); + RegisterPropertyHelper(@TFontDialogOnApply_R,@TFontDialogOnApply_W,'OnApply'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TColorDialog(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TColorDialog) do + begin + RegisterPropertyHelper(@TColorDialogColor_R,@TColorDialogColor_W,'Color'); + RegisterPropertyHelper(@TColorDialogCustomColors_R,@TColorDialogCustomColors_W,'CustomColors'); + RegisterPropertyHelper(@TColorDialogOptions_R,@TColorDialogOptions_W,'Options'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TSaveDialog(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TSaveDialog) do + begin + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TOpenDialog(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TOpenDialog) do + begin + RegisterPropertyHelper(@TOpenDialogFileEditStyle_R,@TOpenDialogFileEditStyle_W,'FileEditStyle'); + RegisterPropertyHelper(@TOpenDialogFiles_R,nil,'Files'); + RegisterPropertyHelper(@TOpenDialogHistoryList_R,@TOpenDialogHistoryList_W,'HistoryList'); + RegisterPropertyHelper(@TOpenDialogDefaultExt_R,@TOpenDialogDefaultExt_W,'DefaultExt'); + RegisterPropertyHelper(@TOpenDialogFileName_R,@TOpenDialogFileName_W,'FileName'); + RegisterPropertyHelper(@TOpenDialogFilter_R,@TOpenDialogFilter_W,'Filter'); + RegisterPropertyHelper(@TOpenDialogFilterIndex_R,@TOpenDialogFilterIndex_W,'FilterIndex'); + RegisterPropertyHelper(@TOpenDialogInitialDir_R,@TOpenDialogInitialDir_W,'InitialDir'); + RegisterPropertyHelper(@TOpenDialogOptions_R,@TOpenDialogOptions_W,'Options'); + RegisterPropertyHelper(@TOpenDialogTitle_R,@TOpenDialogTitle_W,'Title'); + RegisterPropertyHelper(@TOpenDialogOnCanClose_R,@TOpenDialogOnCanClose_W,'OnCanClose'); + RegisterPropertyHelper(@TOpenDialogOnFolderChange_R,@TOpenDialogOnFolderChange_W,'OnFolderChange'); + RegisterPropertyHelper(@TOpenDialogOnSelectionChange_R,@TOpenDialogOnSelectionChange_W,'OnSelectionChange'); + RegisterPropertyHelper(@TOpenDialogOnTypeChange_R,@TOpenDialogOnTypeChange_W,'OnTypeChange'); + RegisterPropertyHelper(@TOpenDialogOnIncludeItem_R,@TOpenDialogOnIncludeItem_W,'OnIncludeItem'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TCommonDialog(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TCommonDialog) do + begin + RegisterPropertyHelper(@TCommonDialogHandle_R,nil,'Handle'); + RegisterPropertyHelper(@TCommonDialogCtl3D_R,@TCommonDialogCtl3D_W,'Ctl3D'); + RegisterPropertyHelper(@TCommonDialogHelpContext_R,@TCommonDialogHelpContext_W,'HelpContext'); + RegisterPropertyHelper(@TCommonDialogOnClose_R,@TCommonDialogOnClose_W,'OnClose'); + RegisterPropertyHelper(@TCommonDialogOnShow_R,@TCommonDialogOnShow_W,'OnShow'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_Dialogs(CL: TPSRuntimeClassImporter); +begin + RIRegister_TCommonDialog(CL); + RIRegister_TOpenDialog(CL); + RIRegister_TSaveDialog(CL); + RIRegister_TColorDialog(CL); + RIRegister_TFontDialog(CL); + RIRegister_TPrinterSetupDialog(CL); + RIRegister_TPrintDialog(CL); + RIRegister_TFindDialog(CL); + RIRegister_TReplaceDialog(CL); +end; + + + +{ TPSImport_Dialogs } +(*----------------------------------------------------------------------------*) +procedure TPSImport_Dialogs.CompOnUses(CompExec: TPSScript); +begin + { nothing } +end; +(*----------------------------------------------------------------------------*) +procedure TPSImport_Dialogs.ExecOnUses(CompExec: TPSScript); +begin + { nothing } +end; +(*----------------------------------------------------------------------------*) +procedure TPSImport_Dialogs.CompileImport1(CompExec: TPSScript); +begin + SIRegister_Dialogs(CompExec.Comp); +end; +(*----------------------------------------------------------------------------*) +procedure TPSImport_Dialogs.CompileImport2(CompExec: TPSScript); +begin + { nothing } +end; +(*----------------------------------------------------------------------------*) +procedure TPSImport_Dialogs.ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); +begin + RIRegister_Dialogs(ri); + RIRegister_Dialogs_Routines(CompExec.Exec); // comment it if no routines +end; +(*----------------------------------------------------------------------------*) +procedure TPSImport_Dialogs.ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); +begin + { nothing } +end; + +end. diff --git a/Units/PascalScript/uPSI_IBX.pas b/Units/PascalScript/uPSI_IBX.pas new file mode 100644 index 0000000..7d1836a --- /dev/null +++ b/Units/PascalScript/uPSI_IBX.pas @@ -0,0 +1,2153 @@ +unit uPSI_IBX; +{ +This file has been generated by UnitParser v0.4, written by M. Knight. +Source Code from Carlo Kok has been used to implement various sections of +UnitParser. Components of ifps3 are used in the construction of UnitParser, +code implementing the class wrapper is taken from Carlo Kok''s conv unility +} + +interface + +uses + SysUtils, Classes, uPSComponent, uPSCompiler, uPSRuntime; + +type + TPSImport_IBX = class(TPSPlugin) + protected + procedure CompOnUses(CompExec: TPSScript); override; + procedure ExecOnUses(CompExec: TPSScript); override; + procedure CompileImport1(CompExec: TPSScript); override; + procedure CompileImport2(CompExec: TPSScript); override; + procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override; + procedure ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override; + end; + + + +implementation + + +uses + WINDOWS + ,CONTROLS + ,IBEXTERNALS + ,IB + ,IBDatabase + ,IBHEADER + ,STDVCL + ,IBSQL + ,DB + ,IBUTILS + ,IBBLOB + ,IBCustomDataSet + ,IBTable + ,IBQuery + ; + +(* === compile-time registration functions === *) +(*----------------------------------------------------------------------------*) +procedure SIRegister_TIBDATASET(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TIBCUSTOMDATASET', 'TIBDATASET') do + with CL.AddClassN(CL.FindClass('TIBCUSTOMDATASET'),'TIBDATASET') do + begin + RegisterMethod('Procedure PREPARE'); + RegisterMethod('Procedure UNPREPARE'); + RegisterMethod('Procedure BATCHINPUT( INPUTOBJECT : TIBBATCHINPUT)'); + RegisterMethod('Procedure BATCHOUTPUT( OUTPUTOBJECT : TIBBATCHOUTPUT)'); + RegisterMethod('Procedure EXECSQL'); + RegisterMethod('Function PARAMBYNAME( IDX : STRING) : TIBXSQLVAR'); + RegisterProperty('PREPARED', 'BOOLEAN', iptr); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TIBCUSTOMDATASET(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TDATASET', 'TIBCUSTOMDATASET') do + with CL.AddClassN(CL.FindClass('TDATASET'),'TIBCUSTOMDATASET') do + begin + RegisterMethod('Procedure APPLYUPDATES'); + RegisterMethod('Function CACHEDUPDATESTATUS : TCACHEDUPDATESTATUS'); + RegisterMethod('Procedure CANCELUPDATES'); + RegisterMethod('Procedure FETCHALL'); + RegisterMethod('Function LOCATENEXT( const KEYFIELDS : STRING; const KEYVALUES : VARIANT; OPTIONS : TLOCATEOPTIONS) : BOOLEAN'); +// RegisterMethod('Function LOCATE( const KEYFIELDS : STRING; const KEYVALUES : VARIANT; OPTIONS : TLOCATEOPTIONS) : BOOLEAN'); + RegisterMethod('Procedure RECORDMODIFIED( VALUE : BOOLEAN)'); + RegisterMethod('Procedure REVERTRECORD'); + RegisterMethod('Procedure UNDELETE'); + RegisterMethod('Function CURRENT : TIBXSQLDA'); + RegisterMethod('Function SQLTYPE : TIBSQLTYPES'); + RegisterProperty('DBHANDLE', 'PISC_DB_HANDLE', iptr); + RegisterProperty('TRHANDLE', 'PISC_TR_HANDLE', iptr); + RegisterProperty('UPDATEOBJECT', 'TIBDATASETUPDATEOBJECT', iptrw); + RegisterProperty('UPDATESPENDING', 'BOOLEAN', iptr); + RegisterProperty('UPDATERECORDTYPES', 'TIBUPDATERECORDTYPES', iptrw); + RegisterProperty('ROWSAFFECTED', 'INTEGER', iptr); + RegisterProperty('PLAN', 'STRING', iptr); + RegisterProperty('DATABASE', 'TIBDATABASE', iptrw); + RegisterProperty('TRANSACTION', 'TIBTRANSACTION', iptrw); + RegisterProperty('FORCEDREFRESH', 'BOOLEAN', iptrw); + RegisterProperty('ONUPDATEERROR', 'TIBUPDATEERROREVENT', iptrw); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TIBGENERATORFIELD(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TPERSISTENT', 'TIBGENERATORFIELD') do + with CL.AddClassN(CL.FindClass('TPERSISTENT'),'TIBGENERATORFIELD') do + begin + RegisterMethod('Constructor CREATE( ADATASET : TIBCUSTOMDATASET)'); + RegisterMethod('Function VALUENAME : STRING'); + RegisterMethod('Procedure APPLY'); + RegisterProperty('FIELD', 'STRING', iptrw); + RegisterProperty('GENERATOR', 'STRING', iptrw); + RegisterProperty('INCREMENTBY', 'INTEGER', iptrw); + RegisterProperty('APPLYEVENT', 'TIBGENERATORAPPLYEVENT', iptrw); + end; +end; + +(* === compile-time registration functions === *) +(*----------------------------------------------------------------------------*) +procedure SIRegister_TIBBASE(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TOBJECT', 'TIBBASE') do + with CL.AddClassN(CL.FindClass('TOBJECT'),'TIBBASE') do + begin + RegisterMethod('Constructor CREATE( AOWNER : TOBJECT)'); + RegisterMethod('Procedure CHECKDATABASE'); + RegisterMethod('Procedure CHECKTRANSACTION'); + RegisterProperty('BEFOREDATABASEDISCONNECT', 'TNOTIFYEVENT', iptrw); + RegisterProperty('AFTERDATABASEDISCONNECT', 'TNOTIFYEVENT', iptrw); + RegisterProperty('ONDATABASEFREE', 'TNOTIFYEVENT', iptrw); + RegisterProperty('BEFORETRANSACTIONEND', 'TNOTIFYEVENT', iptrw); + RegisterProperty('AFTERTRANSACTIONEND', 'TNOTIFYEVENT', iptrw); + RegisterProperty('ONTRANSACTIONFREE', 'TNOTIFYEVENT', iptrw); + RegisterProperty('DATABASE', 'TIBDATABASE', iptrw); + RegisterProperty('DBHANDLE', 'PISC_DB_HANDLE', iptr); + RegisterProperty('OWNER', 'TOBJECT', iptr); + RegisterProperty('TRHANDLE', 'PISC_TR_HANDLE', iptr); + RegisterProperty('TRANSACTION', 'TIBTRANSACTION', iptrw); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TIBTRANSACTION(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TCOMPONENT', 'TIBTRANSACTION') do + with CL.AddClassN(CL.FindClass('TCOMPONENT'),'TIBTRANSACTION') do + begin + RegisterMethod('Function CALL( ERRCODE : ISC_STATUS; RAISEERROR : BOOLEAN) : ISC_STATUS'); + RegisterMethod('Procedure COMMIT'); + RegisterMethod('Procedure COMMITRETAINING'); + RegisterMethod('Procedure ROLLBACK'); + RegisterMethod('Procedure ROLLBACKRETAINING'); + RegisterMethod('Procedure STARTTRANSACTION'); + RegisterMethod('Procedure CHECKINTRANSACTION'); + RegisterMethod('Procedure CHECKNOTINTRANSACTION'); + RegisterMethod('Procedure CHECKAUTOSTOP'); + RegisterMethod('Function ADDDATABASE( DB : TIBDATABASE) : INTEGER'); + RegisterMethod('Function FINDDATABASE( DB : TIBDATABASE) : INTEGER'); + RegisterMethod('Function FINDDEFAULTDATABASE : TIBDATABASE'); + RegisterMethod('Procedure REMOVEDATABASE( IDX : INTEGER)'); + RegisterMethod('Procedure REMOVEDATABASES'); + RegisterMethod('Procedure CHECKDATABASESINLIST'); + RegisterProperty('DATABASECOUNT', 'INTEGER', iptr); + RegisterProperty('DATABASES', 'TIBDATABASE INTEGER', iptr); + RegisterProperty('SQLOBJECTCOUNT', 'INTEGER', iptr); + RegisterProperty('SQLOBJECTS', 'TIBBASE INTEGER', iptr); + RegisterProperty('HANDLE', 'TISC_TR_HANDLE', iptr); + RegisterProperty('HANDLEISSHARED', 'BOOLEAN', iptr); + RegisterProperty('INTRANSACTION', 'BOOLEAN', iptr); + RegisterProperty('TPB', 'PCHAR', iptr); + RegisterProperty('TPBLENGTH', 'SHORT', iptr); + RegisterProperty('ACTIVE', 'BOOLEAN', iptrw); + RegisterProperty('DEFAULTDATABASE', 'TIBDATABASE', iptrw); + RegisterProperty('IDLETIMER', 'INTEGER', iptrw); + RegisterProperty('DEFAULTACTION', 'TTRANSACTIONACTION', iptrw); + RegisterProperty('PARAMS', 'TSTRINGS', iptrw); + RegisterProperty('AUTOSTOPACTION', 'TAUTOSTOPACTION', iptrw); + RegisterProperty('ONIDLETIMER', 'TNOTIFYEVENT', iptrw); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TIBDATABASE(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TCUSTOMCONNECTION', 'TIBDATABASE') do + with CL.AddClassN(CL.FindClass('TCUSTOMCONNECTION'),'TIBDATABASE') do + begin + RegisterMethod('Procedure ADDEVENTNOTIFIER( NOTIFIER : IIBEVENTNOTIFIER)'); + RegisterMethod('Procedure REMOVEEVENTNOTIFIER( NOTIFIER : IIBEVENTNOTIFIER)'); + RegisterMethod('Procedure APPLYUPDATES( const DATASETS : array of TDATASET)'); + RegisterMethod('Procedure CLOSEDATASETS'); + RegisterMethod('Procedure CHECKACTIVE'); + RegisterMethod('Procedure CHECKINACTIVE'); + RegisterMethod('Procedure CREATEDATABASE'); + RegisterMethod('Procedure DROPDATABASE'); + RegisterMethod('Procedure FORCECLOSE'); + RegisterMethod('Procedure GETFIELDNAMES( const TABLENAME : STRING; LIST : TSTRINGS)'); + RegisterMethod('Procedure GETTABLENAMES( LIST : TSTRINGS; SYSTEMTABLES : BOOLEAN)'); + RegisterMethod('Function INDEXOFDBCONST( ST : STRING) : INTEGER'); + RegisterMethod('Function TESTCONNECTED : BOOLEAN'); + RegisterMethod('Procedure CHECKDATABASENAME'); + RegisterMethod('Function CALL( ERRCODE : ISC_STATUS; RAISEERROR : BOOLEAN) : ISC_STATUS'); + RegisterMethod('Function ADDTRANSACTION( TR : TIBTRANSACTION) : INTEGER'); + RegisterMethod('Function FINDTRANSACTION( TR : TIBTRANSACTION) : INTEGER'); + RegisterMethod('Function FINDDEFAULTTRANSACTION( ) : TIBTRANSACTION'); + RegisterMethod('Procedure REMOVETRANSACTION( IDX : INTEGER)'); + RegisterMethod('Procedure REMOVETRANSACTIONS'); + RegisterMethod('Procedure SETHANDLE( VALUE : TISC_DB_HANDLE)'); + RegisterMethod('procedure Open'); + RegisterMethod('procedure Close'); + RegisterProperty('Connected','BOOLEAN',iptrw); + RegisterProperty('HANDLE', 'TISC_DB_HANDLE', iptr); + RegisterProperty('ISREADONLY', 'BOOLEAN', iptr); + RegisterProperty('DBPARAMBYDPB', 'STRING INTEGER', iptrw); + RegisterProperty('SQLOBJECTCOUNT', 'INTEGER', iptr); + RegisterProperty('SQLOBJECTS', 'TIBBASE INTEGER', iptr); + RegisterProperty('HANDLEISSHARED', 'BOOLEAN', iptr); + RegisterProperty('TRANSACTIONCOUNT', 'INTEGER', iptr); + RegisterProperty('TRANSACTIONS', 'TIBTRANSACTION INTEGER', iptr); + RegisterProperty('INTERNALTRANSACTION', 'TIBTRANSACTION', iptr); + RegisterMethod('Function HAS_DEFAULT_VALUE( RELATION, FIELD : STRING) : BOOLEAN'); + RegisterMethod('Function HAS_COMPUTED_BLR( RELATION, FIELD : STRING) : BOOLEAN'); + RegisterMethod('Procedure FLUSHSCHEMA'); + RegisterProperty('DATABASENAME', 'TIBFILENAME', iptrw); + RegisterProperty('PARAMS', 'TSTRINGS', iptrw); + RegisterProperty('DEFAULTTRANSACTION', 'TIBTRANSACTION', iptrw); + RegisterProperty('IDLETIMER', 'INTEGER', iptrw); + RegisterProperty('SQLDIALECT', 'INTEGER', iptrw); + RegisterProperty('DBSQLDIALECT', 'INTEGER', iptr); + RegisterProperty('TRACEFLAGS', 'TTRACEFLAGS', iptrw); + RegisterProperty('ALLOWSTREAMEDCONNECTED', 'BOOLEAN', iptrw); + RegisterProperty('ONLOGIN', 'TIBDATABASELOGINEVENT', iptrw); + RegisterProperty('ONIDLETIMER', 'TNOTIFYEVENT', iptrw); + RegisterProperty('ONDIALECTDOWNGRADEWARNING', 'TNOTIFYEVENT', iptrw); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TIBSCHEMA(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TOBJECT', 'TIBSCHEMA') do + with CL.AddClassN(CL.FindClass('TOBJECT'),'TIBSCHEMA') do + begin + RegisterMethod('Procedure FREENODES'); + RegisterMethod('Function HAS_DEFAULT_VALUE( RELATION, FIELD : STRING) : BOOLEAN'); + RegisterMethod('Function HAS_COMPUTED_BLR( RELATION, FIELD : STRING) : BOOLEAN'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_IBDatabase(CL: TPSPascalCompiler); +begin + CL.AddClassN(CL.FindClass('TOBJECT'),'TIBDATABASE'); + CL.AddClassN(CL.FindClass('TOBJECT'),'TIBTRANSACTION'); + CL.AddClassN(CL.FindClass('TOBJECT'),'TIBBASE'); + CL.AddTypeS('TIBDATABASELOGINEVENT', 'Procedure ( DATABASE : TIBDATABASE; LOG' + +'INPARAMS : TSTRINGS)'); + SIRegister_TIBSCHEMA(CL); + CL.AddTypeS('TIBFILENAME', 'STRING'); + SIRegister_TIBDATABASE(CL); + CL.AddTypeS('TTRANSACTIONACTION', '( TAROLLBACK, TACOMMIT, TAROLLBACKRETAININ' + +'G, TACOMMITRETAINING )'); + CL.AddTypeS('TAUTOSTOPACTION', '( SANONE, SAROLLBACK, SACOMMIT, SAROLLBACKRET' + +'AINING, SACOMMITRETAINING )'); + SIRegister_TIBTRANSACTION(CL); + SIRegister_TIBBASE(CL); +end; + +(* === run-time registration functions === *) +(*----------------------------------------------------------------------------*) +procedure TIBBASETRANSACTION_W(Self: TIBBASE; const T: TIBTRANSACTION); +begin Self.TRANSACTION := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBBASETRANSACTION_R(Self: TIBBASE; var T: TIBTRANSACTION); +begin T := Self.TRANSACTION; end; + +(*----------------------------------------------------------------------------*) +procedure TIBBASETRHANDLE_R(Self: TIBBASE; var T: PISC_TR_HANDLE); +begin T := Self.TRHANDLE; end; + +(*----------------------------------------------------------------------------*) +procedure TIBBASEOWNER_R(Self: TIBBASE; var T: TOBJECT); +begin T := Self.OWNER; end; + +(*----------------------------------------------------------------------------*) +procedure TIBBASEDBHANDLE_R(Self: TIBBASE; var T: PISC_DB_HANDLE); +begin T := Self.DBHANDLE; end; + +(*----------------------------------------------------------------------------*) +procedure TIBBASEDATABASE_W(Self: TIBBASE; const T: TIBDATABASE); +begin Self.DATABASE := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBBASEDATABASE_R(Self: TIBBASE; var T: TIBDATABASE); +begin T := Self.DATABASE; end; + +(*----------------------------------------------------------------------------*) +procedure TIBBASEONTRANSACTIONFREE_W(Self: TIBBASE; const T: TNOTIFYEVENT); +begin Self.ONTRANSACTIONFREE := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBBASEONTRANSACTIONFREE_R(Self: TIBBASE; var T: TNOTIFYEVENT); +begin T := Self.ONTRANSACTIONFREE; end; + +(*----------------------------------------------------------------------------*) +procedure TIBBASEAFTERTRANSACTIONEND_W(Self: TIBBASE; const T: TNOTIFYEVENT); +begin Self.AFTERTRANSACTIONEND := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBBASEAFTERTRANSACTIONEND_R(Self: TIBBASE; var T: TNOTIFYEVENT); +begin T := Self.AFTERTRANSACTIONEND; end; + +(*----------------------------------------------------------------------------*) +procedure TIBBASEBEFORETRANSACTIONEND_W(Self: TIBBASE; const T: TNOTIFYEVENT); +begin Self.BEFORETRANSACTIONEND := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBBASEBEFORETRANSACTIONEND_R(Self: TIBBASE; var T: TNOTIFYEVENT); +begin T := Self.BEFORETRANSACTIONEND; end; + +(*----------------------------------------------------------------------------*) +procedure TIBBASEONDATABASEFREE_W(Self: TIBBASE; const T: TNOTIFYEVENT); +begin Self.ONDATABASEFREE := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBBASEONDATABASEFREE_R(Self: TIBBASE; var T: TNOTIFYEVENT); +begin T := Self.ONDATABASEFREE; end; + +(*----------------------------------------------------------------------------*) +procedure TIBBASEAFTERDATABASEDISCONNECT_W(Self: TIBBASE; const T: TNOTIFYEVENT); +begin Self.AFTERDATABASEDISCONNECT := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBBASEAFTERDATABASEDISCONNECT_R(Self: TIBBASE; var T: TNOTIFYEVENT); +begin T := Self.AFTERDATABASEDISCONNECT; end; + +(*----------------------------------------------------------------------------*) +procedure TIBBASEBEFOREDATABASEDISCONNECT_W(Self: TIBBASE; const T: TNOTIFYEVENT); +begin Self.BEFOREDATABASEDISCONNECT := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBBASEBEFOREDATABASEDISCONNECT_R(Self: TIBBASE; var T: TNOTIFYEVENT); +begin T := Self.BEFOREDATABASEDISCONNECT; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTRANSACTIONONIDLETIMER_W(Self: TIBTRANSACTION; const T: TNOTIFYEVENT); +begin Self.ONIDLETIMER := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTRANSACTIONONIDLETIMER_R(Self: TIBTRANSACTION; var T: TNOTIFYEVENT); +begin T := Self.ONIDLETIMER; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTRANSACTIONAUTOSTOPACTION_W(Self: TIBTRANSACTION; const T: TAUTOSTOPACTION); +begin Self.AUTOSTOPACTION := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTRANSACTIONAUTOSTOPACTION_R(Self: TIBTRANSACTION; var T: TAUTOSTOPACTION); +begin T := Self.AUTOSTOPACTION; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTRANSACTIONPARAMS_W(Self: TIBTRANSACTION; const T: TSTRINGS); +begin Self.PARAMS := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTRANSACTIONPARAMS_R(Self: TIBTRANSACTION; var T: TSTRINGS); +begin T := Self.PARAMS; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTRANSACTIONDEFAULTACTION_W(Self: TIBTRANSACTION; const T: TTRANSACTIONACTION); +begin Self.DEFAULTACTION := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTRANSACTIONDEFAULTACTION_R(Self: TIBTRANSACTION; var T: TTRANSACTIONACTION); +begin T := Self.DEFAULTACTION; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTRANSACTIONIDLETIMER_W(Self: TIBTRANSACTION; const T: INTEGER); +begin Self.IDLETIMER := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTRANSACTIONIDLETIMER_R(Self: TIBTRANSACTION; var T: INTEGER); +begin T := Self.IDLETIMER; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTRANSACTIONDEFAULTDATABASE_W(Self: TIBTRANSACTION; const T: TIBDATABASE); +begin Self.DEFAULTDATABASE := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTRANSACTIONDEFAULTDATABASE_R(Self: TIBTRANSACTION; var T: TIBDATABASE); +begin T := Self.DEFAULTDATABASE; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTRANSACTIONACTIVE_W(Self: TIBTRANSACTION; const T: BOOLEAN); +begin Self.ACTIVE := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTRANSACTIONACTIVE_R(Self: TIBTRANSACTION; var T: BOOLEAN); +begin T := Self.ACTIVE; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTRANSACTIONTPBLENGTH_R(Self: TIBTRANSACTION; var T: SHORT); +begin T := Self.TPBLENGTH; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTRANSACTIONTPB_R(Self: TIBTRANSACTION; var T: PCHAR); +begin T := Self.TPB; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTRANSACTIONINTRANSACTION_R(Self: TIBTRANSACTION; var T: BOOLEAN); +begin T := Self.INTRANSACTION; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTRANSACTIONHANDLEISSHARED_R(Self: TIBTRANSACTION; var T: BOOLEAN); +begin T := Self.HANDLEISSHARED; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTRANSACTIONHANDLE_R(Self: TIBTRANSACTION; var T: TISC_TR_HANDLE); +begin T := Self.HANDLE; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTRANSACTIONSQLOBJECTS_R(Self: TIBTRANSACTION; var T: TIBBASE; const t1: INTEGER); +begin T := Self.SQLOBJECTS[t1]; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTRANSACTIONSQLOBJECTCOUNT_R(Self: TIBTRANSACTION; var T: INTEGER); +begin T := Self.SQLOBJECTCOUNT; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTRANSACTIONDATABASES_R(Self: TIBTRANSACTION; var T: TIBDATABASE; const t1: INTEGER); +begin T := Self.DATABASES[t1]; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTRANSACTIONDATABASECOUNT_R(Self: TIBTRANSACTION; var T: INTEGER); +begin T := Self.DATABASECOUNT; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASEONDIALECTDOWNGRADEWARNING_W(Self: TIBDATABASE; const T: TNOTIFYEVENT); +begin Self.ONDIALECTDOWNGRADEWARNING := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASEONDIALECTDOWNGRADEWARNING_R(Self: TIBDATABASE; var T: TNOTIFYEVENT); +begin T := Self.ONDIALECTDOWNGRADEWARNING; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASEONIDLETIMER_W(Self: TIBDATABASE; const T: TNOTIFYEVENT); +begin Self.ONIDLETIMER := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASEONIDLETIMER_R(Self: TIBDATABASE; var T: TNOTIFYEVENT); +begin T := Self.ONIDLETIMER; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASEONLOGIN_W(Self: TIBDATABASE; const T: TIBDATABASELOGINEVENT); +begin Self.ONLOGIN := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASEONLOGIN_R(Self: TIBDATABASE; var T: TIBDATABASELOGINEVENT); +begin T := Self.ONLOGIN; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASECONNECTED_W(Self: TIBDATABASE; const T: Boolean); +begin Self.Connected := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASECONNECTED_R(Self: TIBDATABASE; var T: Boolean); +begin T := Self.Connected; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASEALLOWSTREAMEDCONNECTED_W(Self: TIBDATABASE; const T: BOOLEAN); +begin Self.ALLOWSTREAMEDCONNECTED := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASEALLOWSTREAMEDCONNECTED_R(Self: TIBDATABASE; var T: BOOLEAN); +begin T := Self.ALLOWSTREAMEDCONNECTED; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASETRACEFLAGS_W(Self: TIBDATABASE; const T: TTRACEFLAGS); +begin Self.TRACEFLAGS := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASETRACEFLAGS_R(Self: TIBDATABASE; var T: TTRACEFLAGS); +begin T := Self.TRACEFLAGS; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASEDBSQLDIALECT_R(Self: TIBDATABASE; var T: INTEGER); +begin T := Self.DBSQLDIALECT; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASESQLDIALECT_W(Self: TIBDATABASE; const T: INTEGER); +begin Self.SQLDIALECT := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASESQLDIALECT_R(Self: TIBDATABASE; var T: INTEGER); +begin T := Self.SQLDIALECT; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASEIDLETIMER_W(Self: TIBDATABASE; const T: INTEGER); +begin Self.IDLETIMER := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASEIDLETIMER_R(Self: TIBDATABASE; var T: INTEGER); +begin T := Self.IDLETIMER; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASEDEFAULTTRANSACTION_W(Self: TIBDATABASE; const T: TIBTRANSACTION); +begin Self.DEFAULTTRANSACTION := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASEDEFAULTTRANSACTION_R(Self: TIBDATABASE; var T: TIBTRANSACTION); +begin T := Self.DEFAULTTRANSACTION; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASEPARAMS_W(Self: TIBDATABASE; const T: TSTRINGS); +begin Self.PARAMS := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASEPARAMS_R(Self: TIBDATABASE; var T: TSTRINGS); +begin T := Self.PARAMS; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASEDATABASENAME_W(Self: TIBDATABASE; const T: TIBFILENAME); +begin Self.DATABASENAME := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASEDATABASENAME_R(Self: TIBDATABASE; var T: TIBFILENAME); +begin T := Self.DATABASENAME; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASEINTERNALTRANSACTION_R(Self: TIBDATABASE; var T: TIBTRANSACTION); +begin T := Self.INTERNALTRANSACTION; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASETRANSACTIONS_R(Self: TIBDATABASE; var T: TIBTRANSACTION; const t1: INTEGER); +begin T := Self.TRANSACTIONS[t1]; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASETRANSACTIONCOUNT_R(Self: TIBDATABASE; var T: INTEGER); +begin T := Self.TRANSACTIONCOUNT; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASEHANDLEISSHARED_R(Self: TIBDATABASE; var T: BOOLEAN); +begin T := Self.HANDLEISSHARED; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASESQLOBJECTS_R(Self: TIBDATABASE; var T: TIBBASE; const t1: INTEGER); +begin T := Self.SQLOBJECTS[t1]; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASESQLOBJECTCOUNT_R(Self: TIBDATABASE; var T: INTEGER); +begin T := Self.SQLOBJECTCOUNT; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASEDBPARAMBYDPB_W(Self: TIBDATABASE; const T: STRING; const t1: INTEGER); +begin Self.DBPARAMBYDPB[t1] := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASEDBPARAMBYDPB_R(Self: TIBDATABASE; var T: STRING; const t1: INTEGER); +begin T := Self.DBPARAMBYDPB[t1]; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASEISREADONLY_R(Self: TIBDATABASE; var T: BOOLEAN); +begin T := Self.ISREADONLY; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATABASEHANDLE_R(Self: TIBDATABASE; var T: TISC_DB_HANDLE); +begin T := Self.HANDLE; end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TIBDATALINK(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TDETAILDATALINK', 'TIBDATALINK') do + with CL.AddClassN(CL.FindClass('TDETAILDATALINK'),'TIBDATALINK') do + begin + RegisterMethod('Constructor CREATE( ADATASET : TIBCUSTOMDATASET)'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TIBBCDFIELD(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TBCDFIELD', 'TIBBCDFIELD') do + with CL.AddClassN(CL.FindClass('TBCDFIELD'),'TIBBCDFIELD') do + begin + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TIBSTRINGFIELD(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TSTRINGFIELD', 'TIBSTRINGFIELD') do + with CL.AddClassN(CL.FindClass('TSTRINGFIELD'),'TIBSTRINGFIELD') do + begin + RegisterMethod('Function GETVALUE( var VALUE : STRING) : BOOLEAN'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TIBDATASETUPDATEOBJECT(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TCOMPONENT', 'TIBDATASETUPDATEOBJECT') do + with CL.AddClassN(CL.FindClass('TCOMPONENT'),'TIBDATASETUPDATEOBJECT') do + begin + RegisterProperty('REFRESHSQL', 'TSTRINGS', iptrw); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_IBCustomDataSet(CL: TPSPascalCompiler); +begin + CL.AddConstantN('BUFFERCACHESIZE','LONGINT').SetInt( 1000); + CL.AddConstantN('UNICACHE','LONGINT').SetInt( 2); + CL.AddClassN(CL.FindClass('TOBJECT'),'TIBCUSTOMDATASET'); + CL.AddClassN(CL.FindClass('TOBJECT'),'TIBDATASET'); + SIRegister_TIBDATASETUPDATEOBJECT(CL); + CL.AddTypeS('TCACHEDUPDATESTATUS', '( CUSUNMODIFIED, CUSMODIFIED, CUSINSERTED' + +', CUSDELETED, CUSUNINSERTED )'); + SIRegister_TIBSTRINGFIELD(CL); + SIRegister_TIBBCDFIELD(CL); + SIRegister_TIBDATALINK(CL); + CL.AddTypeS('TIBGENERATORAPPLYEVENT', '( GAMONNEWRECORD, GAMONPOST, GAMONSERV' + +'ER )'); + SIRegister_TIBGENERATORFIELD(CL); + CL.AddTypeS('TIBUPDATEACTION', '( UAFAIL, UAABORT, UASKIP, UARETRY, UAAPPLY, ' + +'UAAPPLIED )'); + CL.AddTypeS('TIBUPDATERECORDTYPES', 'set of TCACHEDUPDATESTATUS'); + CL.AddTypeS('TLIVEMODE', '( LMINSERT, LMMODIFY, LMDELETE, LMREFRESH )'); + CL.AddTypeS('TLIVEMODES', 'set of TLIVEMODE'); + SIRegister_TIBCUSTOMDATASET(CL); + SIRegister_TIBDATASET(CL); +end; + +(* === run-time registration functions === *) +(*----------------------------------------------------------------------------*) +procedure TIBDATASETPREPARED_R(Self: TIBDATASET; var T: BOOLEAN); +begin T := Self.PREPARED; end; + +(*----------------------------------------------------------------------------*) +procedure TIBCUSTOMDATASETFORCEDREFRESH_W(Self: TIBCUSTOMDATASET; const T: BOOLEAN); +begin Self.FORCEDREFRESH := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBCUSTOMDATASETFORCEDREFRESH_R(Self: TIBCUSTOMDATASET; var T: BOOLEAN); +begin T := Self.FORCEDREFRESH; end; + +(*----------------------------------------------------------------------------*) +procedure TIBCUSTOMDATASETTRANSACTION_W(Self: TIBCUSTOMDATASET; const T: TIBTRANSACTION); +begin Self.TRANSACTION := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBCUSTOMDATASETTRANSACTION_R(Self: TIBCUSTOMDATASET; var T: TIBTRANSACTION); +begin T := Self.TRANSACTION; end; + +(*----------------------------------------------------------------------------*) +procedure TIBCUSTOMDATASETDATABASE_W(Self: TIBCUSTOMDATASET; const T: TIBDATABASE); +begin Self.DATABASE := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBCUSTOMDATASETDATABASE_R(Self: TIBCUSTOMDATASET; var T: TIBDATABASE); +begin T := Self.DATABASE; end; + +(*----------------------------------------------------------------------------*) +procedure TIBCUSTOMDATASETPLAN_R(Self: TIBCUSTOMDATASET; var T: STRING); +begin T := Self.PLAN; end; + +(*----------------------------------------------------------------------------*) +procedure TIBCUSTOMDATASETROWSAFFECTED_R(Self: TIBCUSTOMDATASET; var T: INTEGER); +begin T := Self.ROWSAFFECTED; end; + +(*----------------------------------------------------------------------------*) +procedure TIBCUSTOMDATASETUPDATERECORDTYPES_W(Self: TIBCUSTOMDATASET; const T: TIBUPDATERECORDTYPES); +begin Self.UPDATERECORDTYPES := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBCUSTOMDATASETUPDATERECORDTYPES_R(Self: TIBCUSTOMDATASET; var T: TIBUPDATERECORDTYPES); +begin T := Self.UPDATERECORDTYPES; end; + +(*----------------------------------------------------------------------------*) +procedure TIBCUSTOMDATASETUPDATESPENDING_R(Self: TIBCUSTOMDATASET; var T: BOOLEAN); +begin T := Self.UPDATESPENDING; end; + +(*----------------------------------------------------------------------------*) +procedure TIBCUSTOMDATASETUPDATEOBJECT_W(Self: TIBCUSTOMDATASET; const T: TIBDATASETUPDATEOBJECT); +begin Self.UPDATEOBJECT := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBCUSTOMDATASETUPDATEOBJECT_R(Self: TIBCUSTOMDATASET; var T: TIBDATASETUPDATEOBJECT); +begin T := Self.UPDATEOBJECT; end; + +(*----------------------------------------------------------------------------*) +procedure TIBCUSTOMDATASETTRHANDLE_R(Self: TIBCUSTOMDATASET; var T: PISC_TR_HANDLE); +begin T := Self.TRHANDLE; end; + +(*----------------------------------------------------------------------------*) +procedure TIBCUSTOMDATASETDBHANDLE_R(Self: TIBCUSTOMDATASET; var T: PISC_DB_HANDLE); +begin T := Self.DBHANDLE; end; + +(*----------------------------------------------------------------------------*) +procedure TIBGENERATORFIELDAPPLYEVENT_W(Self: TIBGENERATORFIELD; const T: TIBGENERATORAPPLYEVENT); +begin Self.APPLYEVENT := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBGENERATORFIELDAPPLYEVENT_R(Self: TIBGENERATORFIELD; var T: TIBGENERATORAPPLYEVENT); +begin T := Self.APPLYEVENT; end; + +(*----------------------------------------------------------------------------*) +procedure TIBGENERATORFIELDINCREMENTBY_W(Self: TIBGENERATORFIELD; const T: INTEGER); +begin Self.INCREMENTBY := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBGENERATORFIELDINCREMENTBY_R(Self: TIBGENERATORFIELD; var T: INTEGER); +begin T := Self.INCREMENTBY; end; + +(*----------------------------------------------------------------------------*) +procedure TIBGENERATORFIELDGENERATOR_W(Self: TIBGENERATORFIELD; const T: STRING); +begin Self.GENERATOR := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBGENERATORFIELDGENERATOR_R(Self: TIBGENERATORFIELD; var T: STRING); +begin T := Self.GENERATOR; end; + +(*----------------------------------------------------------------------------*) +procedure TIBGENERATORFIELDFIELD_W(Self: TIBGENERATORFIELD; const T: STRING); +begin Self.FIELD := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBGENERATORFIELDFIELD_R(Self: TIBGENERATORFIELD; var T: STRING); +begin T := Self.FIELD; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATASETUPDATEOBJECTREFRESHSQL_W(Self: TIBDATASETUPDATEOBJECT; const T: TSTRINGS); +begin Self.REFRESHSQL := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBDATASETUPDATEOBJECTREFRESHSQL_R(Self: TIBDATASETUPDATEOBJECT; var T: TSTRINGS); +begin T := Self.REFRESHSQL; end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TIBDATASET(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TIBDATASET) do + begin + RegisterMethod(@TIBDATASET.PREPARE, 'PREPARE'); + RegisterMethod(@TIBDATASET.UNPREPARE, 'UNPREPARE'); + RegisterMethod(@TIBDATASET.BATCHINPUT, 'BATCHINPUT'); + RegisterMethod(@TIBDATASET.BATCHOUTPUT, 'BATCHOUTPUT'); + RegisterMethod(@TIBDATASET.EXECSQL, 'EXECSQL'); + RegisterMethod(@TIBDATASET.PARAMBYNAME, 'PARAMBYNAME'); + RegisterPropertyHelper(@TIBDATASETPREPARED_R,nil,'PREPARED'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TIBCUSTOMDATASET(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TIBCUSTOMDATASET) do + begin + RegisterMethod(@TIBCUSTOMDATASET.APPLYUPDATES, 'APPLYUPDATES'); + RegisterMethod(@TIBCUSTOMDATASET.CACHEDUPDATESTATUS, 'CACHEDUPDATESTATUS'); + RegisterMethod(@TIBCUSTOMDATASET.CANCELUPDATES, 'CANCELUPDATES'); + RegisterMethod(@TIBCUSTOMDATASET.FETCHALL, 'FETCHALL'); + RegisterMethod(@TIBCUSTOMDATASET.LOCATENEXT, 'LOCATENEXT'); +// RegisterMethod(@TIBCUSTOMDATASET.LOCATE, 'LOCATE'); + RegisterMethod(@TIBCUSTOMDATASET.RECORDMODIFIED, 'RECORDMODIFIED'); + RegisterMethod(@TIBCUSTOMDATASET.REVERTRECORD, 'REVERTRECORD'); + RegisterMethod(@TIBCUSTOMDATASET.UNDELETE, 'UNDELETE'); + RegisterMethod(@TIBCUSTOMDATASET.CURRENT, 'CURRENT'); + RegisterMethod(@TIBCUSTOMDATASET.SQLTYPE, 'SQLTYPE'); + RegisterPropertyHelper(@TIBCUSTOMDATASETDBHANDLE_R,nil,'DBHANDLE'); + RegisterPropertyHelper(@TIBCUSTOMDATASETTRHANDLE_R,nil,'TRHANDLE'); + RegisterPropertyHelper(@TIBCUSTOMDATASETUPDATEOBJECT_R,@TIBCUSTOMDATASETUPDATEOBJECT_W,'UPDATEOBJECT'); + RegisterPropertyHelper(@TIBCUSTOMDATASETUPDATESPENDING_R,nil,'UPDATESPENDING'); + RegisterPropertyHelper(@TIBCUSTOMDATASETUPDATERECORDTYPES_R,@TIBCUSTOMDATASETUPDATERECORDTYPES_W,'UPDATERECORDTYPES'); + RegisterPropertyHelper(@TIBCUSTOMDATASETROWSAFFECTED_R,nil,'ROWSAFFECTED'); + RegisterPropertyHelper(@TIBCUSTOMDATASETPLAN_R,nil,'PLAN'); + RegisterPropertyHelper(@TIBCUSTOMDATASETDATABASE_R,@TIBCUSTOMDATASETDATABASE_W,'DATABASE'); + RegisterPropertyHelper(@TIBCUSTOMDATASETTRANSACTION_R,@TIBCUSTOMDATASETTRANSACTION_W,'TRANSACTION'); + RegisterPropertyHelper(@TIBCUSTOMDATASETFORCEDREFRESH_R,@TIBCUSTOMDATASETFORCEDREFRESH_W,'FORCEDREFRESH'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TIBGENERATORFIELD(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TIBGENERATORFIELD) do + begin + RegisterConstructor(@TIBGENERATORFIELD.CREATE, 'CREATE'); + RegisterMethod(@TIBGENERATORFIELD.VALUENAME, 'VALUENAME'); + RegisterMethod(@TIBGENERATORFIELD.APPLY, 'APPLY'); + RegisterPropertyHelper(@TIBGENERATORFIELDFIELD_R,@TIBGENERATORFIELDFIELD_W,'FIELD'); + RegisterPropertyHelper(@TIBGENERATORFIELDGENERATOR_R,@TIBGENERATORFIELDGENERATOR_W,'GENERATOR'); + RegisterPropertyHelper(@TIBGENERATORFIELDINCREMENTBY_R,@TIBGENERATORFIELDINCREMENTBY_W,'INCREMENTBY'); + RegisterPropertyHelper(@TIBGENERATORFIELDAPPLYEVENT_R,@TIBGENERATORFIELDAPPLYEVENT_W,'APPLYEVENT'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TIBDATALINK(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TIBDATALINK) do + begin + RegisterConstructor(@TIBDATALINK.CREATE, 'CREATE'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TIBBCDFIELD(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TIBBCDFIELD) do + begin + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TIBSTRINGFIELD(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TIBSTRINGFIELD) do + begin + RegisterMethod(@TIBSTRINGFIELD.GETVALUE, 'GETVALUE'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TIBDATASETUPDATEOBJECT(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TIBDATASETUPDATEOBJECT) do + begin + RegisterPropertyHelper(@TIBDATASETUPDATEOBJECTREFRESHSQL_R,@TIBDATASETUPDATEOBJECTREFRESHSQL_W,'REFRESHSQL'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_IBCustomDataSet(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TIBCUSTOMDATASET) do + with CL.Add(TIBDATASET) do + RIRegister_TIBDATASETUPDATEOBJECT(CL); + RIRegister_TIBSTRINGFIELD(CL); + RIRegister_TIBBCDFIELD(CL); + RIRegister_TIBDATALINK(CL); + RIRegister_TIBGENERATORFIELD(CL); + RIRegister_TIBCUSTOMDATASET(CL); + RIRegister_TIBDATASET(CL); +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TIBBASE(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TIBBASE) do + begin + RegisterConstructor(@TIBBASE.CREATE, 'CREATE'); + RegisterVirtualMethod(@TIBBASE.CHECKDATABASE, 'CHECKDATABASE'); + RegisterVirtualMethod(@TIBBASE.CHECKTRANSACTION, 'CHECKTRANSACTION'); + RegisterPropertyHelper(@TIBBASEBEFOREDATABASEDISCONNECT_R,@TIBBASEBEFOREDATABASEDISCONNECT_W,'BEFOREDATABASEDISCONNECT'); + RegisterPropertyHelper(@TIBBASEAFTERDATABASEDISCONNECT_R,@TIBBASEAFTERDATABASEDISCONNECT_W,'AFTERDATABASEDISCONNECT'); + RegisterEventPropertyHelper(@TIBBASEONDATABASEFREE_R,@TIBBASEONDATABASEFREE_W,'ONDATABASEFREE'); + RegisterPropertyHelper(@TIBBASEBEFORETRANSACTIONEND_R,@TIBBASEBEFORETRANSACTIONEND_W,'BEFORETRANSACTIONEND'); + RegisterPropertyHelper(@TIBBASEAFTERTRANSACTIONEND_R,@TIBBASEAFTERTRANSACTIONEND_W,'AFTERTRANSACTIONEND'); + RegisterEventPropertyHelper(@TIBBASEONTRANSACTIONFREE_R,@TIBBASEONTRANSACTIONFREE_W,'ONTRANSACTIONFREE'); + RegisterPropertyHelper(@TIBBASEDATABASE_R,@TIBBASEDATABASE_W,'DATABASE'); + RegisterPropertyHelper(@TIBBASEDBHANDLE_R,nil,'DBHANDLE'); + RegisterPropertyHelper(@TIBBASEOWNER_R,nil,'OWNER'); + RegisterPropertyHelper(@TIBBASETRHANDLE_R,nil,'TRHANDLE'); + RegisterPropertyHelper(@TIBBASETRANSACTION_R,@TIBBASETRANSACTION_W,'TRANSACTION'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TIBTRANSACTION(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TIBTRANSACTION) do + begin + RegisterMethod(@TIBTRANSACTION.CALL, 'CALL'); + RegisterMethod(@TIBTRANSACTION.COMMIT, 'COMMIT'); + RegisterMethod(@TIBTRANSACTION.COMMITRETAINING, 'COMMITRETAINING'); + RegisterMethod(@TIBTRANSACTION.ROLLBACK, 'ROLLBACK'); + RegisterMethod(@TIBTRANSACTION.ROLLBACKRETAINING, 'ROLLBACKRETAINING'); + RegisterMethod(@TIBTRANSACTION.STARTTRANSACTION, 'STARTTRANSACTION'); + RegisterMethod(@TIBTRANSACTION.CHECKINTRANSACTION, 'CHECKINTRANSACTION'); + RegisterMethod(@TIBTRANSACTION.CHECKNOTINTRANSACTION, 'CHECKNOTINTRANSACTION'); + RegisterMethod(@TIBTRANSACTION.CHECKAUTOSTOP, 'CHECKAUTOSTOP'); + RegisterMethod(@TIBTRANSACTION.ADDDATABASE, 'ADDDATABASE'); + RegisterMethod(@TIBTRANSACTION.FINDDATABASE, 'FINDDATABASE'); + RegisterMethod(@TIBTRANSACTION.FINDDEFAULTDATABASE, 'FINDDEFAULTDATABASE'); + RegisterMethod(@TIBTRANSACTION.REMOVEDATABASE, 'REMOVEDATABASE'); + RegisterMethod(@TIBTRANSACTION.REMOVEDATABASES, 'REMOVEDATABASES'); + RegisterMethod(@TIBTRANSACTION.CHECKDATABASESINLIST, 'CHECKDATABASESINLIST'); + RegisterPropertyHelper(@TIBTRANSACTIONDATABASECOUNT_R,nil,'DATABASECOUNT'); + RegisterPropertyHelper(@TIBTRANSACTIONDATABASES_R,nil,'DATABASES'); + RegisterPropertyHelper(@TIBTRANSACTIONSQLOBJECTCOUNT_R,nil,'SQLOBJECTCOUNT'); + RegisterPropertyHelper(@TIBTRANSACTIONSQLOBJECTS_R,nil,'SQLOBJECTS'); + RegisterPropertyHelper(@TIBTRANSACTIONHANDLE_R,nil,'HANDLE'); + RegisterPropertyHelper(@TIBTRANSACTIONHANDLEISSHARED_R,nil,'HANDLEISSHARED'); + RegisterPropertyHelper(@TIBTRANSACTIONINTRANSACTION_R,nil,'INTRANSACTION'); + RegisterPropertyHelper(@TIBTRANSACTIONTPB_R,nil,'TPB'); + RegisterPropertyHelper(@TIBTRANSACTIONTPBLENGTH_R,nil,'TPBLENGTH'); + RegisterPropertyHelper(@TIBTRANSACTIONACTIVE_R,@TIBTRANSACTIONACTIVE_W,'ACTIVE'); + RegisterPropertyHelper(@TIBTRANSACTIONDEFAULTDATABASE_R,@TIBTRANSACTIONDEFAULTDATABASE_W,'DEFAULTDATABASE'); + RegisterPropertyHelper(@TIBTRANSACTIONIDLETIMER_R,@TIBTRANSACTIONIDLETIMER_W,'IDLETIMER'); + RegisterPropertyHelper(@TIBTRANSACTIONDEFAULTACTION_R,@TIBTRANSACTIONDEFAULTACTION_W,'DEFAULTACTION'); + RegisterPropertyHelper(@TIBTRANSACTIONPARAMS_R,@TIBTRANSACTIONPARAMS_W,'PARAMS'); + RegisterPropertyHelper(@TIBTRANSACTIONAUTOSTOPACTION_R,@TIBTRANSACTIONAUTOSTOPACTION_W,'AUTOSTOPACTION'); + RegisterEventPropertyHelper(@TIBTRANSACTIONONIDLETIMER_R,@TIBTRANSACTIONONIDLETIMER_W,'ONIDLETIMER'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TIBDATABASE(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TIBDATABASE) do + begin + RegisterMethod(@TIBDATABASE.ADDEVENTNOTIFIER, 'ADDEVENTNOTIFIER'); + RegisterMethod(@TIBDATABASE.REMOVEEVENTNOTIFIER, 'REMOVEEVENTNOTIFIER'); + RegisterMethod(@TIBDATABASE.APPLYUPDATES, 'APPLYUPDATES'); + RegisterMethod(@TIBDATABASE.CLOSEDATASETS, 'CLOSEDATASETS'); + RegisterMethod(@TIBDATABASE.CHECKACTIVE, 'CHECKACTIVE'); + RegisterMethod(@TIBDATABASE.CHECKINACTIVE, 'CHECKINACTIVE'); + RegisterMethod(@TIBDATABASE.CREATEDATABASE, 'CREATEDATABASE'); + RegisterMethod(@TIBDATABASE.DROPDATABASE, 'DROPDATABASE'); + RegisterMethod(@TIBDATABASE.FORCECLOSE, 'FORCECLOSE'); + RegisterMethod(@TIBDATABASE.GETFIELDNAMES, 'GETFIELDNAMES'); + RegisterMethod(@TIBDATABASE.GETTABLENAMES, 'GETTABLENAMES'); + RegisterMethod(@TIBDATABASE.INDEXOFDBCONST, 'INDEXOFDBCONST'); + RegisterMethod(@TIBDATABASE.TESTCONNECTED, 'TESTCONNECTED'); + RegisterMethod(@TIBDATABASE.CHECKDATABASENAME, 'CHECKDATABASENAME'); + RegisterMethod(@TIBDATABASE.CALL, 'CALL'); + RegisterMethod(@TIBDATABASE.Open, 'OPEN'); + RegisterMethod(@TIBDATABASE.Close, 'CLOSE'); + RegisterMethod(@TIBDATABASE.ADDTRANSACTION, 'ADDTRANSACTION'); + RegisterMethod(@TIBDATABASE.FINDTRANSACTION, 'FINDTRANSACTION'); + RegisterMethod(@TIBDATABASE.FINDDEFAULTTRANSACTION, 'FINDDEFAULTTRANSACTION'); + RegisterMethod(@TIBDATABASE.REMOVETRANSACTION, 'REMOVETRANSACTION'); + RegisterMethod(@TIBDATABASE.REMOVETRANSACTIONS, 'REMOVETRANSACTIONS'); + RegisterMethod(@TIBDATABASE.SETHANDLE, 'SETHANDLE'); + RegisterPropertyHelper(@TIBDATABASEHANDLE_R,nil,'HANDLE'); + RegisterPropertyHelper(@TIBDATABASEISREADONLY_R,nil,'ISREADONLY'); + RegisterPropertyHelper(@TIBDATABASEDBPARAMBYDPB_R,@TIBDATABASEDBPARAMBYDPB_W,'DBPARAMBYDPB'); + RegisterPropertyHelper(@TIBDATABASESQLOBJECTCOUNT_R,nil,'SQLOBJECTCOUNT'); + RegisterPropertyHelper(@TIBDATABASESQLOBJECTS_R,nil,'SQLOBJECTS'); + RegisterPropertyHelper(@TIBDATABASEHANDLEISSHARED_R,nil,'HANDLEISSHARED'); + RegisterPropertyHelper(@TIBDATABASETRANSACTIONCOUNT_R,nil,'TRANSACTIONCOUNT'); + RegisterPropertyHelper(@TIBDATABASETRANSACTIONS_R,nil,'TRANSACTIONS'); + RegisterPropertyHelper(@TIBDATABASEINTERNALTRANSACTION_R,nil,'INTERNALTRANSACTION'); + RegisterMethod(@TIBDATABASE.HAS_DEFAULT_VALUE, 'HAS_DEFAULT_VALUE'); + RegisterMethod(@TIBDATABASE.HAS_COMPUTED_BLR, 'HAS_COMPUTED_BLR'); + RegisterMethod(@TIBDATABASE.FLUSHSCHEMA, 'FLUSHSCHEMA'); + RegisterPropertyHelper(@TIBDATABASEDATABASENAME_R,@TIBDATABASEDATABASENAME_W,'DATABASENAME'); + RegisterPropertyHelper(@TIBDATABASECONNECTED_R,@TIBDATABASECONNECTED_W,'CONNECTED'); + RegisterPropertyHelper(@TIBDATABASEPARAMS_R,@TIBDATABASEPARAMS_W,'PARAMS'); + RegisterPropertyHelper(@TIBDATABASEDEFAULTTRANSACTION_R,@TIBDATABASEDEFAULTTRANSACTION_W,'DEFAULTTRANSACTION'); + RegisterPropertyHelper(@TIBDATABASEIDLETIMER_R,@TIBDATABASEIDLETIMER_W,'IDLETIMER'); + RegisterPropertyHelper(@TIBDATABASESQLDIALECT_R,@TIBDATABASESQLDIALECT_W,'SQLDIALECT'); + RegisterPropertyHelper(@TIBDATABASEDBSQLDIALECT_R,nil,'DBSQLDIALECT'); + RegisterPropertyHelper(@TIBDATABASETRACEFLAGS_R,@TIBDATABASETRACEFLAGS_W,'TRACEFLAGS'); + RegisterPropertyHelper(@TIBDATABASEALLOWSTREAMEDCONNECTED_R,@TIBDATABASEALLOWSTREAMEDCONNECTED_W,'ALLOWSTREAMEDCONNECTED'); + RegisterEventPropertyHelper(@TIBDATABASEONLOGIN_R,@TIBDATABASEONLOGIN_W,'ONLOGIN'); + RegisterEventPropertyHelper(@TIBDATABASEONIDLETIMER_R,@TIBDATABASEONIDLETIMER_W,'ONIDLETIMER'); + RegisterEventPropertyHelper(@TIBDATABASEONDIALECTDOWNGRADEWARNING_R,@TIBDATABASEONDIALECTDOWNGRADEWARNING_W,'ONDIALECTDOWNGRADEWARNING'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_IBDatabase(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TIBDATABASE) do + with CL.Add(TIBTRANSACTION) do + with CL.Add(TIBBASE) do + RIRegister_TIBDATABASE(CL); + RIRegister_TIBTRANSACTION(CL); + RIRegister_TIBBASE(CL); +end; + +(* === compile-time registration functions === *) +(*----------------------------------------------------------------------------*) +procedure SIRegister_TIBTABLE(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TIBCUSTOMDATASET', 'TIBTABLE') do + with CL.AddClassN(CL.FindClass('TIBCUSTOMDATASET'),'TIBTABLE') do + begin + RegisterMethod('Procedure ADDINDEX( const NAME, FIELDS : STRING; OPTIONS : TINDEXOPTIONS; const DESCFIELDS : STRING)'); + RegisterMethod('Procedure CREATETABLE'); + RegisterMethod('Procedure DELETEINDEX( const NAME : STRING)'); + RegisterMethod('Procedure DELETETABLE'); + RegisterMethod('Procedure EMPTYTABLE'); + RegisterMethod('Procedure GETINDEXNAMES( LIST : TSTRINGS)'); + RegisterMethod('Procedure GOTOCURRENT( TABLE : TIBTABLE)'); + RegisterProperty('CURRENTDBKEY', 'TIBDBKEY', iptr); + RegisterProperty('EXISTS', 'BOOLEAN', iptr); + RegisterProperty('INDEXFIELDCOUNT', 'INTEGER', iptr); + RegisterProperty('INDEXFIELDS', 'TFIELD INTEGER', iptrw); + RegisterProperty('TABLENAMES', 'TSTRINGS', iptr); + RegisterProperty('DEFAULTINDEX', 'BOOLEAN', iptrw); + RegisterProperty('INDEXDEFS', 'TINDEXDEFS', iptrw); + RegisterProperty('INDEXFIELDNAMES', 'STRING', iptrw); + RegisterProperty('INDEXNAME', 'STRING', iptrw); + RegisterProperty('MASTERFIELDS', 'STRING', iptrw); + RegisterProperty('MASTERSOURCE', 'TDATASOURCE', iptrw); + RegisterProperty('READONLY', 'BOOLEAN', iptrw); + RegisterProperty('STOREDEFS', 'BOOLEAN', iptrw); + RegisterProperty('TABLENAME', 'STRING', iptrw); + RegisterProperty('TABLETYPES', 'TIBTABLETYPES', iptrw); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_IBTable(CL: TPSPascalCompiler); +begin + CL.AddTypeS('TIBTABLETYPE', '( TTSYSTEM, TTVIEW )'); + CL.AddTypeS('TIBTABLETYPES', 'set of TIBTABLETYPE'); + CL.AddTypeS('TINDEXNAME', 'STRING'); + CL.AddClassN(CL.FindClass('TOBJECT'),'TIBTABLE'); + SIRegister_TIBTABLE(CL); +end; + +(* === run-time registration functions === *) +(*----------------------------------------------------------------------------*) +procedure TIBTABLETABLETYPES_W(Self: TIBTABLE; const T: TIBTABLETYPES); +begin Self.TABLETYPES := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTABLETABLETYPES_R(Self: TIBTABLE; var T: TIBTABLETYPES); +begin T := Self.TABLETYPES; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTABLETABLENAME_W(Self: TIBTABLE; const T: STRING); +begin Self.TABLENAME := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTABLETABLENAME_R(Self: TIBTABLE; var T: STRING); +begin T := Self.TABLENAME; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTABLESTOREDEFS_W(Self: TIBTABLE; const T: BOOLEAN); +begin Self.STOREDEFS := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTABLESTOREDEFS_R(Self: TIBTABLE; var T: BOOLEAN); +begin T := Self.STOREDEFS; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTABLEREADONLY_W(Self: TIBTABLE; const T: BOOLEAN); +begin Self.READONLY := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTABLEREADONLY_R(Self: TIBTABLE; var T: BOOLEAN); +begin T := Self.READONLY; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTABLEMASTERSOURCE_W(Self: TIBTABLE; const T: TDATASOURCE); +begin Self.MASTERSOURCE := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTABLEMASTERSOURCE_R(Self: TIBTABLE; var T: TDATASOURCE); +begin T := Self.MASTERSOURCE; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTABLEMASTERFIELDS_W(Self: TIBTABLE; const T: STRING); +begin Self.MASTERFIELDS := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTABLEMASTERFIELDS_R(Self: TIBTABLE; var T: STRING); +begin T := Self.MASTERFIELDS; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTABLEINDEXNAME_W(Self: TIBTABLE; const T: STRING); +begin Self.INDEXNAME := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTABLEINDEXNAME_R(Self: TIBTABLE; var T: STRING); +begin T := Self.INDEXNAME; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTABLEINDEXFIELDNAMES_W(Self: TIBTABLE; const T: STRING); +begin Self.INDEXFIELDNAMES := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTABLEINDEXFIELDNAMES_R(Self: TIBTABLE; var T: STRING); +begin T := Self.INDEXFIELDNAMES; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTABLEINDEXDEFS_W(Self: TIBTABLE; const T: TINDEXDEFS); +begin Self.INDEXDEFS := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTABLEINDEXDEFS_R(Self: TIBTABLE; var T: TINDEXDEFS); +begin T := Self.INDEXDEFS; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTABLEDEFAULTINDEX_W(Self: TIBTABLE; const T: BOOLEAN); +begin Self.DEFAULTINDEX := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTABLEDEFAULTINDEX_R(Self: TIBTABLE; var T: BOOLEAN); +begin T := Self.DEFAULTINDEX; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTABLETABLENAMES_R(Self: TIBTABLE; var T: TSTRINGS); +begin T := Self.TABLENAMES; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTABLEINDEXFIELDS_W(Self: TIBTABLE; const T: TFIELD; const t1: INTEGER); +begin Self.INDEXFIELDS[t1] := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTABLEINDEXFIELDS_R(Self: TIBTABLE; var T: TFIELD; const t1: INTEGER); +begin T := Self.INDEXFIELDS[t1]; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTABLEINDEXFIELDCOUNT_R(Self: TIBTABLE; var T: INTEGER); +begin T := Self.INDEXFIELDCOUNT; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTABLEEXISTS_R(Self: TIBTABLE; var T: BOOLEAN); +begin T := Self.EXISTS; end; + +(*----------------------------------------------------------------------------*) +procedure TIBTABLECURRENTDBKEY_R(Self: TIBTABLE; var T: TIBDBKEY); +begin T := Self.CURRENTDBKEY; end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TIBTABLE(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TIBTABLE) do + begin + RegisterMethod(@TIBTABLE.ADDINDEX, 'ADDINDEX'); + RegisterMethod(@TIBTABLE.CREATETABLE, 'CREATETABLE'); + RegisterMethod(@TIBTABLE.DELETEINDEX, 'DELETEINDEX'); + RegisterMethod(@TIBTABLE.DELETETABLE, 'DELETETABLE'); + RegisterMethod(@TIBTABLE.EMPTYTABLE, 'EMPTYTABLE'); + RegisterMethod(@TIBTABLE.GETINDEXNAMES, 'GETINDEXNAMES'); + RegisterMethod(@TIBTABLE.GOTOCURRENT, 'GOTOCURRENT'); + RegisterPropertyHelper(@TIBTABLECURRENTDBKEY_R,nil,'CURRENTDBKEY'); + RegisterPropertyHelper(@TIBTABLEEXISTS_R,nil,'EXISTS'); + RegisterPropertyHelper(@TIBTABLEINDEXFIELDCOUNT_R,nil,'INDEXFIELDCOUNT'); + RegisterPropertyHelper(@TIBTABLEINDEXFIELDS_R,@TIBTABLEINDEXFIELDS_W,'INDEXFIELDS'); + RegisterPropertyHelper(@TIBTABLETABLENAMES_R,nil,'TABLENAMES'); + RegisterPropertyHelper(@TIBTABLEDEFAULTINDEX_R,@TIBTABLEDEFAULTINDEX_W,'DEFAULTINDEX'); + RegisterPropertyHelper(@TIBTABLEINDEXDEFS_R,@TIBTABLEINDEXDEFS_W,'INDEXDEFS'); + RegisterPropertyHelper(@TIBTABLEINDEXFIELDNAMES_R,@TIBTABLEINDEXFIELDNAMES_W,'INDEXFIELDNAMES'); + RegisterPropertyHelper(@TIBTABLEINDEXNAME_R,@TIBTABLEINDEXNAME_W,'INDEXNAME'); + RegisterPropertyHelper(@TIBTABLEMASTERFIELDS_R,@TIBTABLEMASTERFIELDS_W,'MASTERFIELDS'); + RegisterPropertyHelper(@TIBTABLEMASTERSOURCE_R,@TIBTABLEMASTERSOURCE_W,'MASTERSOURCE'); + RegisterPropertyHelper(@TIBTABLEREADONLY_R,@TIBTABLEREADONLY_W,'READONLY'); + RegisterPropertyHelper(@TIBTABLESTOREDEFS_R,@TIBTABLESTOREDEFS_W,'STOREDEFS'); + RegisterPropertyHelper(@TIBTABLETABLENAME_R,@TIBTABLETABLENAME_W,'TABLENAME'); + RegisterPropertyHelper(@TIBTABLETABLETYPES_R,@TIBTABLETABLETYPES_W,'TABLETYPES'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_IBTable(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TIBTABLE) do + RIRegister_TIBTABLE(CL); +end; + +(* === compile-time registration functions === *) +(*----------------------------------------------------------------------------*) +procedure SIRegister_TIBSQL(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TCOMPONENT', 'TIBSQL') do + with CL.AddClassN(CL.FindClass('TCOMPONENT'),'TIBSQL') do + begin + RegisterMethod('Procedure BATCHINPUT( INPUTOBJECT : TIBBATCHINPUT)'); + RegisterMethod('Procedure BATCHOUTPUT( OUTPUTOBJECT : TIBBATCHOUTPUT)'); + RegisterMethod('Function CALL( ERRCODE : ISC_STATUS; RAISEERROR : BOOLEAN) : ISC_STATUS'); + RegisterMethod('Procedure CHECKCLOSED'); + RegisterMethod('Procedure CHECKOPEN'); + RegisterMethod('Procedure CHECKVALIDSTATEMENT'); + RegisterMethod('Procedure CLOSE'); + RegisterMethod('Function CURRENT : TIBXSQLDA'); + RegisterMethod('Procedure EXECQUERY'); + RegisterMethod('Function FIELDBYNAME( FIELDNAME : STRING) : TIBXSQLVAR'); + RegisterMethod('Procedure FREEHANDLE'); + RegisterMethod('Function NEXT : TIBXSQLDA'); + RegisterMethod('Procedure PREPARE'); + RegisterMethod('Function GETUNIQUERELATIONNAME : STRING'); + RegisterMethod('Function PARAMBYNAME( IDX : STRING) : TIBXSQLVAR'); + RegisterProperty('BOF', 'BOOLEAN', iptr); + RegisterProperty('DBHANDLE', 'PISC_DB_HANDLE', iptr); + RegisterProperty('EOF', 'BOOLEAN', iptr); + RegisterProperty('FIELDS', 'TIBXSQLVAR INTEGER', iptr); + RegisterProperty('FIELDINDEX', 'INTEGER STRING', iptr); + RegisterProperty('OPEN', 'BOOLEAN', iptr); + RegisterProperty('PARAMS', 'TIBXSQLDA', iptr); + RegisterProperty('PLAN', 'STRING', iptr); + RegisterProperty('PREPARED', 'BOOLEAN', iptr); + RegisterProperty('RECORDCOUNT', 'INTEGER', iptr); + RegisterProperty('ROWSAFFECTED', 'INTEGER', iptr); + RegisterProperty('SQLTYPE', 'TIBSQLTYPES', iptr); + RegisterProperty('TRHANDLE', 'PISC_TR_HANDLE', iptr); + RegisterProperty('HANDLE', 'TISC_STMT_HANDLE', iptr); + RegisterProperty('GENERATEPARAMNAMES', 'BOOLEAN', iptrw); + RegisterProperty('UNIQUERELATIONNAME', 'STRING', iptr); + RegisterProperty('DATABASE', 'TIBDATABASE', iptrw); + RegisterProperty('GOTOFIRSTRECORDONEXECUTE', 'BOOLEAN', iptrw); + RegisterProperty('PARAMCHECK', 'BOOLEAN', iptrw); + RegisterProperty('SQL', 'TSTRINGS', iptrw); + RegisterProperty('TRANSACTION', 'TIBTRANSACTION', iptrw); + RegisterProperty('ONSQLCHANGING', 'TNOTIFYEVENT', iptrw); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TIBOUTPUTXML(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TOBJECT', 'TIBOUTPUTXML') do + with CL.AddClassN(CL.FindClass('TOBJECT'),'TIBOUTPUTXML') do + begin + RegisterMethod('Procedure WRITEXML( SQL : TIBSQL)'); + RegisterProperty('HEADERTAG', 'STRING', iptrw); + RegisterProperty('DATABASETAG', 'STRING', iptrw); + RegisterProperty('STREAM', 'TSTREAM', iptrw); + RegisterProperty('TABLETAG', 'STRING', iptrw); + RegisterProperty('ROWTAG', 'STRING', iptrw); + RegisterProperty('FLAGS', 'TIBXMLFLAGS', iptrw); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TIBINPUTRAWFILE(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TIBBATCHINPUT', 'TIBINPUTRAWFILE') do + with CL.AddClassN(CL.FindClass('TIBBATCHINPUT'),'TIBINPUTRAWFILE') do + begin + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TIBOUTPUTRAWFILE(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TIBBATCHOUTPUT', 'TIBOUTPUTRAWFILE') do + with CL.AddClassN(CL.FindClass('TIBBATCHOUTPUT'),'TIBOUTPUTRAWFILE') do + begin + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TIBINPUTDELIMITEDFILE(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TIBBATCHINPUT', 'TIBINPUTDELIMITEDFILE') do + with CL.AddClassN(CL.FindClass('TIBBATCHINPUT'),'TIBINPUTDELIMITEDFILE') do + begin + RegisterMethod('Function GETCOLUMN( var COL : STRING) : INTEGER'); + RegisterProperty('COLDELIMITER', 'STRING', iptrw); + RegisterProperty('READBLANKSASNULL', 'BOOLEAN', iptrw); + RegisterProperty('ROWDELIMITER', 'STRING', iptrw); + RegisterProperty('SKIPTITLES', 'BOOLEAN', iptrw); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TIBOUTPUTDELIMITEDFILE(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TIBBATCHOUTPUT', 'TIBOUTPUTDELIMITEDFILE') do + with CL.AddClassN(CL.FindClass('TIBBATCHOUTPUT'),'TIBOUTPUTDELIMITEDFILE') do + begin + RegisterProperty('COLDELIMITER', 'STRING', iptrw); + RegisterProperty('OUTPUTTITLES', 'BOOLEAN', iptrw); + RegisterProperty('ROWDELIMITER', 'STRING', iptrw); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TIBBATCHOUTPUT(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TIBBATCH', 'TIBBATCHOUTPUT') do + with CL.AddClassN(CL.FindClass('TIBBATCH'),'TIBBATCHOUTPUT') do + begin + RegisterMethod('Function WRITECOLUMNS : BOOLEAN'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TIBBATCHINPUT(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TIBBATCH', 'TIBBATCHINPUT') do + with CL.AddClassN(CL.FindClass('TIBBATCH'),'TIBBATCHINPUT') do + begin + RegisterMethod('Function READPARAMETERS : BOOLEAN'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TIBBATCH(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TOBJECT', 'TIBBATCH') do + with CL.AddClassN(CL.FindClass('TOBJECT'),'TIBBATCH') do + begin + RegisterMethod('Procedure READYFILE'); + RegisterProperty('COLUMNS', 'TIBXSQLDA', iptrw); + RegisterProperty('FILENAME', 'STRING', iptrw); + RegisterProperty('PARAMS', 'TIBXSQLDA', iptrw); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TIBXSQLDA(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TOBJECT', 'TIBXSQLDA') do + with CL.AddClassN(CL.FindClass('TOBJECT'),'TIBXSQLDA') do + begin + RegisterMethod('Constructor CREATE( QUERY : TIBSQL)'); + RegisterMethod('Procedure ADDNAME( FIELDNAME : STRING; IDX : INTEGER)'); + RegisterMethod('Function BYNAME( IDX : STRING) : TIBXSQLVAR'); + RegisterProperty('ASXSQLDA', 'PXSQLDA', iptr); + RegisterProperty('COUNT', 'INTEGER', iptrw); + RegisterProperty('MODIFIED', 'BOOLEAN', iptr); + RegisterProperty('NAMES', 'STRING', iptr); + RegisterProperty('RECORDSIZE', 'INTEGER', iptr); + RegisterProperty('VARS', 'TIBXSQLVAR INTEGER', iptr); + SetDefaultPropery('VARS'); + RegisterProperty('UNIQUERELATIONNAME', 'STRING', iptr); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TIBXSQLVAR(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TOBJECT', 'TIBXSQLVAR') do + with CL.AddClassN(CL.FindClass('TOBJECT'),'TIBXSQLVAR') do + begin + RegisterMethod('Constructor CREATE( PARENT : TIBXSQLDA; QUERY : TIBSQL)'); + RegisterMethod('Procedure ASSIGN( SOURCE : TIBXSQLVAR)'); + RegisterMethod('Procedure LOADFROMFILE( const FILENAME : STRING)'); + RegisterMethod('Procedure LOADFROMSTREAM( STREAM : TSTREAM)'); + RegisterMethod('Procedure SAVETOFILE( const FILENAME : STRING)'); + RegisterMethod('Procedure SAVETOSTREAM( STREAM : TSTREAM)'); + RegisterMethod('Procedure CLEAR'); + RegisterProperty('ASDATE', 'TDATETIME', iptrw); + RegisterProperty('ASTIME', 'TDATETIME', iptrw); + RegisterProperty('ASDATETIME', 'TDATETIME', iptrw); + RegisterProperty('ASDOUBLE', 'DOUBLE', iptrw); + RegisterProperty('ASFLOAT', 'FLOAT', iptrw); + RegisterProperty('ASCURRENCY', 'CURRENCY', iptrw); + RegisterProperty('ASINT64', 'INT64', iptrw); + RegisterProperty('ASINTEGER', 'INTEGER', iptrw); + RegisterProperty('ASLONG', 'LONG', iptrw); + RegisterProperty('ASPOINTER', 'POINTER', iptrw); + RegisterProperty('ASQUAD', 'TISC_QUAD', iptrw); + RegisterProperty('ASSHORT', 'SHORT', iptrw); + RegisterProperty('ASSTRING', 'STRING', iptrw); + RegisterProperty('ASTRIMSTRING', 'STRING', iptrw); + RegisterProperty('ASVARIANT', 'VARIANT', iptrw); + RegisterProperty('ASXSQLVAR', 'PXSQLVAR', iptrw); + RegisterProperty('DATA', 'PXSQLVAR', iptrw); + RegisterProperty('ISNULL', 'BOOLEAN', iptrw); + RegisterProperty('ISNULLABLE', 'BOOLEAN', iptrw); + RegisterProperty('INDEX', 'INTEGER', iptr); + RegisterProperty('MODIFIED', 'BOOLEAN', iptrw); + RegisterProperty('NAME', 'STRING', iptr); + RegisterProperty('SIZE', 'INTEGER', iptr); + RegisterProperty('SQLTYPE', 'INTEGER', iptr); + RegisterProperty('VALUE', 'VARIANT', iptrw); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_IBSQL(CL: TPSPascalCompiler); +begin + CL.AddClassN(CL.FindClass('TOBJECT'),'TIBSQL'); + CL.AddClassN(CL.FindClass('TOBJECT'),'TIBXSQLDA'); + SIRegister_TIBXSQLVAR(CL); + CL.AddTypeS('TIBXSQLVARARRAY', 'array of TIBXSQLVAR'); + SIRegister_TIBXSQLDA(CL); + SIRegister_TIBBATCH(CL); + SIRegister_TIBBATCHINPUT(CL); + SIRegister_TIBBATCHOUTPUT(CL); + SIRegister_TIBOUTPUTDELIMITEDFILE(CL); + SIRegister_TIBINPUTDELIMITEDFILE(CL); + SIRegister_TIBOUTPUTRAWFILE(CL); + SIRegister_TIBINPUTRAWFILE(CL); + CL.AddTypeS('TIBXMLFLAG', '( XMLATTRIBUTE, XMLDISPLAYNULL, XMLNOHEADER )'); + CL.AddTypeS('TIBXMLFLAGS', 'set of TIBXMLFLAG'); + SIRegister_TIBOUTPUTXML(CL); + CL.AddTypeS('TIBSQLTYPES', '( SQLUNKNOWN, SQLSELECT, SQLINSERT, SQLUPDATE, SQ' + +'LDELETE, SQLDDL, SQLGETSEGMENT, SQLPUTSEGMENT, SQLEXECPROCEDURE, SQLSTARTT' + +'RANSACTION, SQLCOMMIT, SQLROLLBACK, SQLSELECTFORUPDATE, SQLSETGENERATOR )'); + SIRegister_TIBSQL(CL); + CL.AddDelphiFunction('Procedure OUTPUTXML( SQLOBJECT : TIBSQL; OUTPUTOBJECT : TIBOUTPUTXML)'); +end; + +(* === run-time registration functions === *) +(*----------------------------------------------------------------------------*) +procedure TIBSQLONSQLCHANGING_W(Self: TIBSQL; const T: TNOTIFYEVENT); +begin Self.ONSQLCHANGING := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBSQLONSQLCHANGING_R(Self: TIBSQL; var T: TNOTIFYEVENT); +begin T := Self.ONSQLCHANGING; end; + +(*----------------------------------------------------------------------------*) +procedure TIBSQLTRANSACTION_W(Self: TIBSQL; const T: TIBTRANSACTION); +begin Self.TRANSACTION := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBSQLTRANSACTION_R(Self: TIBSQL; var T: TIBTRANSACTION); +begin T := Self.TRANSACTION; end; + +(*----------------------------------------------------------------------------*) +procedure TIBSQLSQL_W(Self: TIBSQL; const T: TSTRINGS); +begin Self.SQL := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBSQLSQL_R(Self: TIBSQL; var T: TSTRINGS); +begin T := Self.SQL; end; + +(*----------------------------------------------------------------------------*) +procedure TIBSQLPARAMCHECK_W(Self: TIBSQL; const T: BOOLEAN); +begin Self.PARAMCHECK := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBSQLPARAMCHECK_R(Self: TIBSQL; var T: BOOLEAN); +begin T := Self.PARAMCHECK; end; + +(*----------------------------------------------------------------------------*) +procedure TIBSQLGOTOFIRSTRECORDONEXECUTE_W(Self: TIBSQL; const T: BOOLEAN); +begin Self.GOTOFIRSTRECORDONEXECUTE := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBSQLGOTOFIRSTRECORDONEXECUTE_R(Self: TIBSQL; var T: BOOLEAN); +begin T := Self.GOTOFIRSTRECORDONEXECUTE; end; + +(*----------------------------------------------------------------------------*) +procedure TIBSQLDATABASE_W(Self: TIBSQL; const T: TIBDATABASE); +begin Self.DATABASE := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBSQLDATABASE_R(Self: TIBSQL; var T: TIBDATABASE); +begin T := Self.DATABASE; end; + +(*----------------------------------------------------------------------------*) +procedure TIBSQLUNIQUERELATIONNAME_R(Self: TIBSQL; var T: STRING); +begin T := Self.UNIQUERELATIONNAME; end; + +(*----------------------------------------------------------------------------*) +procedure TIBSQLGENERATEPARAMNAMES_W(Self: TIBSQL; const T: BOOLEAN); +begin Self.GENERATEPARAMNAMES := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBSQLGENERATEPARAMNAMES_R(Self: TIBSQL; var T: BOOLEAN); +begin T := Self.GENERATEPARAMNAMES; end; + +(*----------------------------------------------------------------------------*) +procedure TIBSQLHANDLE_R(Self: TIBSQL; var T: TISC_STMT_HANDLE); +begin T := Self.HANDLE; end; + +(*----------------------------------------------------------------------------*) +procedure TIBSQLTRHANDLE_R(Self: TIBSQL; var T: PISC_TR_HANDLE); +begin T := Self.TRHANDLE; end; + +(*----------------------------------------------------------------------------*) +procedure TIBSQLSQLTYPE_R(Self: TIBSQL; var T: TIBSQLTYPES); +begin T := Self.SQLTYPE; end; + +(*----------------------------------------------------------------------------*) +procedure TIBSQLROWSAFFECTED_R(Self: TIBSQL; var T: INTEGER); +begin T := Self.ROWSAFFECTED; end; + +(*----------------------------------------------------------------------------*) +procedure TIBSQLRECORDCOUNT_R(Self: TIBSQL; var T: INTEGER); +begin T := Self.RECORDCOUNT; end; + +(*----------------------------------------------------------------------------*) +procedure TIBSQLPREPARED_R(Self: TIBSQL; var T: BOOLEAN); +begin T := Self.PREPARED; end; + +(*----------------------------------------------------------------------------*) +procedure TIBSQLPLAN_R(Self: TIBSQL; var T: STRING); +begin T := Self.PLAN; end; + +(*----------------------------------------------------------------------------*) +procedure TIBSQLPARAMS_R(Self: TIBSQL; var T: TIBXSQLDA); +begin T := Self.PARAMS; end; + +(*----------------------------------------------------------------------------*) +procedure TIBSQLOPEN_R(Self: TIBSQL; var T: BOOLEAN); +begin T := Self.OPEN; end; + +(*----------------------------------------------------------------------------*) +procedure TIBSQLFIELDINDEX_R(Self: TIBSQL; var T: INTEGER; const t1: STRING); +begin T := Self.FIELDINDEX[t1]; end; + +(*----------------------------------------------------------------------------*) +procedure TIBSQLFIELDS_R(Self: TIBSQL; var T: TIBXSQLVAR; const t1: INTEGER); +begin T := Self.FIELDS[t1]; end; + +(*----------------------------------------------------------------------------*) +procedure TIBSQLEOF_R(Self: TIBSQL; var T: BOOLEAN); +begin T := Self.EOF; end; + +(*----------------------------------------------------------------------------*) +procedure TIBSQLDBHANDLE_R(Self: TIBSQL; var T: PISC_DB_HANDLE); +begin T := Self.DBHANDLE; end; + +(*----------------------------------------------------------------------------*) +procedure TIBSQLBOF_R(Self: TIBSQL; var T: BOOLEAN); +begin T := Self.BOF; end; + +(*----------------------------------------------------------------------------*) +procedure TIBOUTPUTXMLFLAGS_W(Self: TIBOUTPUTXML; const T: TIBXMLFLAGS); +begin Self.FLAGS := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBOUTPUTXMLFLAGS_R(Self: TIBOUTPUTXML; var T: TIBXMLFLAGS); +begin T := Self.FLAGS; end; + +(*----------------------------------------------------------------------------*) +procedure TIBOUTPUTXMLROWTAG_W(Self: TIBOUTPUTXML; const T: STRING); +begin Self.ROWTAG := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBOUTPUTXMLROWTAG_R(Self: TIBOUTPUTXML; var T: STRING); +begin T := Self.ROWTAG; end; + +(*----------------------------------------------------------------------------*) +procedure TIBOUTPUTXMLTABLETAG_W(Self: TIBOUTPUTXML; const T: STRING); +begin Self.TABLETAG := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBOUTPUTXMLTABLETAG_R(Self: TIBOUTPUTXML; var T: STRING); +begin T := Self.TABLETAG; end; + +(*----------------------------------------------------------------------------*) +procedure TIBOUTPUTXMLSTREAM_W(Self: TIBOUTPUTXML; const T: TSTREAM); +begin Self.STREAM := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBOUTPUTXMLSTREAM_R(Self: TIBOUTPUTXML; var T: TSTREAM); +begin T := Self.STREAM; end; + +(*----------------------------------------------------------------------------*) +procedure TIBOUTPUTXMLDATABASETAG_W(Self: TIBOUTPUTXML; const T: STRING); +begin Self.DATABASETAG := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBOUTPUTXMLDATABASETAG_R(Self: TIBOUTPUTXML; var T: STRING); +begin T := Self.DATABASETAG; end; + +(*----------------------------------------------------------------------------*) +procedure TIBOUTPUTXMLHEADERTAG_W(Self: TIBOUTPUTXML; const T: STRING); +begin Self.HEADERTAG := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBOUTPUTXMLHEADERTAG_R(Self: TIBOUTPUTXML; var T: STRING); +begin T := Self.HEADERTAG; end; + +(*----------------------------------------------------------------------------*) +procedure TIBINPUTDELIMITEDFILESKIPTITLES_W(Self: TIBINPUTDELIMITEDFILE; const T: BOOLEAN); +begin Self.SKIPTITLES := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBINPUTDELIMITEDFILESKIPTITLES_R(Self: TIBINPUTDELIMITEDFILE; var T: BOOLEAN); +begin T := Self.SKIPTITLES; end; + +(*----------------------------------------------------------------------------*) +procedure TIBINPUTDELIMITEDFILEROWDELIMITER_W(Self: TIBINPUTDELIMITEDFILE; const T: STRING); +begin Self.ROWDELIMITER := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBINPUTDELIMITEDFILEROWDELIMITER_R(Self: TIBINPUTDELIMITEDFILE; var T: STRING); +begin T := Self.ROWDELIMITER; end; + +(*----------------------------------------------------------------------------*) +procedure TIBINPUTDELIMITEDFILEREADBLANKSASNULL_W(Self: TIBINPUTDELIMITEDFILE; const T: BOOLEAN); +begin Self.READBLANKSASNULL := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBINPUTDELIMITEDFILEREADBLANKSASNULL_R(Self: TIBINPUTDELIMITEDFILE; var T: BOOLEAN); +begin T := Self.READBLANKSASNULL; end; + +(*----------------------------------------------------------------------------*) +procedure TIBINPUTDELIMITEDFILECOLDELIMITER_W(Self: TIBINPUTDELIMITEDFILE; const T: STRING); +begin Self.COLDELIMITER := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBINPUTDELIMITEDFILECOLDELIMITER_R(Self: TIBINPUTDELIMITEDFILE; var T: STRING); +begin T := Self.COLDELIMITER; end; + +(*----------------------------------------------------------------------------*) +procedure TIBOUTPUTDELIMITEDFILEROWDELIMITER_W(Self: TIBOUTPUTDELIMITEDFILE; const T: STRING); +begin Self.ROWDELIMITER := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBOUTPUTDELIMITEDFILEROWDELIMITER_R(Self: TIBOUTPUTDELIMITEDFILE; var T: STRING); +begin T := Self.ROWDELIMITER; end; + +(*----------------------------------------------------------------------------*) +procedure TIBOUTPUTDELIMITEDFILEOUTPUTTITLES_W(Self: TIBOUTPUTDELIMITEDFILE; const T: BOOLEAN); +begin Self.OUTPUTTITLES := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBOUTPUTDELIMITEDFILEOUTPUTTITLES_R(Self: TIBOUTPUTDELIMITEDFILE; var T: BOOLEAN); +begin T := Self.OUTPUTTITLES; end; + +(*----------------------------------------------------------------------------*) +procedure TIBOUTPUTDELIMITEDFILECOLDELIMITER_W(Self: TIBOUTPUTDELIMITEDFILE; const T: STRING); +begin Self.COLDELIMITER := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBOUTPUTDELIMITEDFILECOLDELIMITER_R(Self: TIBOUTPUTDELIMITEDFILE; var T: STRING); +begin T := Self.COLDELIMITER; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLDAUNIQUERELATIONNAME_R(Self: TIBXSQLDA; var T: STRING); +begin T := Self.UNIQUERELATIONNAME; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLDAVARS_R(Self: TIBXSQLDA; var T: TIBXSQLVAR; const t1: INTEGER); +begin T := Self.VARS[t1]; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLDARECORDSIZE_R(Self: TIBXSQLDA; var T: INTEGER); +begin T := Self.RECORDSIZE; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLDANAMES_R(Self: TIBXSQLDA; var T: STRING); +begin T := Self.NAMES; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLDAMODIFIED_R(Self: TIBXSQLDA; var T: BOOLEAN); +begin T := Self.MODIFIED; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLDACOUNT_W(Self: TIBXSQLDA; const T: INTEGER); +begin Self.COUNT := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLDACOUNT_R(Self: TIBXSQLDA; var T: INTEGER); +begin T := Self.COUNT; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLDAASXSQLDA_R(Self: TIBXSQLDA; var T: PXSQLDA); +begin T := Self.ASXSQLDA; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARVALUE_W(Self: TIBXSQLVAR; const T: VARIANT); +begin Self.VALUE := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARVALUE_R(Self: TIBXSQLVAR; var T: VARIANT); +begin T := Self.VALUE; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARSQLTYPE_R(Self: TIBXSQLVAR; var T: INTEGER); +begin T := Self.SQLTYPE; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARSIZE_R(Self: TIBXSQLVAR; var T: INTEGER); +begin T := Self.SIZE; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARNAME_R(Self: TIBXSQLVAR; var T: STRING); +begin T := Self.NAME; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARMODIFIED_W(Self: TIBXSQLVAR; const T: BOOLEAN); +begin Self.MODIFIED := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARMODIFIED_R(Self: TIBXSQLVAR; var T: BOOLEAN); +begin T := Self.MODIFIED; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARINDEX_R(Self: TIBXSQLVAR; var T: INTEGER); +begin T := Self.INDEX; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARISNULLABLE_W(Self: TIBXSQLVAR; const T: BOOLEAN); +begin Self.ISNULLABLE := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARISNULLABLE_R(Self: TIBXSQLVAR; var T: BOOLEAN); +begin T := Self.ISNULLABLE; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARISNULL_W(Self: TIBXSQLVAR; const T: BOOLEAN); +begin Self.ISNULL := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARISNULL_R(Self: TIBXSQLVAR; var T: BOOLEAN); +begin T := Self.ISNULL; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARDATA_W(Self: TIBXSQLVAR; const T: PXSQLVAR); +begin Self.DATA := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARDATA_R(Self: TIBXSQLVAR; var T: PXSQLVAR); +begin T := Self.DATA; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASXSQLVAR_W(Self: TIBXSQLVAR; const T: PXSQLVAR); +begin Self.ASXSQLVAR := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASXSQLVAR_R(Self: TIBXSQLVAR; var T: PXSQLVAR); +begin T := Self.ASXSQLVAR; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASVARIANT_W(Self: TIBXSQLVAR; const T: VARIANT); +begin Self.ASVARIANT := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASVARIANT_R(Self: TIBXSQLVAR; var T: VARIANT); +begin T := Self.ASVARIANT; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASTRIMSTRING_W(Self: TIBXSQLVAR; const T: STRING); +begin Self.ASTRIMSTRING := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASTRIMSTRING_R(Self: TIBXSQLVAR; var T: STRING); +begin T := Self.ASTRIMSTRING; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASSTRING_W(Self: TIBXSQLVAR; const T: STRING); +begin Self.ASSTRING := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASSTRING_R(Self: TIBXSQLVAR; var T: STRING); +begin T := Self.ASSTRING; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASSHORT_W(Self: TIBXSQLVAR; const T: SHORT); +begin Self.ASSHORT := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASSHORT_R(Self: TIBXSQLVAR; var T: SHORT); +begin T := Self.ASSHORT; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASQUAD_W(Self: TIBXSQLVAR; const T: TISC_QUAD); +begin Self.ASQUAD := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASQUAD_R(Self: TIBXSQLVAR; var T: TISC_QUAD); +begin T := Self.ASQUAD; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASPOINTER_W(Self: TIBXSQLVAR; const T: POINTER); +begin Self.ASPOINTER := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASPOINTER_R(Self: TIBXSQLVAR; var T: POINTER); +begin T := Self.ASPOINTER; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASLONG_W(Self: TIBXSQLVAR; const T: LONG); +begin Self.ASLONG := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASLONG_R(Self: TIBXSQLVAR; var T: LONG); +begin T := Self.ASLONG; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASINTEGER_W(Self: TIBXSQLVAR; const T: INTEGER); +begin Self.ASINTEGER := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASINTEGER_R(Self: TIBXSQLVAR; var T: INTEGER); +begin T := Self.ASINTEGER; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASINT64_W(Self: TIBXSQLVAR; const T: INT64); +begin Self.ASINT64 := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASINT64_R(Self: TIBXSQLVAR; var T: INT64); +begin T := Self.ASINT64; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASCURRENCY_W(Self: TIBXSQLVAR; const T: CURRENCY); +begin Self.ASCURRENCY := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASCURRENCY_R(Self: TIBXSQLVAR; var T: CURRENCY); +begin T := Self.ASCURRENCY; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASFLOAT_W(Self: TIBXSQLVAR; const T: FLOAT); +begin Self.ASFLOAT := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASFLOAT_R(Self: TIBXSQLVAR; var T: FLOAT); +begin T := Self.ASFLOAT; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASDOUBLE_W(Self: TIBXSQLVAR; const T: DOUBLE); +begin Self.ASDOUBLE := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASDOUBLE_R(Self: TIBXSQLVAR; var T: DOUBLE); +begin T := Self.ASDOUBLE; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASDATETIME_W(Self: TIBXSQLVAR; const T: TDATETIME); +begin Self.ASDATETIME := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASDATETIME_R(Self: TIBXSQLVAR; var T: TDATETIME); +begin T := Self.ASDATETIME; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASTIME_W(Self: TIBXSQLVAR; const T: TDATETIME); +begin Self.ASTIME := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASTIME_R(Self: TIBXSQLVAR; var T: TDATETIME); +begin T := Self.ASTIME; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASDATE_W(Self: TIBXSQLVAR; const T: TDATETIME); +begin Self.ASDATE := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBXSQLVARASDATE_R(Self: TIBXSQLVAR; var T: TDATETIME); +begin T := Self.ASDATE; end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_IBSQL_Routines(S: TIFPSExec); +begin + S.RegisterDelphiFunction(@OUTPUTXML, 'OUTPUTXML', cdRegister); +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TIBSQL(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TIBSQL) do + begin + RegisterMethod(@TIBSQL.BATCHINPUT, 'BATCHINPUT'); + RegisterMethod(@TIBSQL.BATCHOUTPUT, 'BATCHOUTPUT'); + RegisterMethod(@TIBSQL.CALL, 'CALL'); + RegisterMethod(@TIBSQL.CHECKCLOSED, 'CHECKCLOSED'); + RegisterMethod(@TIBSQL.CHECKOPEN, 'CHECKOPEN'); + RegisterMethod(@TIBSQL.CHECKVALIDSTATEMENT, 'CHECKVALIDSTATEMENT'); + RegisterMethod(@TIBSQL.CLOSE, 'CLOSE'); + RegisterMethod(@TIBSQL.CURRENT, 'CURRENT'); + RegisterMethod(@TIBSQL.EXECQUERY, 'EXECQUERY'); + RegisterMethod(@TIBSQL.FIELDBYNAME, 'FIELDBYNAME'); + RegisterMethod(@TIBSQL.FREEHANDLE, 'FREEHANDLE'); + RegisterMethod(@TIBSQL.NEXT, 'NEXT'); + RegisterMethod(@TIBSQL.PREPARE, 'PREPARE'); + RegisterMethod(@TIBSQL.GETUNIQUERELATIONNAME, 'GETUNIQUERELATIONNAME'); + RegisterMethod(@TIBSQL.PARAMBYNAME, 'PARAMBYNAME'); + RegisterPropertyHelper(@TIBSQLBOF_R,nil,'BOF'); + RegisterPropertyHelper(@TIBSQLDBHANDLE_R,nil,'DBHANDLE'); + RegisterPropertyHelper(@TIBSQLEOF_R,nil,'EOF'); + RegisterPropertyHelper(@TIBSQLFIELDS_R,nil,'FIELDS'); + RegisterPropertyHelper(@TIBSQLFIELDINDEX_R,nil,'FIELDINDEX'); + RegisterPropertyHelper(@TIBSQLOPEN_R,nil,'OPEN'); + RegisterPropertyHelper(@TIBSQLPARAMS_R,nil,'PARAMS'); + RegisterPropertyHelper(@TIBSQLPLAN_R,nil,'PLAN'); + RegisterPropertyHelper(@TIBSQLPREPARED_R,nil,'PREPARED'); + RegisterPropertyHelper(@TIBSQLRECORDCOUNT_R,nil,'RECORDCOUNT'); + RegisterPropertyHelper(@TIBSQLROWSAFFECTED_R,nil,'ROWSAFFECTED'); + RegisterPropertyHelper(@TIBSQLSQLTYPE_R,nil,'SQLTYPE'); + RegisterPropertyHelper(@TIBSQLTRHANDLE_R,nil,'TRHANDLE'); + RegisterPropertyHelper(@TIBSQLHANDLE_R,nil,'HANDLE'); + RegisterPropertyHelper(@TIBSQLGENERATEPARAMNAMES_R,@TIBSQLGENERATEPARAMNAMES_W,'GENERATEPARAMNAMES'); + RegisterPropertyHelper(@TIBSQLUNIQUERELATIONNAME_R,nil,'UNIQUERELATIONNAME'); + RegisterPropertyHelper(@TIBSQLDATABASE_R,@TIBSQLDATABASE_W,'DATABASE'); + RegisterPropertyHelper(@TIBSQLGOTOFIRSTRECORDONEXECUTE_R,@TIBSQLGOTOFIRSTRECORDONEXECUTE_W,'GOTOFIRSTRECORDONEXECUTE'); + RegisterPropertyHelper(@TIBSQLPARAMCHECK_R,@TIBSQLPARAMCHECK_W,'PARAMCHECK'); + RegisterPropertyHelper(@TIBSQLSQL_R,@TIBSQLSQL_W,'SQL'); + RegisterPropertyHelper(@TIBSQLTRANSACTION_R,@TIBSQLTRANSACTION_W,'TRANSACTION'); + RegisterEventPropertyHelper(@TIBSQLONSQLCHANGING_R,@TIBSQLONSQLCHANGING_W,'ONSQLCHANGING'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TIBOUTPUTXML(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TIBOUTPUTXML) do + begin + RegisterMethod(@TIBOUTPUTXML.WRITEXML, 'WRITEXML'); + RegisterPropertyHelper(@TIBOUTPUTXMLHEADERTAG_R,@TIBOUTPUTXMLHEADERTAG_W,'HEADERTAG'); + RegisterPropertyHelper(@TIBOUTPUTXMLDATABASETAG_R,@TIBOUTPUTXMLDATABASETAG_W,'DATABASETAG'); + RegisterPropertyHelper(@TIBOUTPUTXMLSTREAM_R,@TIBOUTPUTXMLSTREAM_W,'STREAM'); + RegisterPropertyHelper(@TIBOUTPUTXMLTABLETAG_R,@TIBOUTPUTXMLTABLETAG_W,'TABLETAG'); + RegisterPropertyHelper(@TIBOUTPUTXMLROWTAG_R,@TIBOUTPUTXMLROWTAG_W,'ROWTAG'); + RegisterPropertyHelper(@TIBOUTPUTXMLFLAGS_R,@TIBOUTPUTXMLFLAGS_W,'FLAGS'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TIBINPUTRAWFILE(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TIBINPUTRAWFILE) do + begin + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TIBOUTPUTRAWFILE(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TIBOUTPUTRAWFILE) do + begin + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TIBINPUTDELIMITEDFILE(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TIBINPUTDELIMITEDFILE) do + begin + RegisterMethod(@TIBINPUTDELIMITEDFILE.GETCOLUMN, 'GETCOLUMN'); + RegisterPropertyHelper(@TIBINPUTDELIMITEDFILECOLDELIMITER_R,@TIBINPUTDELIMITEDFILECOLDELIMITER_W,'COLDELIMITER'); + RegisterPropertyHelper(@TIBINPUTDELIMITEDFILEREADBLANKSASNULL_R,@TIBINPUTDELIMITEDFILEREADBLANKSASNULL_W,'READBLANKSASNULL'); + RegisterPropertyHelper(@TIBINPUTDELIMITEDFILEROWDELIMITER_R,@TIBINPUTDELIMITEDFILEROWDELIMITER_W,'ROWDELIMITER'); + RegisterPropertyHelper(@TIBINPUTDELIMITEDFILESKIPTITLES_R,@TIBINPUTDELIMITEDFILESKIPTITLES_W,'SKIPTITLES'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TIBOUTPUTDELIMITEDFILE(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TIBOUTPUTDELIMITEDFILE) do + begin + RegisterPropertyHelper(@TIBOUTPUTDELIMITEDFILECOLDELIMITER_R,@TIBOUTPUTDELIMITEDFILECOLDELIMITER_W,'COLDELIMITER'); + RegisterPropertyHelper(@TIBOUTPUTDELIMITEDFILEOUTPUTTITLES_R,@TIBOUTPUTDELIMITEDFILEOUTPUTTITLES_W,'OUTPUTTITLES'); + RegisterPropertyHelper(@TIBOUTPUTDELIMITEDFILEROWDELIMITER_R,@TIBOUTPUTDELIMITEDFILEROWDELIMITER_W,'ROWDELIMITER'); + end; +end; + + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TIBXSQLDA(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TIBXSQLDA) do + begin + RegisterConstructor(@TIBXSQLDA.CREATE, 'CREATE'); + RegisterMethod(@TIBXSQLDA.ADDNAME, 'ADDNAME'); + RegisterMethod(@TIBXSQLDA.BYNAME, 'BYNAME'); + RegisterPropertyHelper(@TIBXSQLDAASXSQLDA_R,nil,'ASXSQLDA'); + RegisterPropertyHelper(@TIBXSQLDACOUNT_R,@TIBXSQLDACOUNT_W,'COUNT'); + RegisterPropertyHelper(@TIBXSQLDAMODIFIED_R,nil,'MODIFIED'); + RegisterPropertyHelper(@TIBXSQLDANAMES_R,nil,'NAMES'); + RegisterPropertyHelper(@TIBXSQLDARECORDSIZE_R,nil,'RECORDSIZE'); + RegisterPropertyHelper(@TIBXSQLDAVARS_R,nil,'VARS'); + RegisterPropertyHelper(@TIBXSQLDAUNIQUERELATIONNAME_R,nil,'UNIQUERELATIONNAME'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TIBXSQLVAR(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TIBXSQLVAR) do + begin + RegisterConstructor(@TIBXSQLVAR.CREATE, 'CREATE'); + RegisterMethod(@TIBXSQLVAR.ASSIGN, 'ASSIGN'); + RegisterMethod(@TIBXSQLVAR.LOADFROMFILE, 'LOADFROMFILE'); + RegisterMethod(@TIBXSQLVAR.LOADFROMSTREAM, 'LOADFROMSTREAM'); + RegisterMethod(@TIBXSQLVAR.SAVETOFILE, 'SAVETOFILE'); + RegisterMethod(@TIBXSQLVAR.SAVETOSTREAM, 'SAVETOSTREAM'); + RegisterMethod(@TIBXSQLVAR.CLEAR, 'CLEAR'); + RegisterPropertyHelper(@TIBXSQLVARASDATE_R,@TIBXSQLVARASDATE_W,'ASDATE'); + RegisterPropertyHelper(@TIBXSQLVARASTIME_R,@TIBXSQLVARASTIME_W,'ASTIME'); + RegisterPropertyHelper(@TIBXSQLVARASDATETIME_R,@TIBXSQLVARASDATETIME_W,'ASDATETIME'); + RegisterPropertyHelper(@TIBXSQLVARASDOUBLE_R,@TIBXSQLVARASDOUBLE_W,'ASDOUBLE'); + RegisterPropertyHelper(@TIBXSQLVARASFLOAT_R,@TIBXSQLVARASFLOAT_W,'ASFLOAT'); + RegisterPropertyHelper(@TIBXSQLVARASCURRENCY_R,@TIBXSQLVARASCURRENCY_W,'ASCURRENCY'); + RegisterPropertyHelper(@TIBXSQLVARASINT64_R,@TIBXSQLVARASINT64_W,'ASINT64'); + RegisterPropertyHelper(@TIBXSQLVARASINTEGER_R,@TIBXSQLVARASINTEGER_W,'ASINTEGER'); + RegisterPropertyHelper(@TIBXSQLVARASLONG_R,@TIBXSQLVARASLONG_W,'ASLONG'); + RegisterPropertyHelper(@TIBXSQLVARASPOINTER_R,@TIBXSQLVARASPOINTER_W,'ASPOINTER'); + RegisterPropertyHelper(@TIBXSQLVARASQUAD_R,@TIBXSQLVARASQUAD_W,'ASQUAD'); + RegisterPropertyHelper(@TIBXSQLVARASSHORT_R,@TIBXSQLVARASSHORT_W,'ASSHORT'); + RegisterPropertyHelper(@TIBXSQLVARASSTRING_R,@TIBXSQLVARASSTRING_W,'ASSTRING'); + RegisterPropertyHelper(@TIBXSQLVARASTRIMSTRING_R,@TIBXSQLVARASTRIMSTRING_W,'ASTRIMSTRING'); + RegisterPropertyHelper(@TIBXSQLVARASVARIANT_R,@TIBXSQLVARASVARIANT_W,'ASVARIANT'); + RegisterPropertyHelper(@TIBXSQLVARASXSQLVAR_R,@TIBXSQLVARASXSQLVAR_W,'ASXSQLVAR'); + RegisterPropertyHelper(@TIBXSQLVARDATA_R,@TIBXSQLVARDATA_W,'DATA'); + RegisterPropertyHelper(@TIBXSQLVARISNULL_R,@TIBXSQLVARISNULL_W,'ISNULL'); + RegisterPropertyHelper(@TIBXSQLVARISNULLABLE_R,@TIBXSQLVARISNULLABLE_W,'ISNULLABLE'); + RegisterPropertyHelper(@TIBXSQLVARINDEX_R,nil,'INDEX'); + RegisterPropertyHelper(@TIBXSQLVARMODIFIED_R,@TIBXSQLVARMODIFIED_W,'MODIFIED'); + RegisterPropertyHelper(@TIBXSQLVARNAME_R,nil,'NAME'); + RegisterPropertyHelper(@TIBXSQLVARSIZE_R,nil,'SIZE'); + RegisterPropertyHelper(@TIBXSQLVARSQLTYPE_R,nil,'SQLTYPE'); + RegisterPropertyHelper(@TIBXSQLVARVALUE_R,@TIBXSQLVARVALUE_W,'VALUE'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_IBSQL(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TIBSQL) do + with CL.Add(TIBXSQLDA) do + RIRegister_TIBXSQLVAR(CL); + RIRegister_TIBXSQLDA(CL); + RIRegister_TIBOUTPUTDELIMITEDFILE(CL); + RIRegister_TIBINPUTDELIMITEDFILE(CL); + RIRegister_TIBOUTPUTRAWFILE(CL); + RIRegister_TIBINPUTRAWFILE(CL); + RIRegister_TIBOUTPUTXML(CL); + RIRegister_TIBSQL(CL); +end; + +(* === compile-time registration functions === *) +(*----------------------------------------------------------------------------*) +procedure SIRegister_TIBQuery(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TIBCustomDataSet', 'TIBQuery') do + with CL.AddClassN(CL.FindClass('TIBCustomDataSet'),'TIBQuery') do + begin + RegisterMethod('Procedure BatchInput( InputObject : TIBBatchInput)'); + RegisterMethod('Procedure BatchOutput( OutputObject : TIBBatchOutput)'); + RegisterMethod('Procedure ExecSQL'); + RegisterMethod('Function ParamByName( const Value : string) : TParam'); + RegisterMethod('Procedure Prepare'); + RegisterMethod('Procedure UnPrepare'); + RegisterProperty('Prepared', 'Boolean', iptrw); + RegisterProperty('ParamCount', 'Word', iptr); + RegisterProperty('StmtHandle', 'TISC_STMT_HANDLE', iptr); + RegisterProperty('Text', 'string', iptr); + RegisterProperty('RowsAffected', 'Integer', iptr); + RegisterProperty('GenerateParamNames', 'Boolean', iptrw); + RegisterProperty('DataSource', 'TDatasource', iptrw); + RegisterProperty('SQL', 'TStrings', iptrw); + RegisterProperty('Params', 'TParams', iptrw); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_IBQuery(CL: TPSPascalCompiler); +begin + SIRegister_TIBQuery(CL); +end; + +(* === run-time registration functions === *) +(*----------------------------------------------------------------------------*) +procedure TIBQueryParams_W(Self: TIBQuery; const T: TParams); +begin Self.Params := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBQueryParams_R(Self: TIBQuery; var T: TParams); +begin T := Self.Params; end; + +(*----------------------------------------------------------------------------*) +procedure TIBQuerySQL_W(Self: TIBQuery; const T: TStrings); +begin Self.SQL := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBQuerySQL_R(Self: TIBQuery; var T: TStrings); +begin T := Self.SQL; end; + +(*----------------------------------------------------------------------------*) +procedure TIBQueryDataSource_W(Self: TIBQuery; const T: TDatasource); +begin Self.DataSource := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBQueryDataSource_R(Self: TIBQuery; var T: TDatasource); +begin T := Self.DataSource; end; + +(*----------------------------------------------------------------------------*) +procedure TIBQueryGenerateParamNames_W(Self: TIBQuery; const T: Boolean); +begin Self.GenerateParamNames := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBQueryGenerateParamNames_R(Self: TIBQuery; var T: Boolean); +begin T := Self.GenerateParamNames; end; + +(*----------------------------------------------------------------------------*) +procedure TIBQueryRowsAffected_R(Self: TIBQuery; var T: Integer); +begin T := Self.RowsAffected; end; + +(*----------------------------------------------------------------------------*) +procedure TIBQueryText_R(Self: TIBQuery; var T: string); +begin T := Self.Text; end; + +(*----------------------------------------------------------------------------*) +procedure TIBQueryStmtHandle_R(Self: TIBQuery; var T: TISC_STMT_HANDLE); +begin T := Self.StmtHandle; end; + +(*----------------------------------------------------------------------------*) +procedure TIBQueryParamCount_R(Self: TIBQuery; var T: Word); +begin T := Self.ParamCount; end; + +(*----------------------------------------------------------------------------*) +procedure TIBQueryPrepared_W(Self: TIBQuery; const T: Boolean); +begin Self.Prepared := T; end; + +(*----------------------------------------------------------------------------*) +procedure TIBQueryPrepared_R(Self: TIBQuery; var T: Boolean); +begin T := Self.Prepared; end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TIBQuery(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TIBQuery) do + begin + RegisterMethod(@TIBQuery.BatchInput, 'BatchInput'); + RegisterMethod(@TIBQuery.BatchOutput, 'BatchOutput'); + RegisterMethod(@TIBQuery.ExecSQL, 'ExecSQL'); + RegisterMethod(@TIBQuery.ParamByName, 'ParamByName'); + RegisterMethod(@TIBQuery.Prepare, 'Prepare'); + RegisterMethod(@TIBQuery.UnPrepare, 'UnPrepare'); + RegisterPropertyHelper(@TIBQueryPrepared_R,@TIBQueryPrepared_W,'Prepared'); + RegisterPropertyHelper(@TIBQueryParamCount_R,nil,'ParamCount'); + RegisterPropertyHelper(@TIBQueryStmtHandle_R,nil,'StmtHandle'); + RegisterPropertyHelper(@TIBQueryText_R,nil,'Text'); + RegisterPropertyHelper(@TIBQueryRowsAffected_R,nil,'RowsAffected'); + RegisterPropertyHelper(@TIBQueryGenerateParamNames_R,@TIBQueryGenerateParamNames_W,'GenerateParamNames'); + RegisterPropertyHelper(@TIBQueryDataSource_R,@TIBQueryDataSource_W,'DataSource'); + RegisterPropertyHelper(@TIBQuerySQL_R,@TIBQuerySQL_W,'SQL'); + RegisterPropertyHelper(@TIBQueryParams_R,@TIBQueryParams_W,'Params'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_IBQuery(CL: TPSRuntimeClassImporter); +begin + RIRegister_TIBQuery(CL); +end; + + + +{ TIFPS3CE_IBCustomDataSet } +(*----------------------------------------------------------------------------*) +procedure TPSImport_IBX.CompOnUses(CompExec: TPSScript); +begin + { nothing } +end; +(*----------------------------------------------------------------------------*) +procedure TPSImport_IBX.ExecOnUses(CompExec: TPSScript); +begin + { nothing } +end; +(*----------------------------------------------------------------------------*) +procedure TPSImport_IBX.CompileImport1(CompExec: TPSScript); +begin + SIRegister_IBDatabase(CompExec.Comp); + SIRegister_IBSQL(CompExec.Comp); + SIRegister_IBCustomDataSet(CompExec.Comp); + SIRegister_IBTable(CompExec.Comp); + SIRegister_IBQuery(CompExec.Comp); +end; +(*----------------------------------------------------------------------------*) +procedure TPSImport_IBX.CompileImport2(CompExec: TPSScript); +begin + { nothing } +end; +(*----------------------------------------------------------------------------*) +procedure TPSImport_IBX.ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); +begin + RIRegister_IBDatabase(ri); + RIRegister_IBSQL(ri); + RIRegister_IBCustomDataSet(ri); + RIRegister_IBTable(ri); + RIRegister_IBQuery(ri); +end; +(*----------------------------------------------------------------------------*) +procedure TPSImport_IBX.ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); +begin + { nothing } +end; + +end. diff --git a/Units/PascalScript/uPSI_JvMail.pas b/Units/PascalScript/uPSI_JvMail.pas new file mode 100644 index 0000000..bb79bbd --- /dev/null +++ b/Units/PascalScript/uPSI_JvMail.pas @@ -0,0 +1,373 @@ +unit uPSI_JvMail; +{ +This file has been generated by UnitParser v0.4b, written by M. Knight +and updated by NP. v/d Spek. +Source Code from Carlo Kok has been used to implement various sections of +UnitParser. Components of ifps3 are used in the construction of UnitParser, +code implementing the class wrapper is taken from Carlo Kok''s conv unility +} +interface + +uses + SysUtils, Classes, uPSComponent, uPSCompiler, uPSRuntime; + +type +(*----------------------------------------------------------------------------*) + TPSImport_JvMail = class(TPSPlugin) + protected + procedure CompOnUses(CompExec: TPSScript); override; + procedure ExecOnUses(CompExec: TPSScript); override; + procedure CompileImport1(CompExec: TPSScript); override; + procedure CompileImport2(CompExec: TPSScript); override; + procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override; + procedure ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override; + end; + +implementation + + +uses + Windows + ,Controls + ,Forms + ,Mapi + ,JclBase + ,JclMapi + ,JvComponent + ,JvMail + ; + +(* === compile-time registration functions === *) +(*----------------------------------------------------------------------------*) +procedure SIRegister_TJvMail(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TJvComponent', 'TJvMail') do + with CL.AddClassN(CL.FindClass('TComponent'),'TJvMail') do + begin + RegisterMethod('Function Address( const Caption : string; EditFields : Integer) : Boolean'); + RegisterMethod('Procedure Clear'); + RegisterMethod('Function ErrorCheck( Res : DWORD) : DWORD'); + RegisterMethod('Function FindFirstMail : Boolean'); + RegisterMethod('Function FindNextMail : Boolean'); + RegisterMethod('Procedure FreeSimpleMapi'); + RegisterMethod('Procedure LogOff'); + RegisterMethod('Procedure LogOn'); + RegisterMethod('Procedure ReadMail'); + RegisterMethod('Function ResolveName( const Name : string) : string'); + RegisterMethod('Function SaveMail( const MessageID : string) : string'); + RegisterMethod('Procedure SendMail( ShowDialog : Boolean)'); + RegisterProperty('ReadedMail', 'TJvMailReadedData', iptr); + RegisterProperty('SeedMessageID', 'string', iptrw); + RegisterProperty('SessionHandle', 'THandle', iptr); + RegisterProperty('SimpleMAPI', 'TJclSimpleMapi', iptr); + RegisterProperty('UserLogged', 'Boolean', iptr); + RegisterProperty('Attachment', 'TStrings', iptrw); + RegisterProperty('BlindCopy', 'TJvMailRecipients', iptrw); + RegisterProperty('Body', 'TStrings', iptrw); + RegisterProperty('CarbonCopy', 'TJvMailRecipients', iptrw); + RegisterProperty('LogonOptions', 'TJvMailLogonOptions', iptrw); + RegisterProperty('LongMsgId', 'Boolean', iptrw); + RegisterProperty('Password', 'string', iptrw); + RegisterProperty('ProfileName', 'string', iptrw); + RegisterProperty('ReadOptions', 'TJvMailReadOptions', iptrw); + RegisterProperty('Recipient', 'TJvMailRecipients', iptrw); + RegisterProperty('Subject', 'string', iptrw); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TJvMailRecipients(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TCollection', 'TJvMailRecipients') do + with CL.AddClassN(CL.FindClass('TCollection'),'TJvMailRecipients') do + begin + RegisterMethod('Constructor Create( AOwner : TJvMail; ARecipientClass : DWORD)'); + RegisterMethod('Function Add : TJvMailRecipient'); + RegisterMethod('Function AddRecipient( const Address : string; const Name : string) : Integer'); + RegisterProperty('Items', 'TJvMailRecipient Integer', iptrw); + SetDefaultPropery('Items'); + RegisterProperty('RecipientClass', 'DWORD', iptr); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TJvMailRecipient(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TCollectionItem', 'TJvMailRecipient') do + with CL.AddClassN(CL.FindClass('TCollectionItem'),'TJvMailRecipient') do + begin + RegisterProperty('AddressAndName', 'string', iptr); + RegisterProperty('Address', 'string', iptrw); + RegisterProperty('Name', 'string', iptrw); + RegisterProperty('Valid', 'Boolean', iptr); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_JvMail(CL: TPSPascalCompiler); +begin + CL.AddClassN(CL.FindClass('TOBJECT'),'TJvMail'); + SIRegister_TJvMailRecipient(CL); + SIRegister_TJvMailRecipients(CL); + CL.AddTypeS('TJvMailLogonOption', '( loLogonUI, loNewSession )'); + CL.AddTypeS('TJvMailReadOption', '( roUnreadOnly, roFifo, roPeek, roHeaderOnl' + +'y, roAttachments )'); + CL.AddTypeS('TJvMailLogonOptions', 'set of TJvMailLogonOption'); + CL.AddTypeS('TJvMailReadOptions', 'set of TJvMailReadOption'); + CL.AddTypeS('TJvMailReadedData', 'record RecipientAddress : string; Recipient' + +'Name : string; ConversationID : string; DateReceived : TDateTime; end'); + SIRegister_TJvMail(CL); +end; + +(* === run-time registration functions === *) +(*----------------------------------------------------------------------------*) +procedure TJvMailSubject_W(Self: TJvMail; const T: string); +begin Self.Subject := T; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailSubject_R(Self: TJvMail; var T: string); +begin T := Self.Subject; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailRecipient_W(Self: TJvMail; const T: TJvMailRecipients); +begin Self.Recipient := T; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailRecipient_R(Self: TJvMail; var T: TJvMailRecipients); +begin T := Self.Recipient; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailReadOptions_W(Self: TJvMail; const T: TJvMailReadOptions); +begin Self.ReadOptions := T; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailReadOptions_R(Self: TJvMail; var T: TJvMailReadOptions); +begin T := Self.ReadOptions; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailProfileName_W(Self: TJvMail; const T: string); +begin Self.ProfileName := T; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailProfileName_R(Self: TJvMail; var T: string); +begin T := Self.ProfileName; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailPassword_W(Self: TJvMail; const T: string); +begin Self.Password := T; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailPassword_R(Self: TJvMail; var T: string); +begin T := Self.Password; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailLongMsgId_W(Self: TJvMail; const T: Boolean); +begin Self.LongMsgId := T; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailLongMsgId_R(Self: TJvMail; var T: Boolean); +begin T := Self.LongMsgId; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailLogonOptions_W(Self: TJvMail; const T: TJvMailLogonOptions); +begin Self.LogonOptions := T; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailLogonOptions_R(Self: TJvMail; var T: TJvMailLogonOptions); +begin T := Self.LogonOptions; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailCarbonCopy_W(Self: TJvMail; const T: TJvMailRecipients); +begin Self.CarbonCopy := T; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailCarbonCopy_R(Self: TJvMail; var T: TJvMailRecipients); +begin T := Self.CarbonCopy; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailBody_W(Self: TJvMail; const T: TStrings); +begin Self.Body := T; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailBody_R(Self: TJvMail; var T: TStrings); +begin T := Self.Body; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailBlindCopy_W(Self: TJvMail; const T: TJvMailRecipients); +begin Self.BlindCopy := T; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailBlindCopy_R(Self: TJvMail; var T: TJvMailRecipients); +begin T := Self.BlindCopy; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailAttachment_W(Self: TJvMail; const T: TStrings); +begin Self.Attachment := T; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailAttachment_R(Self: TJvMail; var T: TStrings); +begin T := Self.Attachment; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailUserLogged_R(Self: TJvMail; var T: Boolean); +begin T := Self.UserLogged; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailSimpleMAPI_R(Self: TJvMail; var T: TJclSimpleMapi); +begin T := Self.SimpleMAPI; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailSessionHandle_R(Self: TJvMail; var T: THandle); +begin T := Self.SessionHandle; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailSeedMessageID_W(Self: TJvMail; const T: string); +begin Self.SeedMessageID := T; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailSeedMessageID_R(Self: TJvMail; var T: string); +begin T := Self.SeedMessageID; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailReadedMail_R(Self: TJvMail; var T: TJvMailReadedData); +begin T := Self.ReadedMail; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailRecipientsRecipientClass_R(Self: TJvMailRecipients; var T: DWORD); +begin T := Self.RecipientClass; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailRecipientsItems_W(Self: TJvMailRecipients; const T: TJvMailRecipient; const t1: Integer); +begin Self.Items[t1] := T; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailRecipientsItems_R(Self: TJvMailRecipients; var T: TJvMailRecipient; const t1: Integer); +begin T := Self.Items[t1]; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailRecipientValid_R(Self: TJvMailRecipient; var T: Boolean); +begin T := Self.Valid; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailRecipientName_W(Self: TJvMailRecipient; const T: string); +begin Self.Name := T; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailRecipientName_R(Self: TJvMailRecipient; var T: string); +begin T := Self.Name; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailRecipientAddress_W(Self: TJvMailRecipient; const T: string); +begin Self.Address := T; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailRecipientAddress_R(Self: TJvMailRecipient; var T: string); +begin T := Self.Address; end; + +(*----------------------------------------------------------------------------*) +procedure TJvMailRecipientAddressAndName_R(Self: TJvMailRecipient; var T: string); +begin T := Self.AddressAndName; end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TJvMail(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TJvMail) do + begin + RegisterMethod(@TJvMail.Address, 'Address'); + RegisterMethod(@TJvMail.Clear, 'Clear'); + RegisterMethod(@TJvMail.ErrorCheck, 'ErrorCheck'); + RegisterMethod(@TJvMail.FindFirstMail, 'FindFirstMail'); + RegisterMethod(@TJvMail.FindNextMail, 'FindNextMail'); + RegisterMethod(@TJvMail.FreeSimpleMapi, 'FreeSimpleMapi'); + RegisterMethod(@TJvMail.LogOff, 'LogOff'); + RegisterMethod(@TJvMail.LogOn, 'LogOn'); + RegisterMethod(@TJvMail.ReadMail, 'ReadMail'); + RegisterMethod(@TJvMail.ResolveName, 'ResolveName'); + RegisterMethod(@TJvMail.SaveMail, 'SaveMail'); + RegisterMethod(@TJvMail.SendMail, 'SendMail'); + RegisterPropertyHelper(@TJvMailReadedMail_R,nil,'ReadedMail'); + RegisterPropertyHelper(@TJvMailSeedMessageID_R,@TJvMailSeedMessageID_W,'SeedMessageID'); + RegisterPropertyHelper(@TJvMailSessionHandle_R,nil,'SessionHandle'); + RegisterPropertyHelper(@TJvMailSimpleMAPI_R,nil,'SimpleMAPI'); + RegisterPropertyHelper(@TJvMailUserLogged_R,nil,'UserLogged'); + RegisterPropertyHelper(@TJvMailAttachment_R,@TJvMailAttachment_W,'Attachment'); + RegisterPropertyHelper(@TJvMailBlindCopy_R,@TJvMailBlindCopy_W,'BlindCopy'); + RegisterPropertyHelper(@TJvMailBody_R,@TJvMailBody_W,'Body'); + RegisterPropertyHelper(@TJvMailCarbonCopy_R,@TJvMailCarbonCopy_W,'CarbonCopy'); + RegisterPropertyHelper(@TJvMailLogonOptions_R,@TJvMailLogonOptions_W,'LogonOptions'); + RegisterPropertyHelper(@TJvMailLongMsgId_R,@TJvMailLongMsgId_W,'LongMsgId'); + RegisterPropertyHelper(@TJvMailPassword_R,@TJvMailPassword_W,'Password'); + RegisterPropertyHelper(@TJvMailProfileName_R,@TJvMailProfileName_W,'ProfileName'); + RegisterPropertyHelper(@TJvMailReadOptions_R,@TJvMailReadOptions_W,'ReadOptions'); + RegisterPropertyHelper(@TJvMailRecipient_R,@TJvMailRecipient_W,'Recipient'); + RegisterPropertyHelper(@TJvMailSubject_R,@TJvMailSubject_W,'Subject'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TJvMailRecipients(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TJvMailRecipients) do + begin + RegisterConstructor(@TJvMailRecipients.Create, 'Create'); + RegisterMethod(@TJvMailRecipients.Add, 'Add'); + RegisterMethod(@TJvMailRecipients.AddRecipient, 'AddRecipient'); + RegisterPropertyHelper(@TJvMailRecipientsItems_R,@TJvMailRecipientsItems_W,'Items'); + RegisterPropertyHelper(@TJvMailRecipientsRecipientClass_R,nil,'RecipientClass'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TJvMailRecipient(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TJvMailRecipient) do + begin + RegisterPropertyHelper(@TJvMailRecipientAddressAndName_R,nil,'AddressAndName'); + RegisterPropertyHelper(@TJvMailRecipientAddress_R,@TJvMailRecipientAddress_W,'Address'); + RegisterPropertyHelper(@TJvMailRecipientName_R,@TJvMailRecipientName_W,'Name'); + RegisterPropertyHelper(@TJvMailRecipientValid_R,nil,'Valid'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_JvMail(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TJvMail) do + RIRegister_TJvMailRecipient(CL); + RIRegister_TJvMailRecipients(CL); + RIRegister_TJvMail(CL); +end; + +{ TPSImport_JvMail } +(*----------------------------------------------------------------------------*) +procedure TPSImport_JvMail.CompOnUses(CompExec: TPSScript); +begin + { nothing } +end; +(*----------------------------------------------------------------------------*) +procedure TPSImport_JvMail.ExecOnUses(CompExec: TPSScript); +begin + { nothing } +end; +(*----------------------------------------------------------------------------*) +procedure TPSImport_JvMail.CompileImport1(CompExec: TPSScript); +begin + SIRegister_JvMail(CompExec.Comp); +end; +(*----------------------------------------------------------------------------*) +procedure TPSImport_JvMail.CompileImport2(CompExec: TPSScript); +begin + { nothing } +end; +(*----------------------------------------------------------------------------*) +procedure TPSImport_JvMail.ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); +begin + RIRegister_JvMail(ri); +end; +(*----------------------------------------------------------------------------*) +procedure TPSImport_JvMail.ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); +begin + { nothing } +end; + +end. diff --git a/Units/PascalScript/uPSI_Mask.pas b/Units/PascalScript/uPSI_Mask.pas new file mode 100644 index 0000000..b2bc080 --- /dev/null +++ b/Units/PascalScript/uPSI_Mask.pas @@ -0,0 +1,187 @@ +unit uPSI_Mask; +{ +This file has been generated by UnitParser v0.5, written by M. Knight +and updated by NP. v/d Spek. +Source Code from Carlo Kok has been used to implement various sections of +UnitParser. Components of ifps3 are used in the construction of UnitParser, +code implementing the class wrapper is taken from Carlo Kok''s conv unility +} +interface + +uses + SysUtils, Classes, uPSComponent, uPSCompiler, uPSRuntime; + +type +(*----------------------------------------------------------------------------*) + TPSImport_Mask = class(TPSPlugin) + protected + procedure CompOnUses(CompExec: TPSScript); override; + procedure ExecOnUses(CompExec: TPSScript); override; + procedure CompileImport1(CompExec: TPSScript); override; + procedure CompileImport2(CompExec: TPSScript); override; + procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override; + procedure ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override; + end; + +implementation + + +uses + Windows ,StdCtrls ,Controls ,Messages ,Forms ,Graphics ,Menus ,Mask; + +(* === compile-time registration functions === *) +(*----------------------------------------------------------------------------*) +procedure SIRegister_TMaskEdit(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TCustomMaskEdit', 'TMaskEdit') do + with CL.AddClassN(CL.FindClass('TCustomMaskEdit'),'TMaskEdit') do + begin + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TCustomMaskEdit(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TCustomEdit', 'TCustomMaskEdit') do + with CL.AddClassN(CL.FindClass('TCustomEdit'),'TCustomMaskEdit') do + begin + RegisterMethod('Procedure ValidateEdit'); + RegisterMethod('Function GetTextLen : Integer'); + RegisterProperty('IsMasked', 'Boolean', iptr); + RegisterProperty('EditText', 'string', iptrw); + RegisterProperty('Text', 'string', iptrw); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_Mask(CL: TPSPascalCompiler); +begin + CL.AddConstantN('DefaultBlank','Char').SetString( '_'); + CL.AddConstantN('MaskFieldSeparator','Char').SetString( ';'); + CL.AddConstantN('MaskNoSave','Char').SetString( '0'); + CL.AddConstantN('mDirReverse','String').SetString( '!'); + CL.AddConstantN('mDirUpperCase','String').SetString( '>'); + CL.AddConstantN('mDirLowerCase','String').SetString( '<'); + CL.AddConstantN('mDirLiteral','String').SetString( '\'); + CL.AddConstantN('mMskAlpha','String').SetString( 'L'); + CL.AddConstantN('mMskAlphaOpt','String').SetString( 'l'); + CL.AddConstantN('mMskAlphaNum','String').SetString( 'A'); + CL.AddConstantN('mMskAlphaNumOpt','String').SetString( 'a'); + CL.AddConstantN('mMskAscii','String').SetString( 'C'); + CL.AddConstantN('mMskAsciiOpt','String').SetString( 'c'); + CL.AddConstantN('mMskNumeric','String').SetString( '0'); + CL.AddConstantN('mMskNumericOpt','String').SetString( '9'); + CL.AddConstantN('mMskNumSymOpt','String').SetString( '#'); + CL.AddConstantN('mMskTimeSeparator','String').SetString( ':'); + CL.AddConstantN('mMskDateSeparator','String').SetString( '/'); + CL.AddTypeS('TMaskCharType', '( mcNone, mcLiteral, mcIntlLiteral, mcDirective' + +', mcMask, mcMaskOpt, mcFieldSeparator, mcField )'); + CL.AddTypeS('TMaskDirective', '( mdReverseDir, mdUpperCase, mdLowerCa' + +'se, mdLiteralChar )'); + CL.AddTypeS('TMaskDirectives', 'set of TMaskDirective'); + CL.AddClassN(CL.FindClass('TOBJECT'),'EDBEditError'); + CL.AddTypeS('TMaskedStatex', '( msMasked, msReEnter, msDBSetText )'); + CL.AddTypeS('TMaskedState', 'set of TMaskedStatex'); + SIRegister_TCustomMaskEdit(CL); + SIRegister_TMaskEdit(CL); + CL.AddDelphiFunction('Function FormatMaskText( const EditMask : string; const Value : string) : string'); + CL.AddDelphiFunction('Function MaskGetMaskSave( const EditMask : string) : Boolean'); + CL.AddDelphiFunction('Function MaskGetMaskBlank( const EditMask : string) : Char'); + CL.AddDelphiFunction('Function MaskGetFldSeparator( const EditMask : string) : Integer'); +end; + +(* === run-time registration functions === *) +(*----------------------------------------------------------------------------*) +procedure TCustomMaskEditText_W(Self: TCustomMaskEdit; const T: string); +begin Self.Text := T; end; + +(*----------------------------------------------------------------------------*) +procedure TCustomMaskEditText_R(Self: TCustomMaskEdit; var T: string); +begin T := Self.Text; end; + +(*----------------------------------------------------------------------------*) +procedure TCustomMaskEditEditText_W(Self: TCustomMaskEdit; const T: string); +begin Self.EditText := T; end; + +(*----------------------------------------------------------------------------*) +procedure TCustomMaskEditEditText_R(Self: TCustomMaskEdit; var T: string); +begin T := Self.EditText; end; + +(*----------------------------------------------------------------------------*) +procedure TCustomMaskEditIsMasked_R(Self: TCustomMaskEdit; var T: Boolean); +begin T := Self.IsMasked; end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_Mask_Routines(S: TPSExec); +begin + S.RegisterDelphiFunction(@FormatMaskText, 'FormatMaskText', cdRegister); + S.RegisterDelphiFunction(@MaskGetMaskSave, 'MaskGetMaskSave', cdRegister); + S.RegisterDelphiFunction(@MaskGetMaskBlank, 'MaskGetMaskBlank', cdRegister); + S.RegisterDelphiFunction(@MaskGetFldSeparator, 'MaskGetFldSeparator', cdRegister); +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TMaskEdit(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TMaskEdit) do + begin + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TCustomMaskEdit(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TCustomMaskEdit) do + begin + RegisterVirtualMethod(@TCustomMaskEdit.ValidateEdit, 'ValidateEdit'); + RegisterMethod(@TCustomMaskEdit.GetTextLen, 'GetTextLen'); + RegisterPropertyHelper(@TCustomMaskEditIsMasked_R,nil,'IsMasked'); + RegisterPropertyHelper(@TCustomMaskEditEditText_R,@TCustomMaskEditEditText_W,'EditText'); + RegisterPropertyHelper(@TCustomMaskEditText_R,@TCustomMaskEditText_W,'Text'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_Mask(CL: TPSRuntimeClassImporter); +begin + with CL.Add(EDBEditError) do + RIRegister_TCustomMaskEdit(CL); + RIRegister_TMaskEdit(CL); +end; + + + +{ TPSImport_Mask } +(*----------------------------------------------------------------------------*) +procedure TPSImport_Mask.CompOnUses(CompExec: TPSScript); +begin + { nothing } +end; +(*----------------------------------------------------------------------------*) +procedure TPSImport_Mask.ExecOnUses(CompExec: TPSScript); +begin + { nothing } +end; +(*----------------------------------------------------------------------------*) +procedure TPSImport_Mask.CompileImport1(CompExec: TPSScript); +begin + SIRegister_Mask(CompExec.Comp); +end; +(*----------------------------------------------------------------------------*) +procedure TPSImport_Mask.CompileImport2(CompExec: TPSScript); +begin + { nothing } +end; +(*----------------------------------------------------------------------------*) +procedure TPSImport_Mask.ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); +begin + RIRegister_Mask(ri); + RIRegister_Mask_Routines(CompExec.Exec); // comment it if no routines +end; +(*----------------------------------------------------------------------------*) +procedure TPSImport_Mask.ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); +begin + { nothing } +end; + +end. diff --git a/Units/PascalScript/uPSI_Registry.pas b/Units/PascalScript/uPSI_Registry.pas new file mode 100644 index 0000000..538d44d --- /dev/null +++ b/Units/PascalScript/uPSI_Registry.pas @@ -0,0 +1,478 @@ +unit uPSI_Registry; +{ +This file has been generated by UnitParser v0.4b, written by M. Knight +and updated by NP. v/d Spek. +Source Code from Carlo Kok has been used to implement various sections of +UnitParser. Components of ifps3 are used in the construction of UnitParser, +code implementing the class wrapper is taken from Carlo Kok''s conv unility +} + +interface + +uses + SysUtils, Classes, uPSComponent, uPSCompiler, uPSRuntime; + +type +(*----------------------------------------------------------------------------*) + TPSImport_Registry = class(TPSPlugin) + protected + procedure CompOnUses(CompExec: TPSScript); override; + procedure ExecOnUses(CompExec: TPSScript); override; + procedure CompileImport1(CompExec: TPSScript); override; + procedure CompileImport2(CompExec: TPSScript); override; + procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override; + procedure ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override; + end; + +implementation + + +uses + Windows ,IniFiles ,Registry ; + +(* === compile-time registration functions === *) +(*----------------------------------------------------------------------------*) +procedure SIRegister_TRegistryIniFile(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TCustomIniFile', 'TRegistryIniFile') do + with CL.AddClassN(CL.FindClass('TCustomIniFile'),'TRegistryIniFile') do + begin + RegisterMethod('Constructor Create( const FileName : string);'); + RegisterMethod('Constructor CreateA( const FileName : string; AAccess : LongWord);'); + RegisterProperty('RegIniFile', 'TRegIniFile', iptr); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TRegIniFile(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TRegistry', 'TRegIniFile') do + with CL.AddClassN(CL.FindClass('TRegistry'),'TRegIniFile') do + begin + RegisterMethod('Constructor Create( const FileName : string);'); + RegisterMethod('Constructor CreateA( const FileName : string; AAccess : LongWord);'); + RegisterMethod('Function ReadString( const Section, Ident, Default : string) : string'); + RegisterMethod('Function ReadInteger( const Section, Ident : string; Default : Longint) : Longint'); + RegisterMethod('Procedure WriteInteger( const Section, Ident : string; Value : Longint)'); + RegisterMethod('Procedure WriteString( const Section, Ident, Value : String)'); + RegisterMethod('Function ReadBool( const Section, Ident : string; Default : Boolean) : Boolean'); + RegisterMethod('Procedure WriteBool( const Section, Ident : string; Value : Boolean)'); + RegisterMethod('Procedure ReadSection( const Section : string; Strings : TStrings)'); + RegisterMethod('Procedure ReadSections( Strings : TStrings)'); + RegisterMethod('Procedure ReadSectionValues( const Section : string; Strings : TStrings)'); + RegisterMethod('Procedure EraseSection( const Section : string)'); + RegisterMethod('Procedure DeleteKey( const Section, Ident : String)'); + RegisterProperty('FileName', 'string', iptr); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TRegistry(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TObject', 'TRegistry') do + with CL.AddClassN(CL.FindClass('TObject'),'TRegistry') do + begin + RegisterMethod('Constructor Create;'); + RegisterMethod('Constructor CreateA( AAccess : LongWord);'); + RegisterMethod('Procedure CloseKey'); + RegisterMethod('Function CreateKey( const Key : string) : Boolean'); + RegisterMethod('Function DeleteKey( const Key : string) : Boolean'); + RegisterMethod('Function DeleteValue( const Name : string) : Boolean'); + RegisterMethod('Function GetDataInfo( const ValueName : string; var Value : TRegDataInfo) : Boolean'); + RegisterMethod('Function GetDataSize( const ValueName : string) : Integer'); + RegisterMethod('Function GetDataType( const ValueName : string) : TRegDataType'); + RegisterMethod('Function GetKeyInfo( var Value : TRegKeyInfo) : Boolean'); + RegisterMethod('Procedure GetKeyNames( Strings : TStrings)'); + RegisterMethod('Procedure GetValueNames( Strings : TStrings)'); + RegisterMethod('Function HasSubKeys : Boolean'); + RegisterMethod('Function KeyExists( const Key : string) : Boolean'); + RegisterMethod('Function LoadKey( const Key, FileName : string) : Boolean'); + RegisterMethod('Procedure MoveKey( const OldName, NewName : string; Delete : Boolean)'); + RegisterMethod('Function OpenKey( const Key : string; CanCreate : Boolean) : Boolean'); + RegisterMethod('Function OpenKeyReadOnly( const Key : String) : Boolean'); + RegisterMethod('Function ReadCurrency( const Name : string) : Currency'); + RegisterMethod('Function ReadBool( const Name : string) : Boolean'); + RegisterMethod('Function ReadDate( const Name : string) : TDateTime'); + RegisterMethod('Function ReadDateTime( const Name : string) : TDateTime'); + RegisterMethod('Function ReadFloat( const Name : string) : Double'); + RegisterMethod('Function ReadInteger( const Name : string) : Integer'); + RegisterMethod('Function ReadString( const Name : string) : string'); + RegisterMethod('Function ReadTime( const Name : string) : TDateTime'); + RegisterMethod('Function RegistryConnect( const UNCName : string) : Boolean'); + RegisterMethod('Procedure RenameValue( const OldName, NewName : string)'); + RegisterMethod('Function ReplaceKey( const Key, FileName, BackUpFileName : string) : Boolean'); + RegisterMethod('Function RestoreKey( const Key, FileName : string) : Boolean'); + RegisterMethod('Function SaveKey( const Key, FileName : string) : Boolean'); + RegisterMethod('Function UnLoadKey( const Key : string) : Boolean'); + RegisterMethod('Function ValueExists( const Name : string) : Boolean'); + RegisterMethod('Procedure WriteCurrency( const Name : string; Value : Currency)'); + RegisterMethod('Procedure WriteBool( const Name : string; Value : Boolean)'); + RegisterMethod('Procedure WriteDate( const Name : string; Value : TDateTime)'); + RegisterMethod('Procedure WriteDateTime( const Name : string; Value : TDateTime)'); + RegisterMethod('Procedure WriteFloat( const Name : string; Value : Double)'); + RegisterMethod('Procedure WriteInteger( const Name : string; Value : Integer)'); + RegisterMethod('Procedure WriteString( const Name, Value : string)'); + RegisterMethod('Procedure WriteExpandString( const Name, Value : string)'); + RegisterMethod('Procedure WriteTime( const Name : string; Value : TDateTime)'); + RegisterProperty('CurrentKey', 'HKEY', iptr); + RegisterProperty('CurrentPath', 'string', iptr); + RegisterProperty('LazyWrite', 'Boolean', iptrw); + RegisterProperty('RootKey', 'HKEY', iptrw); + RegisterProperty('Access', 'LongWord', iptrw); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_Registry(CL: TPSPascalCompiler); +begin + CL.AddClassN(CL.FindClass('TOBJECT'),'ERegistryException'); + SIRegister_TRegistry(CL); + SIRegister_TRegIniFile(CL); + SIRegister_TRegistryIniFile(CL); +end; + +(* === run-time registration functions === *) +(*----------------------------------------------------------------------------*) +procedure TRegistryIniFileRegIniFile_R(Self: TRegistryIniFile; var T: TRegIniFile); +begin T := Self.RegIniFile; end; + +(*----------------------------------------------------------------------------*) +Function TRegistryIniFileCreateA_P(Self: TClass; CreateNewInstance: Boolean; const FileName : string; AAccess : LongWord):TObject; +Begin Result := TRegistryIniFile.Create(FileName, AAccess); END; + +(*----------------------------------------------------------------------------*) +Function TRegistryIniFileCreate_P(Self: TClass; CreateNewInstance: Boolean; const FileName : string):TObject; +Begin Result := TRegistryIniFile.Create(FileName); END; + +(*----------------------------------------------------------------------------*) +procedure TRegIniFileFileName_R(Self: TRegIniFile; var T: string); +begin T := Self.FileName; end; + +(*----------------------------------------------------------------------------*) +Function TRegIniFileCreateA_P(Self: TClass; CreateNewInstance: Boolean; const FileName : string; AAccess : LongWord):TObject; +Begin Result := TRegIniFile.Create(FileName, AAccess); END; + +(*----------------------------------------------------------------------------*) +Function TRegIniFileCreate_P(Self: TClass; CreateNewInstance: Boolean; const FileName : string):TObject; +Begin Result := TRegIniFile.Create(FileName); END; + +(*----------------------------------------------------------------------------*) +procedure TRegistryAccess_W(Self: TRegistry; const T: LongWord); +begin Self.Access := T; end; + +(*----------------------------------------------------------------------------*) +procedure TRegistryAccess_R(Self: TRegistry; var T: LongWord); +begin T := Self.Access; end; + +(*----------------------------------------------------------------------------*) +procedure TRegistryRootKey_W(Self: TRegistry; const T: HKEY); +begin Self.RootKey := T; end; + +(*----------------------------------------------------------------------------*) +procedure TRegistryRootKey_R(Self: TRegistry; var T: HKEY); +begin T := Self.RootKey; end; + +(*----------------------------------------------------------------------------*) +procedure TRegistryLazyWrite_W(Self: TRegistry; const T: Boolean); +begin Self.LazyWrite := T; end; + +(*----------------------------------------------------------------------------*) +procedure TRegistryLazyWrite_R(Self: TRegistry; var T: Boolean); +begin T := Self.LazyWrite; end; + +(*----------------------------------------------------------------------------*) +procedure TRegistryCurrentPath_R(Self: TRegistry; var T: string); +begin T := Self.CurrentPath; end; + +(*----------------------------------------------------------------------------*) +procedure TRegistryCurrentKey_R(Self: TRegistry; var T: HKEY); +begin T := Self.CurrentKey; end; + +(*----------------------------------------------------------------------------*) +Function TRegistryCreateA_P(Self: TClass; CreateNewInstance: Boolean; AAccess : LongWord):TObject; +Begin Result := TRegistry.Create(AAccess); END; + +(*----------------------------------------------------------------------------*) +Function TRegistryCreate_P(Self: TClass; CreateNewInstance: Boolean):TObject; +Begin Result := TRegistry.Create; END; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TRegistryIniFile(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TRegistryIniFile) do + begin + RegisterConstructor(@TRegistryIniFileCreate_P, 'Create'); + RegisterConstructor(@TRegistryIniFileCreateA_P, 'CreateA'); + RegisterPropertyHelper(@TRegistryIniFileRegIniFile_R,nil,'RegIniFile'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TRegIniFile(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TRegIniFile) do + begin + RegisterConstructor(@TRegIniFileCreate_P, 'Create'); + RegisterConstructor(@TRegIniFileCreateA_P, 'CreateA'); + RegisterMethod(@TRegIniFile.ReadString, 'ReadString'); + RegisterMethod(@TRegIniFile.ReadInteger, 'ReadInteger'); + RegisterMethod(@TRegIniFile.WriteInteger, 'WriteInteger'); + RegisterMethod(@TRegIniFile.WriteString, 'WriteString'); + RegisterMethod(@TRegIniFile.ReadBool, 'ReadBool'); + RegisterMethod(@TRegIniFile.WriteBool, 'WriteBool'); + RegisterMethod(@TRegIniFile.ReadSection, 'ReadSection'); + RegisterMethod(@TRegIniFile.ReadSections, 'ReadSections'); + RegisterMethod(@TRegIniFile.ReadSectionValues, 'ReadSectionValues'); + RegisterMethod(@TRegIniFile.EraseSection, 'EraseSection'); + RegisterMethod(@TRegIniFile.DeleteKey, 'DeleteKey'); + RegisterPropertyHelper(@TRegIniFileFileName_R,nil,'FileName'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TRegistry(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TRegistry) do + begin + RegisterConstructor(@TRegistryCreateA_P, 'CreateA'); + RegisterConstructor(@TRegistryCreate_P, 'Create'); + RegisterMethod(@TRegistry.CloseKey, 'CloseKey'); + RegisterMethod(@TRegistry.CreateKey, 'CreateKey'); + RegisterMethod(@TRegistry.DeleteKey, 'DeleteKey'); + RegisterMethod(@TRegistry.DeleteValue, 'DeleteValue'); + RegisterMethod(@TRegistry.GetDataInfo, 'GetDataInfo'); + RegisterMethod(@TRegistry.GetDataSize, 'GetDataSize'); + RegisterMethod(@TRegistry.GetDataType, 'GetDataType'); + RegisterMethod(@TRegistry.GetKeyInfo, 'GetKeyInfo'); + RegisterMethod(@TRegistry.GetKeyNames, 'GetKeyNames'); + RegisterMethod(@TRegistry.GetValueNames, 'GetValueNames'); + RegisterMethod(@TRegistry.HasSubKeys, 'HasSubKeys'); + RegisterMethod(@TRegistry.KeyExists, 'KeyExists'); + RegisterMethod(@TRegistry.LoadKey, 'LoadKey'); + RegisterMethod(@TRegistry.MoveKey, 'MoveKey'); + RegisterMethod(@TRegistry.OpenKey, 'OpenKey'); + RegisterMethod(@TRegistry.OpenKeyReadOnly, 'OpenKeyReadOnly'); + RegisterMethod(@TRegistry.ReadCurrency, 'ReadCurrency'); + RegisterMethod(@TRegistry.ReadBool, 'ReadBool'); + RegisterMethod(@TRegistry.ReadDate, 'ReadDate'); + RegisterMethod(@TRegistry.ReadDateTime, 'ReadDateTime'); + RegisterMethod(@TRegistry.ReadFloat, 'ReadFloat'); + RegisterMethod(@TRegistry.ReadInteger, 'ReadInteger'); + RegisterMethod(@TRegistry.ReadString, 'ReadString'); + RegisterMethod(@TRegistry.ReadTime, 'ReadTime'); + RegisterMethod(@TRegistry.RegistryConnect, 'RegistryConnect'); + RegisterMethod(@TRegistry.RenameValue, 'RenameValue'); + RegisterMethod(@TRegistry.ReplaceKey, 'ReplaceKey'); + RegisterMethod(@TRegistry.RestoreKey, 'RestoreKey'); + RegisterMethod(@TRegistry.SaveKey, 'SaveKey'); + RegisterMethod(@TRegistry.UnLoadKey, 'UnLoadKey'); + RegisterMethod(@TRegistry.ValueExists, 'ValueExists'); + RegisterMethod(@TRegistry.WriteCurrency, 'WriteCurrency'); + RegisterMethod(@TRegistry.WriteBool, 'WriteBool'); + RegisterMethod(@TRegistry.WriteDate, 'WriteDate'); + RegisterMethod(@TRegistry.WriteDateTime, 'WriteDateTime'); + RegisterMethod(@TRegistry.WriteFloat, 'WriteFloat'); + RegisterMethod(@TRegistry.WriteInteger, 'WriteInteger'); + RegisterMethod(@TRegistry.WriteString, 'WriteString'); + RegisterMethod(@TRegistry.WriteExpandString, 'WriteExpandString'); + RegisterMethod(@TRegistry.WriteTime, 'WriteTime'); + RegisterPropertyHelper(@TRegistryCurrentKey_R,nil,'CurrentKey'); + RegisterPropertyHelper(@TRegistryCurrentPath_R,nil,'CurrentPath'); + RegisterPropertyHelper(@TRegistryLazyWrite_R,@TRegistryLazyWrite_W,'LazyWrite'); + RegisterPropertyHelper(@TRegistryRootKey_R,@TRegistryRootKey_W,'RootKey'); + RegisterPropertyHelper(@TRegistryAccess_R,@TRegistryAccess_W,'Access'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_Registry(CL: TPSRuntimeClassImporter); +begin + with CL.Add(ERegistryException) do + RIRegister_TRegistry(CL); + RIRegister_TRegIniFile(CL); + RIRegister_TRegistryIniFile(CL); +end; + +(* === compile-time registration functions === *) +(*----------------------------------------------------------------------------*) +procedure SIRegister_TMemIniFile(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TCustomIniFile', 'TMemIniFile') do + with CL.AddClassN(CL.FindClass('TCustomIniFile'),'TMemIniFile') do + begin + RegisterMethod('Constructor Create( const FileName : string)'); + RegisterMethod('Procedure Clear'); + RegisterMethod('Procedure GetStrings( List : TStrings)'); + RegisterMethod('Procedure Rename( const FileName : string; Reload : Boolean)'); + RegisterMethod('Procedure SetStrings( List : TStrings)'); + end; +end; + + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TIniFile(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TCustomIniFile', 'TIniFile') do + with CL.AddClassN(CL.FindClass('TCustomIniFile'),'TIniFile') do + begin + RegisterMethod('Function ReadString( const Section, Ident, Default : string) : string'); + RegisterMethod('Procedure WriteString( const Section, Ident, Value : String)'); + RegisterMethod('Procedure ReadSection( const Section : string; Strings : TStrings)'); + RegisterMethod('Procedure ReadSections( Strings : TStrings)'); + RegisterMethod('Procedure ReadSectionValues( const Section : string; Strings : TStrings)'); + RegisterMethod('Procedure EraseSection( const Section : string)'); + RegisterMethod('Procedure DeleteKey( const Section, Ident : String)'); + RegisterMethod('Procedure UpdateFile'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TCustomIniFile(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TObject', 'TCustomIniFile') do + with CL.AddClassN(CL.FindClass('TObject'),'TCustomIniFile') do + begin + RegisterMethod('Constructor Create( const FileName : string)'); + RegisterMethod('Function SectionExists( const Section : string) : Boolean'); +// RegisterMethod('Function ReadString( const Section, Ident, Default : string) : string'); +// RegisterMethod('Procedure WriteString( const Section, Ident, Value : String)'); + RegisterMethod('Function ReadInteger( const Section, Ident : string; Default : Longint) : Longint'); + RegisterMethod('Procedure WriteInteger( const Section, Ident : string; Value : Longint)'); + RegisterMethod('Function ReadBool( const Section, Ident : string; Default : Boolean) : Boolean'); + RegisterMethod('Procedure WriteBool( const Section, Ident : string; Value : Boolean)'); + RegisterMethod('Function ReadDate( const Section, Name : string; Default : TDateTime) : TDateTime'); + RegisterMethod('Function ReadDateTime( const Section, Name : string; Default : TDateTime) : TDateTime'); + RegisterMethod('Function ReadFloat( const Section, Name : string; Default : Double) : Double'); + RegisterMethod('Function ReadTime( const Section, Name : string; Default : TDateTime) : TDateTime'); + RegisterMethod('Procedure WriteDate( const Section, Name : string; Value : TDateTime)'); + RegisterMethod('Procedure WriteDateTime( const Section, Name : string; Value : TDateTime)'); + RegisterMethod('Procedure WriteFloat( const Section, Name : string; Value : Double)'); + RegisterMethod('Procedure WriteTime( const Section, Name : string; Value : TDateTime)'); +// RegisterMethod('Procedure ReadSection( const Section : string; Strings : TStrings)'); +// RegisterMethod('Procedure ReadSections( Strings : TStrings)'); +// RegisterMethod('Procedure ReadSectionValues( const Section : string; Strings : TStrings)'); +// RegisterMethod('Procedure EraseSection( const Section : string)'); +// RegisterMethod('Procedure DeleteKey( const Section, Ident : String)'); +// RegisterMethod('Procedure UpdateFile'); + RegisterMethod('Function ValueExists( const Section, Ident : string) : Boolean'); + RegisterProperty('FileName', 'string', iptr); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_IniFiles(CL: TPSPascalCompiler); +begin + SIRegister_TCustomIniFile(CL); + SIRegister_TIniFile(CL); + SIRegister_TMemIniFile(CL); +end; + +(* === run-time registration functions === *) +(*----------------------------------------------------------------------------*) +procedure TCustomIniFileFileName_R(Self: TCustomIniFile; var T: string); +begin T := Self.FileName; end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TMemIniFile(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TMemIniFile) do + begin + RegisterConstructor(@TMemIniFile.Create, 'Create'); + RegisterMethod(@TMemIniFile.Clear, 'Clear'); + RegisterMethod(@TMemIniFile.GetStrings, 'GetStrings'); + RegisterMethod(@TMemIniFile.Rename, 'Rename'); + RegisterMethod(@TMemIniFile.SetStrings, 'SetStrings'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TIniFile(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TIniFile) do + begin + RegisterMethod(@TIniFile.ReadString, 'ReadString'); + RegisterMethod(@TIniFile.WriteString, 'WriteString'); + RegisterMethod(@TIniFile.ReadSection, 'ReadSection'); + RegisterMethod(@TIniFile.ReadSections, 'ReadSections'); + RegisterMethod(@TIniFile.ReadSectionValues, 'ReadSectionValues'); + RegisterMethod(@TIniFile.EraseSection, 'EraseSection'); + RegisterMethod(@TIniFile.DeleteKey, 'DeleteKey'); + RegisterMethod(@TIniFile.UpdateFile, 'UpdateFile'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TCustomIniFile(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TCustomIniFile) do + begin + RegisterConstructor(@TCustomIniFile.Create, 'Create'); + RegisterMethod(@TCustomIniFile.SectionExists, 'SectionExists'); +// RegisterVirtualAbstractMethod(@TCustomIniFile, @!.ReadString, 'ReadString'); +// RegisterVirtualAbstractMethod(@TCustomIniFile, @!.WriteString, 'WriteString'); + RegisterVirtualMethod(@TCustomIniFile.ReadInteger, 'ReadInteger'); + RegisterVirtualMethod(@TCustomIniFile.WriteInteger, 'WriteInteger'); + RegisterVirtualMethod(@TCustomIniFile.ReadBool, 'ReadBool'); + RegisterVirtualMethod(@TCustomIniFile.WriteBool, 'WriteBool'); + RegisterVirtualMethod(@TCustomIniFile.ReadDate, 'ReadDate'); + RegisterVirtualMethod(@TCustomIniFile.ReadDateTime, 'ReadDateTime'); + RegisterVirtualMethod(@TCustomIniFile.ReadFloat, 'ReadFloat'); + RegisterVirtualMethod(@TCustomIniFile.ReadTime, 'ReadTime'); + RegisterVirtualMethod(@TCustomIniFile.WriteDate, 'WriteDate'); + RegisterVirtualMethod(@TCustomIniFile.WriteDateTime, 'WriteDateTime'); + RegisterVirtualMethod(@TCustomIniFile.WriteFloat, 'WriteFloat'); + RegisterVirtualMethod(@TCustomIniFile.WriteTime, 'WriteTime'); +// RegisterVirtualAbstractMethod(@TCustomIniFile, @!.ReadSection, 'ReadSection'); +// RegisterVirtualAbstractMethod(@TCustomIniFile, @!.ReadSections, 'ReadSections'); +// RegisterVirtualAbstractMethod(@TCustomIniFile, @!.ReadSectionValues, 'ReadSectionValues'); +// RegisterVirtualAbstractMethod(@TCustomIniFile, @!.EraseSection, 'EraseSection'); +// RegisterVirtualAbstractMethod(@TCustomIniFile, @!.DeleteKey, 'DeleteKey'); +// RegisterVirtualAbstractMethod(@TCustomIniFile, @!.UpdateFile, 'UpdateFile'); + RegisterMethod(@TCustomIniFile.ValueExists, 'ValueExists'); + RegisterPropertyHelper(@TCustomIniFileFileName_R,nil,'FileName'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_IniFiles(CL: TPSRuntimeClassImporter); +begin + RIRegister_TCustomIniFile(CL); + RIRegister_TIniFile(CL); + RIRegister_TMemIniFile(CL); +end; + +{ TPSImport_Registry } +(*----------------------------------------------------------------------------*) +procedure TPSImport_Registry.CompOnUses(CompExec: TPSScript); +begin + { nothing } +end; +(*----------------------------------------------------------------------------*) +procedure TPSImport_Registry.ExecOnUses(CompExec: TPSScript); +begin + { nothing } +end; +(*----------------------------------------------------------------------------*) +procedure TPSImport_Registry.CompileImport1(CompExec: TPSScript); +begin + SIRegister_Registry(CompExec.Comp); + SIRegister_IniFiles(CompExec.Comp); +end; +(*----------------------------------------------------------------------------*) +procedure TPSImport_Registry.CompileImport2(CompExec: TPSScript); +begin + { nothing } +end; +(*----------------------------------------------------------------------------*) +procedure TPSImport_Registry.ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); +begin + RIRegister_Registry(ri); + RIRegister_IniFiles(ri); +end; +(*----------------------------------------------------------------------------*) +procedure TPSImport_Registry.ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); +begin + { nothing } +end; + +end. diff --git a/Units/PascalScript/uPSPreProcessor.pas b/Units/PascalScript/uPSPreProcessor.pas new file mode 100644 index 0000000..573d5cf --- /dev/null +++ b/Units/PascalScript/uPSPreProcessor.pas @@ -0,0 +1,800 @@ + +unit uPSPreProcessor; +{$I PascalScript.inc} + +interface +uses + Classes, SysUtils, uPSCompiler, uPSUtils; + + + +type + EPSPreProcessor = class(Exception); //- jgv + TPSPreProcessor = class; + TPSPascalPreProcessorParser = class; + + TPSOnNeedFile = function (Sender: TPSPreProcessor; const callingfilename: tbtstring; var FileName, Output: tbtstring): Boolean; + TPSOnProcessDirective = procedure ( + Sender: TPSPreProcessor; + Parser: TPSPascalPreProcessorParser; + const Active: Boolean; + const DirectiveName, DirectiveParam: tbtString; + Var Continue: Boolean); //- jgv - application set continue to false to stop the normal directive processing + + TPSLineInfo = class(TObject) + private + function GetLineOffset(I: Integer): Cardinal; + function GetLineOffsetCount: Longint; + protected + FEndPos: Cardinal; + FStartPos: Cardinal; + FFileName: tbtstring; + FLineOffsets: TIfList; + public + + property FileName: tbtstring read FFileName; + + property StartPos: Cardinal read FStartPos; + + property EndPos: Cardinal read FEndPos; + + property LineOffsetCount: Longint read GetLineOffsetCount; + + property LineOffset[I: Longint]: Cardinal read GetLineOffset; + + + constructor Create; + + destructor Destroy; override; + end; + + TPSLineInfoResults = record + + Row, + Col, + Pos: Cardinal; + + Name: tbtstring; + end; + + TPSLineInfoList = class(TObject) + private + FItems: TIfList; + FCurrent: Longint; + function GetCount: Longint; + function GetItem(I: Integer): TPSLineInfo; + protected + + function Add: TPSLineInfo; + public + + property Count: Longint read GetCount; + + property Items[I: Longint]: TPSLineInfo read GetItem; default; + + procedure Clear; + + function GetLineInfo(const ModuleName: tbtstring; Pos: Cardinal; var Res: TPSLineInfoResults): Boolean; + + property Current: Longint read FCurrent write FCurrent; + + + constructor Create; + + destructor Destroy; override; + end; + TPSDefineStates = class; + + TPSPreProcessor = class(TObject) + private + FID: Pointer; + FCurrentDefines, FDefines: TStringList; + FCurrentLineInfo: TPSLineInfoList; + FOnNeedFile: TPSOnNeedFile; + FAddedPosition: Cardinal; + FDefineState: TPSDefineStates; + FMaxLevel: Longint; + FMainFileName: tbtstring; + FMainFile: tbtstring; + FOnProcessDirective: TPSOnProcessDirective; + FOnProcessUnknowDirective: TPSOnProcessDirective; + procedure ParserNewLine(Sender: TPSPascalPreProcessorParser; Row, Col, Pos: Cardinal); + procedure IntPreProcess(Level: Integer; const OrgFileName: tbtstring; FileName: tbtstring; Dest: TStream); + protected + procedure doAddStdPredefines; virtual; // jgv + public + {The maximum number of levels deep the parser will go, defaults to 20} + property MaxLevel: Longint read FMaxLevel write FMaxLevel; + property CurrentLineInfo: TPSLineInfoList read FCurrentLineInfo; + + property OnNeedFile: TPSOnNeedFile read FOnNeedFile write FOnNeedFile; + + property Defines: TStringList read FDefines write FDefines; + + property MainFile: tbtstring read FMainFile write FMainFile; + + property MainFileName: tbtstring read FMainFileName write FMainFileName; + + property ID: Pointer read FID write FID; + + procedure AdjustMessages(Comp: TPSPascalCompiler); + procedure AdjustMessage(Msg: TPSPascalCompilerMessage); //-jgv + + procedure PreProcess(const Filename: tbtstring; var Output: tbtstring); + + procedure Clear; + + + constructor Create; + + destructor Destroy; override; + + property OnProcessDirective: TPSOnProcessDirective read fOnProcessDirective write fOnProcessDirective; + property OnProcessUnknowDirective: TPSOnProcessDirective read fOnProcessUnknowDirective write fOnProcessUnknowDirective; + end; + + TPSPascalPreProcessorType = (ptEOF, ptOther, ptDefine); + + TPSOnNewLine = procedure (Sender: TPSPascalPreProcessorParser; Row, Col, Pos: Cardinal) of object; + + TPSPascalPreProcessorParser = class(TObject) + private + FData: tbtstring; + FText: PAnsichar; + FToken: tbtstring; + FTokenId: TPSPascalPreProcessorType; + FLastEnterPos, FLen, FRow, FCol, FPos: Cardinal; + FOnNewLine: TPSOnNewLine; + public + + procedure SetText(const dta: tbtstring); + + procedure Next; + + property Token: tbtstring read FToken; + + property TokenId: TPSPascalPreProcessorType read FTokenId; + + property Row: Cardinal read FRow; + + property Col: Cardinal read FCol; + + property Pos: Cardinal read FPos; + + property OnNewLine: TPSOnNewLine read FOnNewLine write FOnNewLine; + end; + + TPSDefineState = class(TObject) + private + FInElse: Boolean; + FDoWrite: Boolean; + public + + property InElse: Boolean read FInElse write FInElse; + + property DoWrite: Boolean read FDoWrite write FDoWrite; + end; + + TPSDefineStates = class(TObject) + private + FItems: TIfList; + function GetCount: Longint; + function GetItem(I: Integer): TPSDefineState; + function GetWrite: Boolean; + function GetPrevWrite: Boolean; //JeromeWelsh - nesting fix + public + + property Count: Longint read GetCount; + + property Item[I: Longint]: TPSDefineState read GetItem; default; + + function Add: TPSDefineState; + + procedure Delete(I: Longint); + + + constructor Create; + + destructor Destroy; override; + + procedure Clear; + + property DoWrite: Boolean read GetWrite; + property DoPrevWrite: Boolean read GetPrevWrite; //JeromeWelsh - nesting fix + end; + +implementation + +{$IFDEF DELPHI3UP } +resourceString +{$ELSE } +const +{$ENDIF } + + RPS_TooManyNestedInclude = 'Too many nested include files while processing ''%s'' from ''%s'''; + RPS_IncludeNotFound = 'Unable to find file ''%s'' used from ''%s'''; + RPS_DefineTooManyParameters = 'Too many parameters at %d:%d'; + RPS_NoIfdefForEndif = 'No IFDEF for ENDIF at %d:%d'; + RPS_NoIfdefForElse = 'No IFDEF for ELSE at %d:%d'; + RPS_ElseTwice = 'Can''t use ELSE twice at %d:%d'; + RPS_UnknownCompilerDirective = 'Unknown compiler directives at %d:%d'; + RPs_DefineNotClosed = 'Define not closed'; + +{ TPSLineInfoList } + +function TPSLineInfoList.Add: TPSLineInfo; +begin + Result := TPSLineInfo.Create; + FItems.Add(Result); +end; + +procedure TPSLineInfoList.Clear; +var + i: Longint; +begin + for i := FItems.count -1 downto 0 do + TPSLineInfo(FItems[i]).Free; + FItems.Clear; +end; + +constructor TPSLineInfoList.Create; +begin + inherited Create; + FItems := TIfList.Create; +end; + +destructor TPSLineInfoList.Destroy; +begin + Clear; + FItems.Free; + inherited Destroy; +end; + +function TPSLineInfoList.GetCount: Longint; +begin + Result := FItems.Count; +end; + +function TPSLineInfoList.GetItem(I: Integer): TPSLineInfo; +begin + Result := TPSLineInfo(FItems[i]); +end; + +function TPSLineInfoList.GetLineInfo(const ModuleName: tbtstring; Pos: Cardinal; var Res: TPSLineInfoResults): Boolean; +var + i,j: Longint; + linepos: Cardinal; + Item: TPSLineInfo; + lModuleName: tbtstring; +begin + lModuleName := FastUpperCase(ModuleName); + + for i := FItems.Count -1 downto 0 do + begin + Item := FItems[i]; + if (Pos >= Item.StartPos) and (Pos < Item.EndPos) and + (lModuleName = '') or (lModuleName = Item.FileName) then + begin + Res.Name := Item.FileName; + Pos := Pos - Item.StartPos; + Res.Pos := Pos; + Res.Col := 1; + Res.Row := 1; + LinePos := 0; + for j := 0 to Item.LineOffsetCount -1 do + begin + if Pos >= Item.LineOffset[j] then + begin + linepos := Item.LineOffset[j]; + end else + begin + Res.Row := j; // j -1, but line counting starts at 1 + Res.Col := pos - linepos + 1; + Break; + end; + end; + Result := True; + exit; + end; + end; + Result := False; +end; + +{ TPSLineInfo } + +constructor TPSLineInfo.Create; +begin + inherited Create; + FLineOffsets := TIfList.Create; +end; + +destructor TPSLineInfo.Destroy; +begin + FLineOffsets.Free; + inherited Destroy; +end; + + +function TPSLineInfo.GetLineOffset(I: Integer): Cardinal; +begin + Result := Longint(FLineOffsets[I]); +end; + +function TPSLineInfo.GetLineOffsetCount: Longint; +begin + result := FLineOffsets.Count; +end; + +{ TPSPascalPreProcessorParser } + +procedure TPSPascalPreProcessorParser.Next; +var + ci: Cardinal; + +begin + FPos := FPos + FLen; + case FText[FPos] of + #0: + begin + FLen := 0; + FTokenId := ptEof; + end; + '''': + begin + ci := FPos; + while (FText[ci] <> #0) do + begin + Inc(ci); + while FText[ci] = '''' do + begin + if FText[ci+1] <> '''' then Break; + inc(ci); + inc(ci); + end; + if FText[ci] = '''' then Break; + if FText[ci] = #13 then + begin + inc(FRow); + if FText[ci] = #10 then + inc(ci); + FLastEnterPos := ci -1; + if @FOnNewLine <> nil then FOnNewLine(Self, FRow, FPos - FLastEnterPos + 1, ci+1); + end else if FText[ci] = #10 then + begin + inc(FRow); + FLastEnterPos := ci -1; + if @FOnNewLine <> nil then FOnNewLine(Self, FRow, FPos - FLastEnterPos + 1, ci+1); + end; + end; + FLen := ci - FPos + 1; + FTokenId := ptOther; + end; + '(': + begin + if FText[FPos + 1] = '*' then + begin + ci := FPos + 1; + while (FText[ci] <> #0) do begin + if (FText[ci] = '*') and (FText[ci + 1] = ')') then + Break; + if FText[ci] = #13 then + begin + inc(FRow); + if FText[ci+1] = #10 then + inc(ci); + FLastEnterPos := ci -1; + if @FOnNewLine <> nil then FOnNewLine(Self, FRow, FPos - FLastEnterPos + 1, ci+1); + end else if FText[ci] = #10 then + begin + inc(FRow); + FLastEnterPos := ci -1; + if @FOnNewLine <> nil then FOnNewLine(Self, FRow, FPos - FLastEnterPos + 1, ci+1); + end; + Inc(ci); + end; + FTokenId := ptOther; + if (FText[ci] <> #0) then + Inc(ci, 2); + FLen := ci - FPos; + end + else + begin + FTokenId := ptOther; + FLen := 1; + end; + end; + '/': + begin + if FText[FPos + 1] = '/' then + begin + ci := FPos + 1; + while (FText[ci] <> #0) and (FText[ci] <> #13) and + (FText[ci] <> #10) do begin + Inc(ci); + end; + FTokenId := ptOther; + FLen := ci - FPos; + end else + begin + FTokenId := ptOther; + FLen := 1; + end; + end; + '{': + begin + ci := FPos + 1; + while (FText[ci] <> #0) and (FText[ci] <> '}') do begin + if FText[ci] = #13 then + begin + inc(FRow); + if FText[ci+1] = #10 then + inc(ci); + FLastEnterPos := ci - 1; + if @FOnNewLine <> nil then FOnNewLine(Self, FRow, FPos - FLastEnterPos + 1, ci+1); + end else if FText[ci] = #10 then + begin + inc(FRow); + FLastEnterPos := ci - 1; + if @FOnNewLine <> nil then FOnNewLine(Self, FRow, FPos - FLastEnterPos + 1, ci+1); + end; + Inc(ci); + end; + if (FText[FPos + 1] = '$') or (FText[FPos + 1] = '.') then + FTokenId := ptDefine + else + FTokenId := ptOther; + + FLen := ci - FPos + 1; + end; + else + begin + ci := FPos + 1; + while not (FText[ci] in [#0,'{', '(', '''', '/']) do + begin + if FText[ci] = #13 then + begin + inc(FRow); + if FText[ci+1] = #10 then + inc(ci); + FLastEnterPos := ci - 1; + if @FOnNewLine <> nil then FOnNewLine(Self, FRow, FPos - FLastEnterPos + 1, ci+1); + end else if FText[ci] = #10 then + begin + inc(FRow); + FLastEnterPos := ci -1 ; + if @FOnNewLine <> nil then FOnNewLine(Self, FRow, FPos - FLastEnterPos + 1, ci+1); + end; + Inc(Ci); + end; + FTokenId := ptOther; + FLen := ci - FPos; + end; + end; + FCol := FPos - FLastEnterPos + 1; + FToken := Copy(FData, FPos +1, FLen); +end; + +procedure TPSPascalPreProcessorParser.SetText(const dta: tbtstring); +begin + FData := dta; + FText := pAnsichar(FData); + FLen := 0; + FPos := 0; + FCol := 1; + FLastEnterPos := 0; + FRow := 1; + if @FOnNewLine <> nil then FOnNewLine(Self, 1, 1, 0); + Next; +end; + +{ TPSPreProcessor } + +procedure TPSPreProcessor.AdjustMessage(Msg: TPSPascalCompilerMessage); +var + Res: TPSLineInfoResults; +begin + if CurrentLineInfo.GetLineInfo(Msg.ModuleName, Msg.Pos, Res) then + begin + Msg.SetCustomPos(res.Pos, Res.Row, Res.Col); + Msg.ModuleName := Res.Name; + end; +end; + +procedure TPSPreProcessor.AdjustMessages(Comp: TPSPascalCompiler); +var + i: Longint; +begin + for i := 0 to Comp.MsgCount -1 do + AdjustMessage (Comp.Msg[i]); +end; + +procedure TPSPreProcessor.Clear; +begin + FDefineState.Clear; + FDefines.Clear; + FCurrentDefines.Clear; + FCurrentLineInfo.Clear; + FMainFile := ''; +end; + +constructor TPSPreProcessor.Create; +begin + inherited Create; + FDefines := TStringList.Create; + FCurrentLineInfo := TPSLineInfoList.Create; + FCurrentDefines := TStringList.Create; + FDefines.Duplicates := dupIgnore; + FCurrentDefines.Duplicates := dupIgnore; + FDefineState := TPSDefineStates.Create; + FMaxLevel := 20; + + doAddStdPredefines; +end; + +destructor TPSPreProcessor.Destroy; +begin + FDefineState.Free; + FCurrentDefines.Free; + FDefines.Free; + FCurrentLineInfo.Free; + inherited Destroy; +end; + +procedure TPSPreProcessor.doAddStdPredefines; +begin + //--- 20050708_jgv + FCurrentDefines.Add (Format ('VER%d', [PSCurrentBuildNo])); + {$IFDEF CPU386 } + FCurrentDefines.Add ('CPU386'); + {$ENDIF } + {$IFDEF MSWINDOWS } + FCurrentDefines.Add ('MSWINDOWS'); + FCurrentDefines.Add ('WIN32'); + {$ENDIF } + {$IFDEF LINUX } + FCurrentDefines.Add ('LINUX'); + {$ENDIF } +end; + +procedure TPSPreProcessor.IntPreProcess(Level: Integer; const OrgFileName: tbtstring; FileName: tbtstring; Dest: TStream); +var + Parser: TPSPascalPreProcessorParser; + dta: tbtstring; + item: TPSLineInfo; + s, name: tbtstring; + current, i: Longint; + ds: TPSDefineState; + AppContinue: Boolean; +begin + if Level > MaxLevel then raise EPSPreProcessor.CreateFmt(RPS_TooManyNestedInclude, [FileName, OrgFileName]); + Parser := TPSPascalPreProcessorParser.Create; + try + Parser.OnNewLine := ParserNewLine; + if FileName = MainFileName then + begin + dta := MainFile; + end else + if (@OnNeedFile = nil) or (not OnNeedFile(Self, OrgFileName, FileName, dta)) then + raise EPSPreProcessor.CreateFmt(RPS_IncludeNotFound, [FileName, OrgFileName]); + Item := FCurrentLineInfo.Add; + current := FCurrentLineInfo.Count -1; + FCurrentLineInfo.Current := current; + Item.FStartPos := Dest.Position; + Item.FFileName := FileName; + Parser.SetText(dta); + while Parser.TokenId <> ptEOF do + begin + s := Parser.Token; + if Parser.TokenId = ptDefine then + begin + Delete(s,1,2); // delete the {$ + Delete(s,length(s), 1); // delete the } + + //-- 20050707_jgv trim right + i := length (s); + while (i > 0) and (s[i] = ' ') do begin + Delete (s, i, 1); + Dec (i); + end; + //-- end_jgv + + if pos(tbtChar(' '), s) = 0 then + begin + name := uppercase(s); + s := ''; + end else + begin + Name := uppercase(copy(s,1,pos(' ', s)-1)); + Delete(s, 1, pos(' ', s)); + end; + + //-- 20050707_jgv - ask the application + AppContinue := True; + If @OnProcessDirective <> Nil then OnProcessDirective (Self, Parser, FDefineState.DoWrite, name, s, AppContinue); + + If AppContinue then + //-- end jgv + + if (Name = 'I') or (Name = 'INCLUDE') or (Name = '.INCLUDE') then + begin + if FDefineState.DoWrite then + begin + FAddedPosition := 0; + IntPreProcess(Level +1, FileName, s, Dest); + FCurrentLineInfo.Current := current; + FAddedPosition := Cardinal(Dest.Position) - Item.StartPos - Parser.Pos; + end; + end else if (Name = 'DEFINE') then + begin + if FDefineState.DoWrite then + begin + if pos(' ', s) <> 0 then raise EPSPreProcessor.CreateFmt(RPS_DefineTooManyParameters, [Parser.Row, Parser.Col]); + FCurrentDefines.Add(Uppercase(S)); + end; + end else if (Name = 'UNDEF') then + begin + if FDefineState.DoWrite then + begin + if pos(' ', s) <> 0 then raise EPSPreProcessor.CreateFmt(RPS_DefineTooManyParameters, [Parser.Row, Parser.Col]); + i := FCurrentDefines.IndexOf(Uppercase(s)); + if i <> -1 then + FCurrentDefines.Delete(i); + end; + end else if (Name = 'IFDEF') then + begin + if pos(' ', s) <> 0 then raise EPSPreProcessor.CreateFmt(RPS_DefineTooManyParameters, [Parser.Row, Parser.Col]); + //JeromeWelsh - nesting fix + if (FDefineState.DoWrite and (FCurrentDefines.IndexOf(Uppercase(s)) <> -1)) then + FDefineState.Add.DoWrite := True + else + FDefineState.Add.DoWrite := False; + end else if (Name = 'IFNDEF') then + begin + if pos(' ', s) <> 0 then raise EPSPreProcessor.CreateFmt(RPS_DefineTooManyParameters, [Parser.Row, Parser.Col]); + //JeromeWelsh - nesting fix + if (FCurrentDefines.IndexOf(Uppercase(s)) = -1) and FDefineState.DoWrite then + FDefineState.Add.DoWrite := True + else + FDefineState.Add.DoWrite := False; + end else if (Name = 'ENDIF') then + begin + //- jgv remove - borland use it (sysutils.pas) + //- if s <> '' then raise EPSPreProcessor.CreateFmt(RPS_DefineTooManyParameters, [Parser.Row, Parser.Col]); + if FDefineState.Count = 0 then + raise EPSPreProcessor.CreateFmt(RPS_NoIfdefForEndif, [Parser.Row, Parser.Col]); + FDefineState.Delete(FDefineState.Count -1); // remove define from list + end else if (Name = 'ELSE') then + begin + if s<> '' then raise EPSPreProcessor.CreateFmt(RPS_DefineTooManyParameters, [Parser.Row, Parser.Col]); + if FDefineState.Count = 0 then + raise EPSPreProcessor.CreateFmt(RPS_NoIfdefForElse, [Parser.Row, Parser.Col]); + ds := FDefineState[FDefineState.Count -1]; + if ds.InElse then + raise EPSPreProcessor.CreateFmt(RPS_ElseTwice, [Parser.Row, Parser.Col]); + ds.FInElse := True; + //JeromeWelsh - nesting fix + ds.DoWrite := not ds.DoWrite and FDefineState.DoPrevWrite; + end + + //-- 20050710_jgv custom application error process + else if Parser.Token[2] <> '.' then begin + If @OnProcessUnknowDirective <> Nil then begin + OnProcessUnknowDirective (Self, Parser, FDefineState.DoWrite, name, s, AppContinue); + end; + If AppContinue then + //-- end jgv + + raise EPSPreProcessor.CreateFmt(RPS_UnknownCompilerDirective, [Parser.Row, Parser.Col]); + end; + end; + + if (not FDefineState.DoWrite) or (Parser.TokenId = ptDefine) then + begin + SetLength(s, Length(Parser.Token)); + for i := length(s) downto 1 do + s[i] := #32; // space + end; + Dest.Write(s[1], length(s)); + Parser.Next; + end; + Item.FEndPos := Dest.Position; + finally + Parser.Free; + end; +end; + +procedure TPSPreProcessor.ParserNewLine(Sender: TPSPascalPreProcessorParser; Row, Col, Pos: Cardinal); +begin + if FCurrentLineInfo.Current >= FCurrentLineInfo.Count then exit; //errr ??? + with FCurrentLineInfo.Items[FCurrentLineInfo.Current] do + begin + Pos := Pos + FAddedPosition; + FLineOffsets.Add(Pointer(Pos)); + end; +end; + +procedure TPSPreProcessor.PreProcess(const Filename: tbtstring; var Output: tbtstring); +var + Stream: TMemoryStream; +begin + FAddedPosition := 0; + FCurrentDefines.Assign(FDefines); + Stream := TMemoryStream.Create; + try + IntPreProcess(0, '', FileName, Stream); + Stream.Position := 0; + SetLength(Output, Stream.Size); + Stream.Read(Output[1], Length(Output)); + finally + Stream.Free; + end; + if FDefineState.Count <> 0 then + raise EPSPreProcessor.Create(RPs_DefineNotClosed); +end; + +{ TPSDefineStates } + +function TPSDefineStates.Add: TPSDefineState; +begin + Result := TPSDefineState.Create; + FItems.Add(Result); +end; + +procedure TPSDefineStates.Clear; +var + i: Longint; +begin + for i := Longint(FItems.Count) -1 downto 0 do + TPSDefineState(FItems[i]).Free; + FItems.Clear; +end; + +constructor TPSDefineStates.Create; +begin + inherited Create; + FItems := TIfList.Create; +end; + +procedure TPSDefineStates.Delete(I: Integer); +begin + TPSDefineState(FItems[i]).Free; + FItems.Delete(i); +end; + +destructor TPSDefineStates.Destroy; +var + i: Longint; +begin + for i := Longint(FItems.Count) -1 downto 0 do + TPSDefineState(FItems[i]).Free; + FItems.Free; + inherited Destroy; +end; + +function TPSDefineStates.GetCount: Longint; +begin + Result := FItems.Count; +end; + +function TPSDefineStates.GetItem(I: Integer): TPSDefineState; +begin + Result := FItems[i]; +end; + +function TPSDefineStates.GetWrite: Boolean; +begin + if FItems.Count = 0 then + result := true + else Result := TPSDefineState(FItems[FItems.Count -1]).DoWrite; +end; + +//JeromeWelsh - nesting fix +function TPSDefineStates.GetPrevWrite: Boolean; +begin + if FItems.Count < 2 then + result := true + else Result := TPSDefineState(FItems[FItems.Count -2]).DoWrite; +end; + +end. + diff --git a/Units/PascalScript/uPSR_DB.pas b/Units/PascalScript/uPSR_DB.pas new file mode 100644 index 0000000..3c2fb80 --- /dev/null +++ b/Units/PascalScript/uPSR_DB.pas @@ -0,0 +1,2094 @@ +{runtime DB support} +Unit uPSR_DB; +{$I PascalScript.inc} +Interface +Uses uPSRuntime, uPSUtils, SysUtils; + +procedure RIRegisterTDATASET(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTPARAMS(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTPARAM(Cl: TPSRuntimeClassImporter); + +{$IFNDEF FPC} +procedure RIRegisterTGUIDFIELD(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTVARIANTFIELD(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTREFERENCEFIELD(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTDATASETFIELD(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTARRAYFIELD(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTADTFIELD(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTOBJECTFIELD(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTWIDESTRINGFIELD(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTFIELDLIST(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTFIELDDEFLIST(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTFLATLIST(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTDEFCOLLECTION(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTNAMEDITEM(Cl: TPSRuntimeClassImporter); + +{$IFDEF DELPHI6UP} +procedure RIRegisterTFMTBCDFIELD(Cl: TPSRuntimeClassImporter); +{$ENDIF} +procedure RIRegisterTBCDFIELD(Cl: TPSRuntimeClassImporter); + +{$ENDIF} + +procedure RIRegisterTGRAPHICFIELD(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTMEMOFIELD(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTBLOBFIELD(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTVARBYTESFIELD(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTBYTESFIELD(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTBINARYFIELD(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTTIMEFIELD(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTDATEFIELD(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTDATETIMEFIELD(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTBOOLEANFIELD(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTCURRENCYFIELD(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTFLOATFIELD(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTAUTOINCFIELD(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTWORDFIELD(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTLARGEINTFIELD(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTSMALLINTFIELD(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTINTEGERFIELD(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTNUMERICFIELD(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTSTRINGFIELD(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTFIELD(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTLOOKUPLIST(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTFIELDS(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTINDEXDEFS(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTINDEXDEF(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTFIELDDEFS(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTFIELDDEF(Cl: TPSRuntimeClassImporter); +procedure RIRegister_DB(CL: TPSRuntimeClassImporter); + +implementation +Uses DB, {$IFDEF DELPHI6UP}{$IFNDEF FPC}FMTBcd, MaskUtils,{$ENDIF}{$ENDIF}Classes; + +procedure TDATASETONPOSTERROR_W(Self: TDATASET; const T: TDATASETERROREVENT); +begin Self.ONPOSTERROR := T; end; + +procedure TDATASETONPOSTERROR_R(Self: TDATASET; var T: TDATASETERROREVENT); +begin T := Self.ONPOSTERROR; end; + +procedure TDATASETONNEWRECORD_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT); +begin Self.ONNEWRECORD := T; end; + +procedure TDATASETONNEWRECORD_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT); +begin T := Self.ONNEWRECORD; end; + +procedure TDATASETONFILTERRECORD_W(Self: TDATASET; const T: TFILTERRECORDEVENT); +begin Self.ONFILTERRECORD := T; end; + +procedure TDATASETONFILTERRECORD_R(Self: TDATASET; var T: TFILTERRECORDEVENT); +begin T := Self.ONFILTERRECORD; end; + +procedure TDATASETONEDITERROR_W(Self: TDATASET; const T: TDATASETERROREVENT); +begin Self.ONEDITERROR := T; end; + +procedure TDATASETONEDITERROR_R(Self: TDATASET; var T: TDATASETERROREVENT); +begin T := Self.ONEDITERROR; end; + +procedure TDATASETONDELETEERROR_W(Self: TDATASET; const T: TDATASETERROREVENT); +begin Self.ONDELETEERROR := T; end; + +procedure TDATASETONDELETEERROR_R(Self: TDATASET; var T: TDATASETERROREVENT); +begin T := Self.ONDELETEERROR; end; + +procedure TDATASETONCALCFIELDS_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT); +begin Self.ONCALCFIELDS := T; end; + +procedure TDATASETONCALCFIELDS_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT); +begin T := Self.ONCALCFIELDS; end; + +{$IFNDEF FPC} +procedure TDATASETAFTERREFRESH_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT); +begin Self.AFTERREFRESH := T; end; + +procedure TDATASETAFTERREFRESH_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT); +begin T := Self.AFTERREFRESH; end; + +procedure TDATASETBEFOREREFRESH_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT); +begin Self.BEFOREREFRESH := T; end; + +procedure TDATASETBEFOREREFRESH_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT); +begin T := Self.BEFOREREFRESH; end; + +{$ENDIF} + +procedure TDATASETAFTERSCROLL_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT); +begin Self.AFTERSCROLL := T; end; + +procedure TDATASETAFTERSCROLL_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT); +begin T := Self.AFTERSCROLL; end; + +procedure TDATASETBEFORESCROLL_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT); +begin Self.BEFORESCROLL := T; end; + +procedure TDATASETBEFORESCROLL_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT); +begin T := Self.BEFORESCROLL; end; + +procedure TDATASETAFTERDELETE_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT); +begin Self.AFTERDELETE := T; end; + +procedure TDATASETAFTERDELETE_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT); +begin T := Self.AFTERDELETE; end; + +procedure TDATASETBEFOREDELETE_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT); +begin Self.BEFOREDELETE := T; end; + +procedure TDATASETBEFOREDELETE_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT); +begin T := Self.BEFOREDELETE; end; + +procedure TDATASETAFTERCANCEL_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT); +begin Self.AFTERCANCEL := T; end; + +procedure TDATASETAFTERCANCEL_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT); +begin T := Self.AFTERCANCEL; end; + +procedure TDATASETBEFORECANCEL_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT); +begin Self.BEFORECANCEL := T; end; + +procedure TDATASETBEFORECANCEL_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT); +begin T := Self.BEFORECANCEL; end; + +procedure TDATASETAFTERPOST_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT); +begin Self.AFTERPOST := T; end; + +procedure TDATASETAFTERPOST_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT); +begin T := Self.AFTERPOST; end; + +procedure TDATASETBEFOREPOST_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT); +begin Self.BEFOREPOST := T; end; + +procedure TDATASETBEFOREPOST_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT); +begin T := Self.BEFOREPOST; end; + +procedure TDATASETAFTEREDIT_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT); +begin Self.AFTEREDIT := T; end; + +procedure TDATASETAFTEREDIT_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT); +begin T := Self.AFTEREDIT; end; + +procedure TDATASETBEFOREEDIT_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT); +begin Self.BEFOREEDIT := T; end; + +procedure TDATASETBEFOREEDIT_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT); +begin T := Self.BEFOREEDIT; end; + +procedure TDATASETAFTERINSERT_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT); +begin Self.AFTERINSERT := T; end; + +procedure TDATASETAFTERINSERT_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT); +begin T := Self.AFTERINSERT; end; + +procedure TDATASETBEFOREINSERT_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT); +begin Self.BEFOREINSERT := T; end; + +procedure TDATASETBEFOREINSERT_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT); +begin T := Self.BEFOREINSERT; end; + +procedure TDATASETAFTERCLOSE_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT); +begin Self.AFTERCLOSE := T; end; + +procedure TDATASETAFTERCLOSE_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT); +begin T := Self.AFTERCLOSE; end; + +procedure TDATASETBEFORECLOSE_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT); +begin Self.BEFORECLOSE := T; end; + +procedure TDATASETBEFORECLOSE_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT); +begin T := Self.BEFORECLOSE; end; + +procedure TDATASETAFTEROPEN_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT); +begin Self.AFTEROPEN := T; end; + +procedure TDATASETAFTEROPEN_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT); +begin T := Self.AFTEROPEN; end; + +procedure TDATASETBEFOREOPEN_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT); +begin Self.BEFOREOPEN := T; end; + +procedure TDATASETBEFOREOPEN_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT); +begin T := Self.BEFOREOPEN; end; + +procedure TDATASETAUTOCALCFIELDS_W(Self: TDATASET; const T: BOOLEAN); +begin Self.AUTOCALCFIELDS := T; end; + +procedure TDATASETAUTOCALCFIELDS_R(Self: TDATASET; var T: BOOLEAN); +begin T := Self.AUTOCALCFIELDS; end; + +procedure TDATASETACTIVE_W(Self: TDATASET; const T: BOOLEAN); +begin Self.ACTIVE := T; end; + +procedure TDATASETACTIVE_R(Self: TDATASET; var T: BOOLEAN); +begin T := Self.ACTIVE; end; + +procedure TDATASETFILTEROPTIONS_W(Self: TDATASET; const T: TFILTEROPTIONS); +begin Self.FILTEROPTIONS := T; end; + +procedure TDATASETFILTEROPTIONS_R(Self: TDATASET; var T: TFILTEROPTIONS); +begin T := Self.FILTEROPTIONS; end; + +procedure TDATASETFILTERED_W(Self: TDATASET; const T: BOOLEAN); +begin Self.FILTERED := T; end; + +procedure TDATASETFILTERED_R(Self: TDATASET; var T: BOOLEAN); +begin T := Self.FILTERED; end; + +procedure TDATASETFILTER_W(Self: TDATASET; const T: String); +begin Self.FILTER := T; end; + +procedure TDATASETFILTER_R(Self: TDATASET; var T: String); +begin T := Self.FILTER; end; + +procedure TDATASETSTATE_R(Self: TDATASET; var T: TDATASETSTATE); +begin T := Self.STATE; end; + +{$IFNDEF FPC} +procedure TDATASETSPARSEARRAYS_W(Self: TDATASET; const T: BOOLEAN); +begin Self.SPARSEARRAYS := T; end; + +procedure TDATASETSPARSEARRAYS_R(Self: TDATASET; var T: BOOLEAN); +begin T := Self.SPARSEARRAYS; end; +{$ENDIF} + +procedure TDATASETRECORDSIZE_R(Self: TDATASET; var T: WORD); +begin T := Self.RECORDSIZE; end; + +procedure TDATASETRECNO_W(Self: TDATASET; const T: INTEGER); +begin Self.RECNO := T; end; + +procedure TDATASETRECNO_R(Self: TDATASET; var T: INTEGER); +begin T := Self.RECNO; end; + +procedure TDATASETRECORDCOUNT_R(Self: TDATASET; var T: INTEGER); +begin T := Self.RECORDCOUNT; end; + +{$IFNDEF FPC} +procedure TDATASETOBJECTVIEW_W(Self: TDATASET; const T: BOOLEAN); +begin Self.OBJECTVIEW := T; end; + +procedure TDATASETOBJECTVIEW_R(Self: TDATASET; var T: BOOLEAN); +begin T := Self.OBJECTVIEW; end; +{$ENDIF} + +procedure TDATASETMODIFIED_R(Self: TDATASET; var T: BOOLEAN); +begin T := Self.MODIFIED; end; + +{$IFDEF DELPHI6UP} +procedure TDATASETISUNIDIRECTIONAL_R(Self: TDATASET; var T: BOOLEAN); +begin T := Self.ISUNIDIRECTIONAL; end; +{$ENDIF} + +procedure TDATASETFOUND_R(Self: TDATASET; var T: BOOLEAN); +begin T := Self.FOUND; end; + +procedure TDATASETFIELDVALUES_W(Self: TDATASET; const T: VARIANT; const t1: String); +begin Self.FIELDVALUES[t1] := T; end; + +procedure TDATASETFIELDVALUES_R(Self: TDATASET; var T: VARIANT; const t1: String); +begin T := Self.FIELDVALUES[t1]; end; + +procedure TDATASETFIELDS_R(Self: TDATASET; var T: TFIELDS); +begin T := Self.FIELDS; end; + +{$IFNDEF FPC} + +procedure TDATASETFIELDLIST_R(Self: TDATASET; var T: TFIELDLIST); +begin T := Self.FIELDLIST; end; + + +procedure TDATASETFIELDDEFLIST_R(Self: TDATASET; var T: TFIELDDEFLIST); +begin T := Self.FIELDDEFLIST; end; + +procedure TDATASETFIELDDEFS_W(Self: TDATASET; const T: TFIELDDEFS); +begin Self.FIELDDEFS := T; end; + +procedure TDATASETFIELDDEFS_R(Self: TDATASET; var T: TFIELDDEFS); +begin T := Self.FIELDDEFS; end; + +procedure TDATASETBLOCKREADSIZE_W(Self: TDATASET; const T: INTEGER); +begin Self.BLOCKREADSIZE := T; end; + +procedure TDATASETBLOCKREADSIZE_R(Self: TDATASET; var T: INTEGER); +begin T := Self.BLOCKREADSIZE; end; + +procedure TDATASETDESIGNER_R(Self: TDATASET; var T: TDATASETDESIGNER); +begin T := Self.DESIGNER; end; + + +procedure TDATASETDATASETFIELD_W(Self: TDATASET; const T: TDATASETFIELD); +begin Self.DATASETFIELD := T; end; + + + +procedure TDATASETDATASETFIELD_R(Self: TDATASET; var T: TDATASETFIELD); +begin T := Self.DATASETFIELD; end; + + +procedure TDATASETAGGFIELDS_R(Self: TDATASET; var T: TFIELDS); +begin T := Self.AGGFIELDS; end; + + + +{$ENDIF} + +procedure TDATASETFIELDCOUNT_R(Self: TDATASET; var T: INTEGER); +begin T := Self.FIELDCOUNT; end; + + +procedure TDATASETEOF_R(Self: TDATASET; var T: BOOLEAN); +begin T := Self.EOF; end; + +procedure TDATASETDEFAULTFIELDS_R(Self: TDATASET; var T: BOOLEAN); +begin T := Self.DEFAULTFIELDS; end; + +procedure TDATASETDATASOURCE_R(Self: TDATASET; var T: TDATASOURCE); +begin T := Self.DATASOURCE; end; + + + +procedure TDATASETCANMODIFY_R(Self: TDATASET; var T: BOOLEAN); +begin T := Self.CANMODIFY; end; + +//procedure TDATASETBOOKMARK_W(Self: TDATASET; const T: TBOOKMARKSTR); +//begin Self.BOOKMARK := T; end; + +//procedure TDATASETBOOKMARK_R(Self: TDATASET; var T: TBOOKMARKSTR); +//begin T := Self.BOOKMARK; end; + +procedure TDATASETBOF_R(Self: TDATASET; var T: BOOLEAN); +begin T := Self.BOF; end; + +procedure TPARAMSPARAMVALUES_W(Self: TPARAMS; const T: VARIANT; const t1: String); +begin Self.PARAMVALUES[t1] := T; end; + +procedure TPARAMSPARAMVALUES_R(Self: TPARAMS; var T: VARIANT; const t1: String); +begin T := Self.PARAMVALUES[t1]; end; + +procedure TPARAMSITEMS_W(Self: TPARAMS; const T: TPARAM; const t1: INTEGER); +begin Self.ITEMS[t1] := T; end; + +procedure TPARAMSITEMS_R(Self: TPARAMS; var T: TPARAM; const t1: INTEGER); +begin T := Self.ITEMS[t1]; end; + +procedure TPARAMVALUE_W(Self: TPARAM; const T: VARIANT); +begin Self.VALUE := T; end; + +procedure TPARAMVALUE_R(Self: TPARAM; var T: VARIANT); +begin T := Self.VALUE; end; + + +{$IFDEF DELPHI6UP} +procedure TPARAMSIZE_W(Self: TPARAM; const T: INTEGER); +begin Self.SIZE := T; end; + +procedure TPARAMSIZE_R(Self: TPARAM; var T: INTEGER); +begin T := Self.SIZE; end; +{$ENDIF} + +procedure TPARAMPARAMTYPE_W(Self: TPARAM; const T: TPARAMTYPE); +begin Self.PARAMTYPE := T; end; + +procedure TPARAMPARAMTYPE_R(Self: TPARAM; var T: TPARAMTYPE); +begin T := Self.PARAMTYPE; end; + +procedure TPARAMNAME_W(Self: TPARAM; const T: String); +begin Self.NAME := T; end; + +procedure TPARAMNAME_R(Self: TPARAM; var T: String); +begin T := Self.NAME; end; + +{$IFDEF DELPHI6UP} +procedure TPARAMNUMERICSCALE_W(Self: TPARAM; const T: INTEGER); +begin Self.NUMERICSCALE := T; end; + +procedure TPARAMNUMERICSCALE_R(Self: TPARAM; var T: INTEGER); +begin T := Self.NUMERICSCALE; end; +{$ENDIF} +{$IFDEF DELPHI6UP} + +procedure TPARAMPRECISION_W(Self: TPARAM; const T: INTEGER); +begin Self.PRECISION := T; end; + +procedure TPARAMPRECISION_R(Self: TPARAM; var T: INTEGER); +begin T := Self.PRECISION; end; +{$ENDIF} +procedure TPARAMDATATYPE_W(Self: TPARAM; const T: TFIELDTYPE); +begin Self.DATATYPE := T; end; + +procedure TPARAMDATATYPE_R(Self: TPARAM; var T: TFIELDTYPE); +begin T := Self.DATATYPE; end; + +procedure TPARAMTEXT_W(Self: TPARAM; const T: String); +begin Self.TEXT := T; end; + +procedure TPARAMTEXT_R(Self: TPARAM; var T: String); +begin T := Self.TEXT; end; + +procedure TPARAMNATIVESTR_W(Self: TPARAM; const T: String); +begin Self.NATIVESTR := T; end; + +procedure TPARAMNATIVESTR_R(Self: TPARAM; var T: String); +begin T := Self.NATIVESTR; end; + +procedure TPARAMISNULL_R(Self: TPARAM; var T: BOOLEAN); +begin T := Self.ISNULL; end; + +procedure TPARAMBOUND_W(Self: TPARAM; const T: BOOLEAN); +begin Self.BOUND := T; end; + +procedure TPARAMBOUND_R(Self: TPARAM; var T: BOOLEAN); +begin T := Self.BOUND; end; + +procedure TPARAMASWORD_W(Self: TPARAM; const T: LONGINT); +begin Self.ASWORD := T; end; + +procedure TPARAMASWORD_R(Self: TPARAM; var T: LONGINT); +begin T := Self.ASWORD; end; + +procedure TPARAMASTIME_W(Self: TPARAM; const T: TDATETIME); +begin Self.ASTIME := T; end; + +procedure TPARAMASTIME_R(Self: TPARAM; var T: TDATETIME); +begin T := Self.ASTIME; end; + +procedure TPARAMASSTRING_W(Self: TPARAM; const T: String); +begin Self.ASSTRING := T; end; + +procedure TPARAMASSTRING_R(Self: TPARAM; var T: String); +begin T := Self.ASSTRING; end; + +procedure TPARAMASMEMO_W(Self: TPARAM; const T: String); +begin Self.ASMEMO := T; end; + +procedure TPARAMASMEMO_R(Self: TPARAM; var T: String); +begin T := Self.ASMEMO; end; + +procedure TPARAMASSMALLINT_W(Self: TPARAM; const T: LONGINT); +begin Self.ASSMALLINT := T; end; + +procedure TPARAMASSMALLINT_R(Self: TPARAM; var T: LONGINT); +begin T := Self.ASSMALLINT; end; + +procedure TPARAMASINTEGER_W(Self: TPARAM; const T: LONGINT); +begin Self.ASINTEGER := T; end; + +procedure TPARAMASINTEGER_R(Self: TPARAM; var T: LONGINT); +begin T := Self.ASINTEGER; end; + +procedure TPARAMASFLOAT_W(Self: TPARAM; const T: DOUBLE); +begin Self.ASFLOAT := T; end; + +procedure TPARAMASFLOAT_R(Self: TPARAM; var T: DOUBLE); +begin T := Self.ASFLOAT; end; + +procedure TPARAMASDATETIME_W(Self: TPARAM; const T: TDATETIME); +begin Self.ASDATETIME := T; end; + +procedure TPARAMASDATETIME_R(Self: TPARAM; var T: TDATETIME); +begin T := Self.ASDATETIME; end; + +procedure TPARAMASDATE_W(Self: TPARAM; const T: TDATETIME); +begin Self.ASDATE := T; end; + +procedure TPARAMASDATE_R(Self: TPARAM; var T: TDATETIME); +begin T := Self.ASDATE; end; + +procedure TPARAMASCURRENCY_W(Self: TPARAM; const T: CURRENCY); +begin Self.ASCURRENCY := T; end; + +procedure TPARAMASCURRENCY_R(Self: TPARAM; var T: CURRENCY); +begin T := Self.ASCURRENCY; end; + +procedure TPARAMASBOOLEAN_W(Self: TPARAM; const T: BOOLEAN); +begin Self.ASBOOLEAN := T; end; + +procedure TPARAMASBOOLEAN_R(Self: TPARAM; var T: BOOLEAN); +begin T := Self.ASBOOLEAN; end; + +procedure TPARAMASBLOB_W(Self: TPARAM; const T: TBLOBDATA); +begin Self.ASBLOB := T; end; + +procedure TPARAMASBLOB_R(Self: TPARAM; var T: TBLOBDATA); +begin T := Self.ASBLOB; end; + +{$IFNDEF FPC} + +{$IFDEF DELPHI6UP} +procedure TPARAMASFMTBCD_W(Self: TPARAM; const T: TBCD); +begin Self.ASFMTBCD := T; end; + +procedure TPARAMASFMTBCD_R(Self: TPARAM; var T: TBCD); +begin T := Self.ASFMTBCD; end; +{$ENDIF} +procedure TPARAMASBCD_W(Self: TPARAM; const T: CURRENCY); +begin Self.ASBCD := T; end; + +procedure TPARAMASBCD_R(Self: TPARAM; var T: CURRENCY); +begin T := Self.ASBCD; end; + +procedure TREFERENCEFIELDREFERENCETABLENAME_W(Self: TREFERENCEFIELD; const T: String); +begin Self.REFERENCETABLENAME := T; end; + +procedure TREFERENCEFIELDREFERENCETABLENAME_R(Self: TREFERENCEFIELD; var T: String); +begin T := Self.REFERENCETABLENAME; end; + + +procedure TDATASETFIELDINCLUDEOBJECTFIELD_W(Self: TDATASETFIELD; const T: BOOLEAN); +begin Self.INCLUDEOBJECTFIELD := T; end; + +procedure TDATASETFIELDINCLUDEOBJECTFIELD_R(Self: TDATASETFIELD; var T: BOOLEAN); +begin T := Self.INCLUDEOBJECTFIELD; end; + +procedure TDATASETFIELDNESTEDDATASET_R(Self: TDATASETFIELD; var T: TDATASET); +begin T := Self.NESTEDDATASET; end; + +procedure TOBJECTFIELDOBJECTTYPE_W(Self: TOBJECTFIELD; const T: String); +begin Self.OBJECTTYPE := T; end; + +procedure TOBJECTFIELDOBJECTTYPE_R(Self: TOBJECTFIELD; var T: String); +begin T := Self.OBJECTTYPE; end; + +procedure TOBJECTFIELDUNNAMED_R(Self: TOBJECTFIELD; var T: BOOLEAN); +begin T := Self.UNNAMED; end; + +procedure TOBJECTFIELDFIELDVALUES_W(Self: TOBJECTFIELD; const T: VARIANT; const t1: INTEGER); +begin Self.FIELDVALUES[t1] := T; end; + +procedure TOBJECTFIELDFIELDVALUES_R(Self: TOBJECTFIELD; var T: VARIANT; const t1: INTEGER); +begin T := Self.FIELDVALUES[t1]; end; + +procedure TOBJECTFIELDFIELDS_R(Self: TOBJECTFIELD; var T: TFIELDS); +begin T := Self.FIELDS; end; + +procedure TOBJECTFIELDFIELDCOUNT_R(Self: TOBJECTFIELD; var T: INTEGER); +begin T := Self.FIELDCOUNT; end; +{$ENDIF} + + +{$IFNDEF FPC} +{$IFDEF DELPHI6UP} +procedure TBLOBFIELDGRAPHICHEADER_W(Self: TBLOBFIELD; const T: BOOLEAN); +begin Self.GRAPHICHEADER := T; end; + +procedure TBLOBFIELDGRAPHICHEADER_R(Self: TBLOBFIELD; var T: BOOLEAN); +begin T := Self.GRAPHICHEADER; end; +{$ENDIF} +{$ENDIF} + +procedure TBLOBFIELDBLOBTYPE_W(Self: TBLOBFIELD; const T: TBLOBTYPE); +begin Self.BLOBTYPE := T; end; + +procedure TBLOBFIELDBLOBTYPE_R(Self: TBLOBFIELD; var T: TBLOBTYPE); +begin T := Self.BLOBTYPE; end; + +procedure TBLOBFIELDTRANSLITERATE_W(Self: TBLOBFIELD; const T: BOOLEAN); +begin Self.TRANSLITERATE := T; end; + +procedure TBLOBFIELDTRANSLITERATE_R(Self: TBLOBFIELD; var T: BOOLEAN); +begin T := Self.TRANSLITERATE; end; + +procedure TBLOBFIELDVALUE_W(Self: TBLOBFIELD; const T: String); +{$IFDEF DELPHI2009UP} +var + b: TBytes; +begin + setLEngth(b, Length(T)); + Move(T[1], b[0], Length(T)); + self.Value := b; + {$ELSE} +begin + Self.VALUE := T; + {$ENDIF} +end; + +procedure TBLOBFIELDVALUE_R(Self: TBLOBFIELD; var T: String); +begin +{$IFDEF DELPHI2009UP} + SetLength(t, Length(SElf.Value)); + Move(Self.Value[0], t[1], LEngth(T)); +{$ELSE} + T := Self.VALUE; +{$ENDIF} +end; + +procedure TBLOBFIELDMODIFIED_W(Self: TBLOBFIELD; const T: BOOLEAN); +begin Self.MODIFIED := T; end; + +procedure TBLOBFIELDMODIFIED_R(Self: TBLOBFIELD; var T: BOOLEAN); +begin T := Self.MODIFIED; end; + +procedure TBLOBFIELDBLOBSIZE_R(Self: TBLOBFIELD; var T: INTEGER); +begin T := Self.BLOBSIZE; end; + +{$IFNDEF FPC} +{$IFDEF DELPHI6UP} +procedure TFMTBCDFIELDPRECISION_W(Self: TFMTBCDFIELD; const T: INTEGER); +begin Self.PRECISION := T; end; + +procedure TFMTBCDFIELDPRECISION_R(Self: TFMTBCDFIELD; var T: INTEGER); +begin T := Self.PRECISION; end; + +procedure TFMTBCDFIELDMINVALUE_W(Self: TFMTBCDFIELD; const T: String); +begin Self.MINVALUE := T; end; + +procedure TFMTBCDFIELDMINVALUE_R(Self: TFMTBCDFIELD; var T: String); +begin T := Self.MINVALUE; end; + +procedure TFMTBCDFIELDMAXVALUE_W(Self: TFMTBCDFIELD; const T: String); +begin Self.MAXVALUE := T; end; + +procedure TFMTBCDFIELDMAXVALUE_R(Self: TFMTBCDFIELD; var T: String); +begin T := Self.MAXVALUE; end; + +procedure TFMTBCDFIELDCURRENCY_W(Self: TFMTBCDFIELD; const T: BOOLEAN); +begin Self.CURRENCY := T; end; + +procedure TFMTBCDFIELDCURRENCY_R(Self: TFMTBCDFIELD; var T: BOOLEAN); +begin T := Self.CURRENCY; end; + +procedure TFMTBCDFIELDVALUE_W(Self: TFMTBCDFIELD; const T: TBCD); +begin Self.VALUE := T; end; + +procedure TFMTBCDFIELDVALUE_R(Self: TFMTBCDFIELD; var T: TBCD); +begin T := Self.VALUE; end; +{$ENDIF} + +procedure TBCDFIELDPRECISION_W(Self: TBCDFIELD; const T: INTEGER); +begin Self.PRECISION := T; end; + +procedure TBCDFIELDPRECISION_R(Self: TBCDFIELD; var T: INTEGER); +begin T := Self.PRECISION; end; + +procedure TBCDFIELDMINVALUE_W(Self: TBCDFIELD; const T: CURRENCY); +begin Self.MINVALUE := T; end; + +procedure TBCDFIELDMINVALUE_R(Self: TBCDFIELD; var T: CURRENCY); +begin T := Self.MINVALUE; end; + +procedure TBCDFIELDMAXVALUE_W(Self: TBCDFIELD; const T: CURRENCY); +begin Self.MAXVALUE := T; end; + +procedure TBCDFIELDMAXVALUE_R(Self: TBCDFIELD; var T: CURRENCY); +begin T := Self.MAXVALUE; end; + +procedure TBCDFIELDCURRENCY_W(Self: TBCDFIELD; const T: BOOLEAN); +begin Self.CURRENCY := T; end; + +procedure TBCDFIELDCURRENCY_R(Self: TBCDFIELD; var T: BOOLEAN); +begin T := Self.CURRENCY; end; + +procedure TBCDFIELDVALUE_W(Self: TBCDFIELD; const T: CURRENCY); +begin Self.VALUE := T; end; + +procedure TBCDFIELDVALUE_R(Self: TBCDFIELD; var T: CURRENCY); +begin T := Self.VALUE; end; +{$ENDIF} + + +procedure TDATETIMEFIELDDISPLAYFORMAT_W(Self: TDATETIMEFIELD; const T: String); +begin Self.DISPLAYFORMAT := T; end; + +procedure TDATETIMEFIELDDISPLAYFORMAT_R(Self: TDATETIMEFIELD; var T: String); +begin T := Self.DISPLAYFORMAT; end; + +procedure TDATETIMEFIELDVALUE_W(Self: TDATETIMEFIELD; const T: TDATETIME); +begin Self.VALUE := T; end; + +procedure TDATETIMEFIELDVALUE_R(Self: TDATETIMEFIELD; var T: TDATETIME); +begin T := Self.VALUE; end; + +procedure TBOOLEANFIELDDISPLAYVALUES_W(Self: TBOOLEANFIELD; const T: String); +begin Self.DISPLAYVALUES := T; end; + +procedure TBOOLEANFIELDDISPLAYVALUES_R(Self: TBOOLEANFIELD; var T: String); +begin T := Self.DISPLAYVALUES; end; + +procedure TBOOLEANFIELDVALUE_W(Self: TBOOLEANFIELD; const T: BOOLEAN); +begin Self.VALUE := T; end; + +procedure TBOOLEANFIELDVALUE_R(Self: TBOOLEANFIELD; var T: BOOLEAN); +begin T := Self.VALUE; end; + +procedure TFLOATFIELDPRECISION_W(Self: TFLOATFIELD; const T: INTEGER); +begin Self.PRECISION := T; end; + +procedure TFLOATFIELDPRECISION_R(Self: TFLOATFIELD; var T: INTEGER); +begin T := Self.PRECISION; end; + +procedure TFLOATFIELDMINVALUE_W(Self: TFLOATFIELD; const T: DOUBLE); +begin Self.MINVALUE := T; end; + +procedure TFLOATFIELDMINVALUE_R(Self: TFLOATFIELD; var T: DOUBLE); +begin T := Self.MINVALUE; end; + +procedure TFLOATFIELDMAXVALUE_W(Self: TFLOATFIELD; const T: DOUBLE); +begin Self.MAXVALUE := T; end; + +procedure TFLOATFIELDMAXVALUE_R(Self: TFLOATFIELD; var T: DOUBLE); +begin T := Self.MAXVALUE; end; + +{$IFNDEF FPC} +procedure TFLOATFIELDCURRENCY_W(Self: TFLOATFIELD; const T: BOOLEAN); +begin Self.CURRENCY := T; end; + +procedure TFLOATFIELDCURRENCY_R(Self: TFLOATFIELD; var T: BOOLEAN); +begin T := Self.CURRENCY; end; +{$ENDIF} + +procedure TFLOATFIELDVALUE_W(Self: TFLOATFIELD; const T: DOUBLE); +begin Self.VALUE := T; end; + +procedure TFLOATFIELDVALUE_R(Self: TFLOATFIELD; var T: DOUBLE); +begin T := Self.VALUE; end; + +procedure TLARGEINTFIELDMINVALUE_W(Self: TLARGEINTFIELD; const T: LARGEINT); +begin Self.MINVALUE := T; end; + +procedure TLARGEINTFIELDMINVALUE_R(Self: TLARGEINTFIELD; var T: LARGEINT); +begin T := Self.MINVALUE; end; + +procedure TLARGEINTFIELDMAXVALUE_W(Self: TLARGEINTFIELD; const T: LARGEINT); +begin Self.MAXVALUE := T; end; + +procedure TLARGEINTFIELDMAXVALUE_R(Self: TLARGEINTFIELD; var T: LARGEINT); +begin T := Self.MAXVALUE; end; + +procedure TLARGEINTFIELDVALUE_W(Self: TLARGEINTFIELD; const T: LARGEINT); +begin Self.VALUE := T; end; + +procedure TLARGEINTFIELDVALUE_R(Self: TLARGEINTFIELD; var T: LARGEINT); +begin T := Self.VALUE; end; + +procedure TLARGEINTFIELDASLARGEINT_W(Self: TLARGEINTFIELD; const T: LARGEINT); +begin Self.ASLARGEINT := T; end; + +procedure TLARGEINTFIELDASLARGEINT_R(Self: TLARGEINTFIELD; var T: LARGEINT); +begin T := Self.ASLARGEINT; end; + +procedure TINTEGERFIELDMINVALUE_W(Self: TINTEGERFIELD; const T: LONGINT); +begin Self.MINVALUE := T; end; + +procedure TINTEGERFIELDMINVALUE_R(Self: TINTEGERFIELD; var T: LONGINT); +begin T := Self.MINVALUE; end; + +procedure TINTEGERFIELDMAXVALUE_W(Self: TINTEGERFIELD; const T: LONGINT); +begin Self.MAXVALUE := T; end; + +procedure TINTEGERFIELDMAXVALUE_R(Self: TINTEGERFIELD; var T: LONGINT); +begin T := Self.MAXVALUE; end; + +procedure TINTEGERFIELDVALUE_W(Self: TINTEGERFIELD; const T: LONGINT); +begin Self.VALUE := T; end; + +procedure TINTEGERFIELDVALUE_R(Self: TINTEGERFIELD; var T: LONGINT); +begin T := Self.VALUE; end; + +procedure TNUMERICFIELDEDITFORMAT_W(Self: TNUMERICFIELD; const T: String); +begin Self.EDITFORMAT := T; end; + +procedure TNUMERICFIELDEDITFORMAT_R(Self: TNUMERICFIELD; var T: String); +begin T := Self.EDITFORMAT; end; + +procedure TNUMERICFIELDDISPLAYFORMAT_W(Self: TNUMERICFIELD; const T: String); +begin Self.DISPLAYFORMAT := T; end; + +procedure TNUMERICFIELDDISPLAYFORMAT_R(Self: TNUMERICFIELD; var T: String); +begin T := Self.DISPLAYFORMAT; end; + +{$IFNDEF FPC} +procedure TWIDESTRINGFIELDVALUE_W(Self: TWIDESTRINGFIELD; const T: WIDESTRING); +begin Self.VALUE := T; end; + +procedure TWIDESTRINGFIELDVALUE_R(Self: TWIDESTRINGFIELD; var T: WIDESTRING); +begin T := Self.VALUE; end; + +procedure TSTRINGFIELDTRANSLITERATE_W(Self: TSTRINGFIELD; const T: BOOLEAN); +begin Self.TRANSLITERATE := T; end; + +procedure TSTRINGFIELDTRANSLITERATE_R(Self: TSTRINGFIELD; var T: BOOLEAN); +begin T := Self.TRANSLITERATE; end; + +procedure TSTRINGFIELDFIXEDCHAR_W(Self: TSTRINGFIELD; const T: BOOLEAN); +begin Self.FIXEDCHAR := T; end; + +procedure TSTRINGFIELDFIXEDCHAR_R(Self: TSTRINGFIELD; var T: BOOLEAN); +begin T := Self.FIXEDCHAR; end; +{$ENDIF} + + +procedure TSTRINGFIELDVALUE_W(Self: TSTRINGFIELD; const T: String); +begin Self.VALUE := T; end; + +procedure TSTRINGFIELDVALUE_R(Self: TSTRINGFIELD; var T: String); +begin T := Self.VALUE; end; + +procedure TFIELDONVALIDATE_W(Self: TFIELD; const T: TFIELDNOTIFYEVENT); +begin Self.ONVALIDATE := T; end; + +procedure TFIELDONVALIDATE_R(Self: TFIELD; var T: TFIELDNOTIFYEVENT); +begin T := Self.ONVALIDATE; end; + +procedure TFIELDONSETTEXT_W(Self: TFIELD; const T: TFIELDSETTEXTEVENT); +begin Self.ONSETTEXT := T; end; + +procedure TFIELDONSETTEXT_R(Self: TFIELD; var T: TFIELDSETTEXTEVENT); +begin T := Self.ONSETTEXT; end; + +procedure TFIELDONGETTEXT_W(Self: TFIELD; const T: TFIELDGETTEXTEVENT); +begin Self.ONGETTEXT := T; end; + +procedure TFIELDONGETTEXT_R(Self: TFIELD; var T: TFIELDGETTEXTEVENT); +begin T := Self.ONGETTEXT; end; + +procedure TFIELDONCHANGE_W(Self: TFIELD; const T: TFIELDNOTIFYEVENT); +begin Self.ONCHANGE := T; end; + +procedure TFIELDONCHANGE_R(Self: TFIELD; var T: TFIELDNOTIFYEVENT); +begin T := Self.ONCHANGE; end; + +procedure TFIELDVISIBLE_W(Self: TFIELD; const T: BOOLEAN); +begin Self.VISIBLE := T; end; + +procedure TFIELDVISIBLE_R(Self: TFIELD; var T: BOOLEAN); +begin T := Self.VISIBLE; end; + +procedure TFIELDREQUIRED_W(Self: TFIELD; const T: BOOLEAN); +begin Self.REQUIRED := T; end; + +procedure TFIELDREQUIRED_R(Self: TFIELD; var T: BOOLEAN); +begin T := Self.REQUIRED; end; + +procedure TFIELDREADONLY_W(Self: TFIELD; const T: BOOLEAN); +begin Self.READONLY := T; end; + +procedure TFIELDREADONLY_R(Self: TFIELD; var T: BOOLEAN); +begin T := Self.READONLY; end; + +procedure TFIELDPROVIDERFLAGS_W(Self: TFIELD; const T: TPROVIDERFLAGS); +begin Self.PROVIDERFLAGS := T; end; + +procedure TFIELDPROVIDERFLAGS_R(Self: TFIELD; var T: TPROVIDERFLAGS); +begin T := Self.PROVIDERFLAGS; end; + +procedure TFIELDORIGIN_W(Self: TFIELD; const T: String); +begin Self.ORIGIN := T; end; + +procedure TFIELDORIGIN_R(Self: TFIELD; var T: String); +begin T := Self.ORIGIN; end; + +procedure TFIELDLOOKUPCACHE_W(Self: TFIELD; const T: BOOLEAN); +begin Self.LOOKUPCACHE := T; end; + +procedure TFIELDLOOKUPCACHE_R(Self: TFIELD; var T: BOOLEAN); +begin T := Self.LOOKUPCACHE; end; + +procedure TFIELDKEYFIELDS_W(Self: TFIELD; const T: String); +begin Self.KEYFIELDS := T; end; + +procedure TFIELDKEYFIELDS_R(Self: TFIELD; var T: String); +begin T := Self.KEYFIELDS; end; + +procedure TFIELDLOOKUPRESULTFIELD_W(Self: TFIELD; const T: String); +begin Self.LOOKUPRESULTFIELD := T; end; + +procedure TFIELDLOOKUPRESULTFIELD_R(Self: TFIELD; var T: String); +begin T := Self.LOOKUPRESULTFIELD; end; + +procedure TFIELDLOOKUPKEYFIELDS_W(Self: TFIELD; const T: String); +begin Self.LOOKUPKEYFIELDS := T; end; + +procedure TFIELDLOOKUPKEYFIELDS_R(Self: TFIELD; var T: String); +begin T := Self.LOOKUPKEYFIELDS; end; + +procedure TFIELDLOOKUPDATASET_W(Self: TFIELD; const T: TDATASET); +begin Self.LOOKUPDATASET := T; end; + +procedure TFIELDLOOKUPDATASET_R(Self: TFIELD; var T: TDATASET); +begin T := Self.LOOKUPDATASET; end; + +procedure TFIELDIMPORTEDCONSTRAINT_W(Self: TFIELD; const T: String); +begin Self.IMPORTEDCONSTRAINT := T; end; + +procedure TFIELDIMPORTEDCONSTRAINT_R(Self: TFIELD; var T: String); +begin T := Self.IMPORTEDCONSTRAINT; end; + +procedure TFIELDINDEX_W(Self: TFIELD; const T: INTEGER); +begin Self.INDEX := T; end; + +procedure TFIELDINDEX_R(Self: TFIELD; var T: INTEGER); +begin T := Self.INDEX; end; + +procedure TFIELDHASCONSTRAINTS_R(Self: TFIELD; var T: BOOLEAN); +begin T := Self.HASCONSTRAINTS; end; + +procedure TFIELDFIELDNAME_W(Self: TFIELD; const T: String); +begin Self.FIELDNAME := T; end; + +procedure TFIELDFIELDNAME_R(Self: TFIELD; var T: String); +begin T := Self.FIELDNAME; end; + +procedure TFIELDFIELDKIND_W(Self: TFIELD; const T: TFIELDKIND); +begin Self.FIELDKIND := T; end; + +procedure TFIELDFIELDKIND_R(Self: TFIELD; var T: TFIELDKIND); +begin T := Self.FIELDKIND; end; + +procedure TFIELDDISPLAYWIDTH_W(Self: TFIELD; const T: INTEGER); +begin Self.DISPLAYWIDTH := T; end; + +procedure TFIELDDISPLAYWIDTH_R(Self: TFIELD; var T: INTEGER); +begin T := Self.DISPLAYWIDTH; end; + +procedure TFIELDDISPLAYLABEL_W(Self: TFIELD; const T: String); +begin Self.DISPLAYLABEL := T; end; + +procedure TFIELDDISPLAYLABEL_R(Self: TFIELD; var T: String); +begin T := Self.DISPLAYLABEL; end; + +procedure TFIELDDEFAULTEXPRESSION_W(Self: TFIELD; const T: String); +begin Self.DEFAULTEXPRESSION := T; end; + +procedure TFIELDDEFAULTEXPRESSION_R(Self: TFIELD; var T: String); +begin T := Self.DEFAULTEXPRESSION; end; + +procedure TFIELDCONSTRAINTERRORMESSAGE_W(Self: TFIELD; const T: String); +begin Self.CONSTRAINTERRORMESSAGE := T; end; + +procedure TFIELDCONSTRAINTERRORMESSAGE_R(Self: TFIELD; var T: String); +begin T := Self.CONSTRAINTERRORMESSAGE; end; + +procedure TFIELDCUSTOMCONSTRAINT_W(Self: TFIELD; const T: String); +begin Self.CUSTOMCONSTRAINT := T; end; + +procedure TFIELDCUSTOMCONSTRAINT_R(Self: TFIELD; var T: String); +begin T := Self.CUSTOMCONSTRAINT; end; + +{$IFNDEF FPC} +procedure TFIELDAUTOGENERATEVALUE_W(Self: TFIELD; const T: TAUTOREFRESHFLAG); +begin Self.AUTOGENERATEVALUE := T; end; + +procedure TFIELDAUTOGENERATEVALUE_R(Self: TFIELD; var T: TAUTOREFRESHFLAG); +begin T := Self.AUTOGENERATEVALUE; end; + +procedure TFIELDVALIDCHARS_W(Self: TFIELD; const T: TFIELDCHARS); +begin Self.VALIDCHARS := T; end; + +procedure TFIELDVALIDCHARS_R(Self: TFIELD; var T: TFIELDCHARS); +begin T := Self.VALIDCHARS; end; + + +procedure TFIELDPARENTFIELD_W(Self: TFIELD; const T: TOBJECTFIELD); +begin Self.PARENTFIELD := T; end; + +procedure TFIELDPARENTFIELD_R(Self: TFIELD; var T: TOBJECTFIELD); +begin T := Self.PARENTFIELD; end; + + + +{$ENDIF} + +procedure TFIELDALIGNMENT_W(Self: TFIELD; const T: TALIGNMENT); +begin Self.ALIGNMENT := T; end; + +procedure TFIELDALIGNMENT_R(Self: TFIELD; var T: TALIGNMENT); +begin T := Self.ALIGNMENT; end; + +procedure TFIELDVALUE_W(Self: TFIELD; const T: VARIANT); +begin Self.VALUE := T; end; + +procedure TFIELDVALUE_R(Self: TFIELD; var T: VARIANT); +begin T := Self.VALUE; end; + +procedure TFIELDTEXT_W(Self: TFIELD; const T: String); +begin Self.TEXT := T; end; + +procedure TFIELDTEXT_R(Self: TFIELD; var T: String); +begin T := Self.TEXT; end; + +procedure TFIELDSIZE_W(Self: TFIELD; const T: INTEGER); +begin Self.SIZE := T; end; + +procedure TFIELDSIZE_R(Self: TFIELD; var T: INTEGER); +begin T := Self.SIZE; end; + +procedure TFIELDOLDVALUE_R(Self: TFIELD; var T: VARIANT); +begin T := Self.OLDVALUE; end; + +procedure TFIELDOFFSET_R(Self: TFIELD; var T: INTEGER); +begin T := Self.OFFSET; end; + +procedure TFIELDNEWVALUE_W(Self: TFIELD; const T: VARIANT); +begin Self.NEWVALUE := T; end; + +procedure TFIELDNEWVALUE_R(Self: TFIELD; var T: VARIANT); +begin T := Self.NEWVALUE; end; + +procedure TFIELDLOOKUPLIST_R(Self: TFIELD; var T: TLOOKUPLIST); +begin T := Self.LOOKUPLIST; end; + +{$IFNDEF FPC} +procedure TFIELDLOOKUP_W(Self: TFIELD; const T: BOOLEAN); +begin Self.LOOKUP := T; end; + +procedure TFIELDLOOKUP_R(Self: TFIELD; var T: BOOLEAN); +begin T := Self.LOOKUP; end; + +procedure TFIELDFULLNAME_R(Self: TFIELD; var T: String); +begin T := Self.FULLNAME; end; + + +procedure TFIELDEDITMASKPTR_R(Self: TFIELD; var T: String); +begin T := Self.EDITMASKPTR; end; + +procedure TFIELDEDITMASK_W(Self: TFIELD; const T: String); +begin Self.EDITMASK := T; end; + +procedure TFIELDEDITMASK_R(Self: TFIELD; var T: String); +begin T := Self.EDITMASK; end; + +{$ENDIF} + +procedure TFIELDISNULL_R(Self: TFIELD; var T: BOOLEAN); +begin T := Self.ISNULL; end; + +procedure TFIELDISINDEXFIELD_R(Self: TFIELD; var T: BOOLEAN); +begin T := Self.ISINDEXFIELD; end; + +procedure TFIELDFIELDNO_R(Self: TFIELD; var T: INTEGER); +begin T := Self.FIELDNO; end; + + + +procedure TFIELDDISPLAYTEXT_R(Self: TFIELD; var T: String); +begin T := Self.DISPLAYTEXT; end; + +procedure TFIELDDISPLAYNAME_R(Self: TFIELD; var T: String); +begin T := Self.DISPLAYNAME; end; + +procedure TFIELDDATATYPE_R(Self: TFIELD; var T: TFIELDTYPE); +begin T := Self.DATATYPE; end; + +procedure TFIELDDATASIZE_R(Self: TFIELD; var T: INTEGER); +begin T := Self.DATASIZE; end; + +procedure TFIELDDATASET_W(Self: TFIELD; const T: TDATASET); +begin Self.DATASET := T; end; + +procedure TFIELDDATASET_R(Self: TFIELD; var T: TDATASET); +begin T := Self.DATASET; end; + +procedure TFIELDCURVALUE_R(Self: TFIELD; var T: VARIANT); +begin T := Self.CURVALUE; end; + +procedure TFIELDCANMODIFY_R(Self: TFIELD; var T: BOOLEAN); +begin T := Self.CANMODIFY; end; + +procedure TFIELDCALCULATED_W(Self: TFIELD; const T: BOOLEAN); +begin Self.CALCULATED := T; end; + +procedure TFIELDCALCULATED_R(Self: TFIELD; var T: BOOLEAN); +begin T := Self.CALCULATED; end; + +procedure TFIELDATTRIBUTESET_W(Self: TFIELD; const T: String); +begin Self.ATTRIBUTESET := T; end; + +procedure TFIELDATTRIBUTESET_R(Self: TFIELD; var T: String); +begin T := Self.ATTRIBUTESET; end; + +procedure TFIELDASVARIANT_W(Self: TFIELD; const T: VARIANT); +begin Self.ASVARIANT := T; end; + +procedure TFIELDASVARIANT_R(Self: TFIELD; var T: VARIANT); +begin T := Self.ASVARIANT; end; + +procedure TFIELDASSTRING_W(Self: TFIELD; const T: String); +begin Self.ASSTRING := T; end; + +procedure TFIELDASSTRING_R(Self: TFIELD; var T: String); +begin T := Self.ASSTRING; end; + +procedure TFIELDASINTEGER_W(Self: TFIELD; const T: LONGINT); +begin Self.ASINTEGER := T; end; + +procedure TFIELDASINTEGER_R(Self: TFIELD; var T: LONGINT); +begin T := Self.ASINTEGER; end; + +procedure TFIELDASFLOAT_W(Self: TFIELD; const T: DOUBLE); +begin Self.ASFLOAT := T; end; + +procedure TFIELDASFLOAT_R(Self: TFIELD; var T: DOUBLE); +begin T := Self.ASFLOAT; end; + +procedure TFIELDASDATETIME_W(Self: TFIELD; const T: TDATETIME); +begin Self.ASDATETIME := T; end; + +procedure TFIELDASDATETIME_R(Self: TFIELD; var T: TDATETIME); +begin T := Self.ASDATETIME; end; + +procedure TFIELDASCURRENCY_W(Self: TFIELD; const T: CURRENCY); +begin Self.ASCURRENCY := T; end; + +procedure TFIELDASCURRENCY_R(Self: TFIELD; var T: CURRENCY); +begin T := Self.ASCURRENCY; end; + +procedure TFIELDASBOOLEAN_W(Self: TFIELD; const T: BOOLEAN); +begin Self.ASBOOLEAN := T; end; + +procedure TFIELDASBOOLEAN_R(Self: TFIELD; var T: BOOLEAN); +begin T := Self.ASBOOLEAN; end; + +{$IFNDEF FPC} +{$IFDEF DELPHI6UP} +procedure TFIELDASBCD_W(Self: TFIELD; const T: TBCD); +begin Self.ASBCD := T; end; + +procedure TFIELDASBCD_R(Self: TFIELD; var T: TBCD); +begin T := Self.ASBCD; end; +{$ENDIF} + +procedure TFIELDLISTFIELDS_R(Self: TFIELDLIST; var T: TFIELD; const t1: INTEGER); +begin T := Self.FIELDS[t1]; end; + +procedure TFIELDDEFLISTFIELDDEFS_R(Self: TFIELDDEFLIST; var T: TFIELDDEF; const t1: INTEGER); +begin T := Self.FIELDDEFS[t1]; end; + +procedure TFLATLISTDATASET_R(Self: TFLATLIST; var T: TDATASET); +begin T := Self.DATASET; end; + +procedure TINDEXDEFGROUPINGLEVEL_W(Self: TINDEXDEF; const T: INTEGER); +begin Self.GROUPINGLEVEL := T; end; + +procedure TINDEXDEFGROUPINGLEVEL_R(Self: TINDEXDEF; var T: INTEGER); +begin T := Self.GROUPINGLEVEL; end; + + + +{$ENDIF} + +procedure TFIELDSFIELDS_W(Self: TFIELDS; const T: TFIELD; const t1: INTEGER); +begin Self.FIELDS[t1] := T; end; + +procedure TFIELDSFIELDS_R(Self: TFIELDS; var T: TFIELD; const t1: INTEGER); +begin T := Self.FIELDS[t1]; end; + +procedure TFIELDSDATASET_R(Self: TFIELDS; var T: TDATASET); +begin T := Self.DATASET; end; + +procedure TFIELDSCOUNT_R(Self: TFIELDS; var T: INTEGER); +begin T := Self.COUNT; end; + +procedure TINDEXDEFSITEMS_W(Self: TINDEXDEFS; const T: TINDEXDEF; const t1: INTEGER); +begin Self.ITEMS[t1] := T; end; + +procedure TINDEXDEFSITEMS_R(Self: TINDEXDEFS; var T: TINDEXDEF; const t1: INTEGER); +begin T := Self.ITEMS[t1]; end; + +procedure TINDEXDEFSOURCE_W(Self: TINDEXDEF; const T: String); +begin Self.SOURCE := T; end; + +procedure TINDEXDEFSOURCE_R(Self: TINDEXDEF; var T: String); +begin T := Self.SOURCE; end; + +procedure TINDEXDEFOPTIONS_W(Self: TINDEXDEF; const T: TINDEXOPTIONS); +begin Self.OPTIONS := T; end; + +procedure TINDEXDEFOPTIONS_R(Self: TINDEXDEF; var T: TINDEXOPTIONS); +begin T := Self.OPTIONS; end; + +procedure TINDEXDEFFIELDS_W(Self: TINDEXDEF; const T: String); +begin Self.FIELDS := T; end; + +procedure TINDEXDEFFIELDS_R(Self: TINDEXDEF; var T: String); +begin T := Self.FIELDS; end; + +procedure TINDEXDEFEXPRESSION_W(Self: TINDEXDEF; const T: String); +begin {$IFNDEF FPC}Self.EXPRESSION := T; {$ENDIF}end; + +procedure TINDEXDEFEXPRESSION_R(Self: TINDEXDEF; var T: String); +begin T := Self.EXPRESSION; end; + +{$IFNDEF FPC} +procedure TINDEXDEFDESCFIELDS_W(Self: TINDEXDEF; const T: String); +begin Self.DESCFIELDS := T; end; + +procedure TINDEXDEFDESCFIELDS_R(Self: TINDEXDEF; var T: String); +begin T := Self.DESCFIELDS; end; + +procedure TINDEXDEFCASEINSFIELDS_W(Self: TINDEXDEF; const T: String); +begin Self.CASEINSFIELDS := T; end; + +procedure TINDEXDEFCASEINSFIELDS_R(Self: TINDEXDEF; var T: String); +begin T := Self.CASEINSFIELDS; end; + + +procedure TINDEXDEFFIELDEXPRESSION_R(Self: TINDEXDEF; var T: String); +begin T := Self.FIELDEXPRESSION; end; + +procedure TFIELDDEFSPARENTDEF_R(Self: TFIELDDEFS; var T: TFIELDDEF); +begin T := Self.PARENTDEF; end; + +{$ENDIF} + +procedure TFIELDDEFSITEMS_W(Self: TFIELDDEFS; const T: TFIELDDEF; const t1: INTEGER); +begin Self.ITEMS[t1] := T; end; + +procedure TFIELDDEFSITEMS_R(Self: TFIELDDEFS; var T: TFIELDDEF; const t1: INTEGER); +begin T := Self.ITEMS[t1]; end; + +procedure TFIELDDEFSHIDDENFIELDS_W(Self: TFIELDDEFS; const T: BOOLEAN); +begin Self.HIDDENFIELDS := T; end; + +procedure TFIELDDEFSHIDDENFIELDS_R(Self: TFIELDDEFS; var T: BOOLEAN); +begin T := Self.HIDDENFIELDS; end; + +procedure TFIELDDEFSIZE_W(Self: TFIELDDEF; const T: INTEGER); +begin Self.SIZE := T; end; + +procedure TFIELDDEFSIZE_R(Self: TFIELDDEF; var T: INTEGER); +begin T := Self.SIZE; end; + +procedure TFIELDDEFPRECISION_W(Self: TFIELDDEF; const T: INTEGER); +begin Self.PRECISION := T; end; + +procedure TFIELDDEFPRECISION_R(Self: TFIELDDEF; var T: INTEGER); +begin T := Self.PRECISION; end; + +procedure TFIELDDEFDATATYPE_W(Self: TFIELDDEF; const T: TFIELDTYPE); +begin Self.DATATYPE := T; end; + +procedure TFIELDDEFDATATYPE_R(Self: TFIELDDEF; var T: TFIELDTYPE); +begin T := Self.DATATYPE; end; + +{$IFNDEF FPC} +procedure TFIELDDEFCHILDDEFS_W(Self: TFIELDDEF; const T: TFIELDDEFS); +begin Self.CHILDDEFS := T; end; + +procedure TFIELDDEFCHILDDEFS_R(Self: TFIELDDEF; var T: TFIELDDEFS); +begin T := Self.CHILDDEFS; end; + +procedure TFIELDDEFREQUIRED_W(Self: TFIELDDEF; const T: BOOLEAN); +begin Self.REQUIRED := T;end; + +procedure TFIELDDEFPARENTDEF_R(Self: TFIELDDEF; var T: TFIELDDEF); +begin T := Self.PARENTDEF; end; + +{$ENDIF} + +procedure TFIELDDEFATTRIBUTES_W(Self: TFIELDDEF; const T: TFIELDATTRIBUTES); +begin Self.ATTRIBUTES := T; end; + +procedure TFIELDDEFATTRIBUTES_R(Self: TFIELDDEF; var T: TFIELDATTRIBUTES); +begin T := Self.ATTRIBUTES; end; + +procedure TFIELDDEFREQUIRED_R(Self: TFIELDDEF; var T: BOOLEAN); +begin T := Self.REQUIRED; end; + +procedure TFIELDDEFINTERNALCALCFIELD_W(Self: TFIELDDEF; const T: BOOLEAN); +begin Self.INTERNALCALCFIELD := T; end; + +procedure TFIELDDEFINTERNALCALCFIELD_R(Self: TFIELDDEF; var T: BOOLEAN); +begin T := Self.INTERNALCALCFIELD; end; + +{$IFNDEF FPC} +procedure TFIELDDEFFIELDNO_W(Self: TFIELDDEF; const T: INTEGER); +begin Self.FIELDNO := T; end; + +procedure TDEFCOLLECTIONUPDATED_W(Self: TDEFCOLLECTION; const T: BOOLEAN); +begin Self.UPDATED := T; end; + +procedure TDEFCOLLECTIONUPDATED_R(Self: TDEFCOLLECTION; var T: BOOLEAN); +begin T := Self.UPDATED; end; + +procedure TDEFCOLLECTIONDATASET_R(Self: TDEFCOLLECTION; var T: TDATASET); +begin T := Self.DATASET; end; + +procedure TNAMEDITEMNAME_W(Self: TNAMEDITEM; const T: String); +begin Self.NAME := T; end; + +procedure TNAMEDITEMNAME_R(Self: TNAMEDITEM; var T: String); +begin T := Self.NAME; end; + + +{$ENDIF} + +procedure TFIELDDEFFIELDNO_R(Self: TFIELDDEF; var T: INTEGER); +begin T := Self.FIELDNO; end; + +procedure TFIELDDEFFIELDCLASS_R(Self: TFIELDDEF; var T: TFIELDCLASS); +begin T := Self.FIELDCLASS; end; + +procedure RIRegisterTDATASET(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TDATASET) do + begin + RegisterMethod(@TDATASET.ACTIVEBUFFER, 'ACTIVEBUFFER'); + RegisterMethod(@TDATASET.APPEND, 'APPEND'); + RegisterMethod(@TDATASET.APPENDRECORD, 'APPENDRECORD'); +// RegisterVirtualMethod(@TDATASET.BOOKMARKVALID, 'BOOKMARKVALID'); + RegisterVirtualMethod(@TDATASET.CANCEL, 'CANCEL'); + RegisterMethod(@TDATASET.CHECKBROWSEMODE, 'CHECKBROWSEMODE'); + RegisterMethod(@TDATASET.CLEARFIELDS, 'CLEARFIELDS'); + RegisterMethod(@TDATASET.CLOSE, 'CLOSE'); + RegisterMethod(@TDATASET.CONTROLSDISABLED, 'CONTROLSDISABLED'); +// RegisterVirtualMethod(@TDATASET.COMPAREBOOKMARKS, 'COMPAREBOOKMARKS'); + RegisterVirtualMethod(@TDATASET.CREATEBLOBSTREAM, 'CREATEBLOBSTREAM'); + RegisterMethod(@TDATASET.CURSORPOSCHANGED, 'CURSORPOSCHANGED'); + RegisterMethod(@TDATASET.DELETE, 'DELETE'); + RegisterMethod(@TDATASET.DISABLECONTROLS, 'DISABLECONTROLS'); + RegisterMethod(@TDATASET.EDIT, 'EDIT'); + RegisterMethod(@TDATASET.ENABLECONTROLS, 'ENABLECONTROLS'); + RegisterMethod(@TDATASET.FIELDBYNAME, 'FIELDBYNAME'); + RegisterMethod(@TDATASET.FINDFIELD, 'FINDFIELD'); + RegisterMethod(@TDATASET.FINDFIRST, 'FINDFIRST'); + RegisterMethod(@TDATASET.FINDLAST, 'FINDLAST'); + RegisterMethod(@TDATASET.FINDNEXT, 'FINDNEXT'); + RegisterMethod(@TDATASET.FINDPRIOR, 'FINDPRIOR'); + RegisterMethod(@TDATASET.FIRST, 'FIRST'); +// RegisterVirtualMethod(@TDATASET.FREEBOOKMARK, 'FREEBOOKMARK'); +// RegisterVirtualMethod(@TDATASET.GETBOOKMARK, 'GETBOOKMARK'); + RegisterVirtualMethod(@TDATASET.GETCURRENTRECORD, 'GETCURRENTRECORD'); +// RegisterVirtualMethod(@TDATASET.GETDETAILDATASETS, 'GETDETAILDATASETS'); +// RegisterVirtualMethod(@TDATASET.GETDETAILLINKFIELDS, 'GETDETAILLINKFIELDS'); +// RegisterVirtualMethod(@TDATASET.GETBLOBFIELDDATA, 'GETBLOBFIELDDATA'); +// RegisterMethod(@TDATASET.GETFIELDLIST, 'GETFIELDLIST'); + RegisterMethod(@TDATASET.GETFIELDNAMES, 'GETFIELDNAMES'); +// RegisterMethod(@TDATASET.GOTOBOOKMARK, 'GOTOBOOKMARK'); + RegisterMethod(@TDATASET.INSERT, 'INSERT'); + RegisterMethod(@TDATASET.INSERTRECORD, 'INSERTRECORD'); + RegisterMethod(@TDATASET.ISEMPTY, 'ISEMPTY'); + RegisterMethod(@TDATASET.ISLINKEDTO, 'ISLINKEDTO'); + RegisterVirtualMethod(@TDATASET.ISSEQUENCED, 'ISSEQUENCED'); + RegisterMethod(@TDATASET.LAST, 'LAST'); + RegisterVirtualMethod(@TDATASET.LOCATE, 'LOCATE'); + RegisterVirtualMethod(@TDATASET.LOOKUP, 'LOOKUP'); + RegisterMethod(@TDATASET.MOVEBY, 'MOVEBY'); + RegisterMethod(@TDATASET.NEXT, 'NEXT'); + RegisterMethod(@TDATASET.OPEN, 'OPEN'); + RegisterVirtualMethod(@TDATASET.POST, 'POST'); + RegisterMethod(@TDATASET.PRIOR, 'PRIOR'); + RegisterMethod(@TDATASET.REFRESH, 'REFRESH'); +// RegisterVirtualMethod(@TDATASET.RESYNC, 'RESYNC'); + RegisterMethod(@TDATASET.SETFIELDS, 'SETFIELDS'); + RegisterVirtualMethod(@TDATASET.TRANSLATE, 'TRANSLATE'); + RegisterMethod(@TDATASET.UPDATECURSORPOS, 'UPDATECURSORPOS'); + RegisterMethod(@TDATASET.UPDATERECORD, 'UPDATERECORD'); + RegisterVirtualMethod(@TDATASET.UPDATESTATUS, 'UPDATESTATUS'); + RegisterPropertyHelper(@TDATASETBOF_R,nil,'BOF'); +// RegisterPropertyHelper(@TDATASETBOOKMARK_R,@TDATASETBOOKMARK_W,'BOOKMARK'); + RegisterPropertyHelper(@TDATASETCANMODIFY_R,nil,'CANMODIFY'); + RegisterPropertyHelper(@TDATASETDATASOURCE_R,nil,'DATASOURCE'); + RegisterPropertyHelper(@TDATASETDEFAULTFIELDS_R,nil,'DEFAULTFIELDS'); + RegisterPropertyHelper(@TDATASETEOF_R,nil,'EOF'); + RegisterPropertyHelper(@TDATASETFIELDCOUNT_R,nil,'FIELDCOUNT'); + RegisterPropertyHelper(@TDATASETFIELDS_R,nil,'FIELDS'); + RegisterPropertyHelper(@TDATASETFIELDVALUES_R,@TDATASETFIELDVALUES_W,'FIELDVALUES'); + RegisterPropertyHelper(@TDATASETFOUND_R,nil,'FOUND'); +{$IFDEF DELPHI6UP} + RegisterPropertyHelper(@TDATASETISUNIDIRECTIONAL_R,nil,'ISUNIDIRECTIONAL'); +{$ENDIF} + RegisterPropertyHelper(@TDATASETMODIFIED_R,nil,'MODIFIED'); + RegisterPropertyHelper(@TDATASETRECORDCOUNT_R,nil,'RECORDCOUNT'); + RegisterPropertyHelper(@TDATASETRECNO_R,@TDATASETRECNO_W,'RECNO'); + RegisterPropertyHelper(@TDATASETRECORDSIZE_R,nil,'RECORDSIZE'); + RegisterPropertyHelper(@TDATASETSTATE_R,nil,'STATE'); + RegisterPropertyHelper(@TDATASETFILTER_R,@TDATASETFILTER_W,'FILTER'); + RegisterPropertyHelper(@TDATASETFILTERED_R,@TDATASETFILTERED_W,'FILTERED'); + RegisterPropertyHelper(@TDATASETFILTEROPTIONS_R,@TDATASETFILTEROPTIONS_W,'FILTEROPTIONS'); + RegisterPropertyHelper(@TDATASETACTIVE_R,@TDATASETACTIVE_W,'ACTIVE'); + RegisterPropertyHelper(@TDATASETAUTOCALCFIELDS_R,@TDATASETAUTOCALCFIELDS_W,'AUTOCALCFIELDS'); + RegisterPropertyHelper(@TDATASETBEFOREOPEN_R,@TDATASETBEFOREOPEN_W,'BEFOREOPEN'); + RegisterPropertyHelper(@TDATASETAFTEROPEN_R,@TDATASETAFTEROPEN_W,'AFTEROPEN'); + RegisterPropertyHelper(@TDATASETBEFORECLOSE_R,@TDATASETBEFORECLOSE_W,'BEFORECLOSE'); + RegisterPropertyHelper(@TDATASETAFTERCLOSE_R,@TDATASETAFTERCLOSE_W,'AFTERCLOSE'); + RegisterPropertyHelper(@TDATASETBEFOREINSERT_R,@TDATASETBEFOREINSERT_W,'BEFOREINSERT'); + RegisterPropertyHelper(@TDATASETAFTERINSERT_R,@TDATASETAFTERINSERT_W,'AFTERINSERT'); + RegisterPropertyHelper(@TDATASETBEFOREEDIT_R,@TDATASETBEFOREEDIT_W,'BEFOREEDIT'); + RegisterPropertyHelper(@TDATASETAFTEREDIT_R,@TDATASETAFTEREDIT_W,'AFTEREDIT'); + RegisterPropertyHelper(@TDATASETBEFOREPOST_R,@TDATASETBEFOREPOST_W,'BEFOREPOST'); + RegisterPropertyHelper(@TDATASETAFTERPOST_R,@TDATASETAFTERPOST_W,'AFTERPOST'); + RegisterPropertyHelper(@TDATASETBEFORECANCEL_R,@TDATASETBEFORECANCEL_W,'BEFORECANCEL'); + RegisterPropertyHelper(@TDATASETAFTERCANCEL_R,@TDATASETAFTERCANCEL_W,'AFTERCANCEL'); + RegisterPropertyHelper(@TDATASETBEFOREDELETE_R,@TDATASETBEFOREDELETE_W,'BEFOREDELETE'); + RegisterPropertyHelper(@TDATASETAFTERDELETE_R,@TDATASETAFTERDELETE_W,'AFTERDELETE'); + RegisterPropertyHelper(@TDATASETBEFORESCROLL_R,@TDATASETBEFORESCROLL_W,'BEFORESCROLL'); + RegisterPropertyHelper(@TDATASETAFTERSCROLL_R,@TDATASETAFTERSCROLL_W,'AFTERSCROLL'); + {$IFNDEF FPC} + RegisterPropertyHelper(@TDATASETFIELDLIST_R,nil,'FIELDLIST'); + RegisterPropertyHelper(@TDATASETDESIGNER_R,nil,'DESIGNER'); + RegisterPropertyHelper(@TDATASETBLOCKREADSIZE_R,@TDATASETBLOCKREADSIZE_W,'BLOCKREADSIZE'); + RegisterPropertyHelper(@TDATASETBEFOREREFRESH_R,@TDATASETBEFOREREFRESH_W,'BEFOREREFRESH'); + RegisterPropertyHelper(@TDATASETAFTERREFRESH_R,@TDATASETAFTERREFRESH_W,'AFTERREFRESH'); + RegisterPropertyHelper(@TDATASETAGGFIELDS_R,nil,'AGGFIELDS'); + RegisterPropertyHelper(@TDATASETDATASETFIELD_R,@TDATASETDATASETFIELD_W,'DATASETFIELD'); + RegisterPropertyHelper(@TDATASETOBJECTVIEW_R,@TDATASETOBJECTVIEW_W,'OBJECTVIEW'); + RegisterPropertyHelper(@TDATASETSPARSEARRAYS_R,@TDATASETSPARSEARRAYS_W,'SPARSEARRAYS'); + RegisterPropertyHelper(@TDATASETFIELDDEFS_R,@TDATASETFIELDDEFS_W,'FIELDDEFS'); + RegisterPropertyHelper(@TDATASETFIELDDEFLIST_R,nil,'FIELDDEFLIST'); + + {$ENDIF} + RegisterEventPropertyHelper(@TDATASETONCALCFIELDS_R,@TDATASETONCALCFIELDS_W,'ONCALCFIELDS'); + RegisterEventPropertyHelper(@TDATASETONDELETEERROR_R,@TDATASETONDELETEERROR_W,'ONDELETEERROR'); + RegisterEventPropertyHelper(@TDATASETONEDITERROR_R,@TDATASETONEDITERROR_W,'ONEDITERROR'); + RegisterEventPropertyHelper(@TDATASETONFILTERRECORD_R,@TDATASETONFILTERRECORD_W,'ONFILTERRECORD'); + RegisterEventPropertyHelper(@TDATASETONNEWRECORD_R,@TDATASETONNEWRECORD_W,'ONNEWRECORD'); + RegisterEventPropertyHelper(@TDATASETONPOSTERROR_R,@TDATASETONPOSTERROR_W,'ONPOSTERROR'); + end; +end; + +procedure RIRegisterTPARAMS(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TPARAMS) do + begin +// RegisterMethod(@TPARAMS.ASSIGNVALUES, 'ASSIGNVALUES'); + RegisterMethod(@TPARAMS.ADDPARAM, 'ADDPARAM'); + RegisterMethod(@TPARAMS.REMOVEPARAM, 'REMOVEPARAM'); + RegisterMethod(@TPARAMS.CREATEPARAM, 'CREATEPARAM'); + RegisterMethod(@TPARAMS.GETPARAMLIST, 'GETPARAMLIST'); + RegisterMethod(@TPARAMS.ISEQUAL, 'ISEQUAL'); + RegisterMethod(@TPARAMS.PARSESQL, 'PARSESQL'); + RegisterMethod(@TPARAMS.PARAMBYNAME, 'PARAMBYNAME'); + RegisterMethod(@TPARAMS.FINDPARAM, 'FINDPARAM'); + RegisterPropertyHelper(@TPARAMSITEMS_R,@TPARAMSITEMS_W,'ITEMS'); + RegisterPropertyHelper(@TPARAMSPARAMVALUES_R,@TPARAMSPARAMVALUES_W,'PARAMVALUES'); + end; +end; + +procedure RIRegisterTPARAM(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TPARAM) do + begin + RegisterMethod(@TPARAM.ASSIGNFIELD, 'ASSIGNFIELD'); + RegisterMethod(@TPARAM.ASSIGNFIELDVALUE, 'ASSIGNFIELDVALUE'); + RegisterMethod(@TPARAM.CLEAR, 'CLEAR'); +// RegisterMethod(@TPARAM.GETDATA, 'GETDATA'); + RegisterMethod(@TPARAM.GETDATASIZE, 'GETDATASIZE'); + RegisterMethod(@TPARAM.LOADFROMFILE, 'LOADFROMFILE'); + RegisterMethod(@TPARAM.LOADFROMSTREAM, 'LOADFROMSTREAM'); +// RegisterMethod(@TPARAM.SETBLOBDATA, 'SETBLOBDATA'); +// RegisterMethod(@TPARAM.SETDATA, 'SETDATA'); + {$IFNDEF FPC} + RegisterPropertyHelper(@TPARAMASBCD_R,@TPARAMASBCD_W,'ASBCD'); +{$IFDEF DELPHI6UP} + RegisterPropertyHelper(@TPARAMASFMTBCD_R,@TPARAMASFMTBCD_W,'ASFMTBCD'); +{$ENDIF} + {$ENDIF} + RegisterPropertyHelper(@TPARAMASBLOB_R,@TPARAMASBLOB_W,'ASBLOB'); + RegisterPropertyHelper(@TPARAMASBOOLEAN_R,@TPARAMASBOOLEAN_W,'ASBOOLEAN'); + RegisterPropertyHelper(@TPARAMASCURRENCY_R,@TPARAMASCURRENCY_W,'ASCURRENCY'); + RegisterPropertyHelper(@TPARAMASDATE_R,@TPARAMASDATE_W,'ASDATE'); + RegisterPropertyHelper(@TPARAMASDATETIME_R,@TPARAMASDATETIME_W,'ASDATETIME'); + RegisterPropertyHelper(@TPARAMASFLOAT_R,@TPARAMASFLOAT_W,'ASFLOAT'); + RegisterPropertyHelper(@TPARAMASINTEGER_R,@TPARAMASINTEGER_W,'ASINTEGER'); + RegisterPropertyHelper(@TPARAMASSMALLINT_R,@TPARAMASSMALLINT_W,'ASSMALLINT'); + RegisterPropertyHelper(@TPARAMASMEMO_R,@TPARAMASMEMO_W,'ASMEMO'); + RegisterPropertyHelper(@TPARAMASSTRING_R,@TPARAMASSTRING_W,'ASSTRING'); + RegisterPropertyHelper(@TPARAMASTIME_R,@TPARAMASTIME_W,'ASTIME'); + RegisterPropertyHelper(@TPARAMASWORD_R,@TPARAMASWORD_W,'ASWORD'); + RegisterPropertyHelper(@TPARAMBOUND_R,@TPARAMBOUND_W,'BOUND'); + RegisterPropertyHelper(@TPARAMISNULL_R,nil,'ISNULL'); + RegisterPropertyHelper(@TPARAMNATIVESTR_R,@TPARAMNATIVESTR_W,'NATIVESTR'); + RegisterPropertyHelper(@TPARAMTEXT_R,@TPARAMTEXT_W,'TEXT'); + RegisterPropertyHelper(@TPARAMDATATYPE_R,@TPARAMDATATYPE_W,'DATATYPE'); +{$IFDEF DELPHI6UP} + RegisterPropertyHelper(@TPARAMPRECISION_R,@TPARAMPRECISION_W,'PRECISION'); + RegisterPropertyHelper(@TPARAMNUMERICSCALE_R,@TPARAMNUMERICSCALE_W,'NUMERICSCALE'); + RegisterPropertyHelper(@TPARAMSIZE_R,@TPARAMSIZE_W,'SIZE'); +{$ENDIF} + RegisterPropertyHelper(@TPARAMNAME_R,@TPARAMNAME_W,'NAME'); + RegisterPropertyHelper(@TPARAMPARAMTYPE_R,@TPARAMPARAMTYPE_W,'PARAMTYPE'); + RegisterPropertyHelper(@TPARAMVALUE_R,@TPARAMVALUE_W,'VALUE'); + end; +end; + +{$IFNDEF FPC} +procedure RIRegisterTGUIDFIELD(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TGUIDFIELD) do + begin + end; +end; + +procedure RIRegisterTVARIANTFIELD(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TVARIANTFIELD) do + begin + end; +end; + +procedure RIRegisterTREFERENCEFIELD(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TREFERENCEFIELD) do + begin + RegisterPropertyHelper(@TREFERENCEFIELDREFERENCETABLENAME_R,@TREFERENCEFIELDREFERENCETABLENAME_W,'REFERENCETABLENAME'); + end; +end; + + +procedure RIRegisterTDATASETFIELD(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TDATASETFIELD) do + begin + RegisterPropertyHelper(@TDATASETFIELDNESTEDDATASET_R,nil,'NESTEDDATASET'); + RegisterPropertyHelper(@TDATASETFIELDINCLUDEOBJECTFIELD_R,@TDATASETFIELDINCLUDEOBJECTFIELD_W,'INCLUDEOBJECTFIELD'); + end; +end; + + +procedure RIRegisterTARRAYFIELD(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TARRAYFIELD) do + begin + end; +end; + + +procedure RIRegisterTADTFIELD(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TADTFIELD) do + begin + end; +end; + + +procedure RIRegisterTOBJECTFIELD(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TOBJECTFIELD) do + begin + RegisterPropertyHelper(@TOBJECTFIELDFIELDCOUNT_R,nil,'FIELDCOUNT'); + RegisterPropertyHelper(@TOBJECTFIELDFIELDS_R,nil,'FIELDS'); + RegisterPropertyHelper(@TOBJECTFIELDFIELDVALUES_R,@TOBJECTFIELDFIELDVALUES_W,'FIELDVALUES'); + RegisterPropertyHelper(@TOBJECTFIELDUNNAMED_R,nil,'UNNAMED'); + RegisterPropertyHelper(@TOBJECTFIELDOBJECTTYPE_R,@TOBJECTFIELDOBJECTTYPE_W,'OBJECTTYPE'); + end; +end; +{$ENDIF} + + +procedure RIRegisterTGRAPHICFIELD(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TGRAPHICFIELD) do + begin + end; +end; + +procedure RIRegisterTMEMOFIELD(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TMEMOFIELD) do + begin + end; +end; + +procedure RIRegisterTBLOBFIELD(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TBLOBFIELD) do + begin + RegisterMethod(@TBLOBFIELD.LOADFROMFILE, 'LOADFROMFILE'); + RegisterMethod(@TBLOBFIELD.LOADFROMSTREAM, 'LOADFROMSTREAM'); + RegisterMethod(@TBLOBFIELD.SAVETOFILE, 'SAVETOFILE'); + RegisterMethod(@TBLOBFIELD.SAVETOSTREAM, 'SAVETOSTREAM'); + RegisterPropertyHelper(@TBLOBFIELDBLOBSIZE_R,nil,'BLOBSIZE'); + RegisterPropertyHelper(@TBLOBFIELDMODIFIED_R,@TBLOBFIELDMODIFIED_W,'MODIFIED'); + RegisterPropertyHelper(@TBLOBFIELDVALUE_R,@TBLOBFIELDVALUE_W,'VALUE'); + RegisterPropertyHelper(@TBLOBFIELDTRANSLITERATE_R,@TBLOBFIELDTRANSLITERATE_W,'TRANSLITERATE'); + RegisterPropertyHelper(@TBLOBFIELDBLOBTYPE_R,@TBLOBFIELDBLOBTYPE_W,'BLOBTYPE'); +{$IFNDEF FPC} +{$IFDEF DELPHI6UP} + RegisterPropertyHelper(@TBLOBFIELDGRAPHICHEADER_R,@TBLOBFIELDGRAPHICHEADER_W,'GRAPHICHEADER'); +{$ENDIF} +{$ENDIF} + end; +end; + + +{$IFNDEF FPC} +{$IFDEF DELPHI6UP} + +procedure RIRegisterTFMTBCDFIELD(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TFMTBCDFIELD) do + begin + RegisterPropertyHelper(@TFMTBCDFIELDVALUE_R,@TFMTBCDFIELDVALUE_W,'VALUE'); + RegisterPropertyHelper(@TFMTBCDFIELDCURRENCY_R,@TFMTBCDFIELDCURRENCY_W,'CURRENCY'); + RegisterPropertyHelper(@TFMTBCDFIELDMAXVALUE_R,@TFMTBCDFIELDMAXVALUE_W,'MAXVALUE'); + RegisterPropertyHelper(@TFMTBCDFIELDMINVALUE_R,@TFMTBCDFIELDMINVALUE_W,'MINVALUE'); + RegisterPropertyHelper(@TFMTBCDFIELDPRECISION_R,@TFMTBCDFIELDPRECISION_W,'PRECISION'); + end; +end; +{$ENDIF} +procedure RIRegisterTBCDFIELD(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TBCDFIELD) do + begin + RegisterPropertyHelper(@TBCDFIELDVALUE_R,@TBCDFIELDVALUE_W,'VALUE'); + RegisterPropertyHelper(@TBCDFIELDCURRENCY_R,@TBCDFIELDCURRENCY_W,'CURRENCY'); + RegisterPropertyHelper(@TBCDFIELDMAXVALUE_R,@TBCDFIELDMAXVALUE_W,'MAXVALUE'); + RegisterPropertyHelper(@TBCDFIELDMINVALUE_R,@TBCDFIELDMINVALUE_W,'MINVALUE'); + RegisterPropertyHelper(@TBCDFIELDPRECISION_R,@TBCDFIELDPRECISION_W,'PRECISION'); + end; +end; +{$ENDIF} + +procedure RIRegisterTVARBYTESFIELD(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TVARBYTESFIELD) do + begin + end; +end; + +procedure RIRegisterTBYTESFIELD(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TBYTESFIELD) do + begin + end; +end; + +procedure RIRegisterTBINARYFIELD(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TBINARYFIELD) do + begin + end; +end; + +procedure RIRegisterTTIMEFIELD(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TTIMEFIELD) do + begin + end; +end; + +procedure RIRegisterTDATEFIELD(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TDATEFIELD) do + begin + end; +end; + +procedure RIRegisterTDATETIMEFIELD(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TDATETIMEFIELD) do + begin + RegisterPropertyHelper(@TDATETIMEFIELDVALUE_R,@TDATETIMEFIELDVALUE_W,'VALUE'); + RegisterPropertyHelper(@TDATETIMEFIELDDISPLAYFORMAT_R,@TDATETIMEFIELDDISPLAYFORMAT_W,'DISPLAYFORMAT'); + end; +end; + +procedure RIRegisterTBOOLEANFIELD(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TBOOLEANFIELD) do + begin + RegisterPropertyHelper(@TBOOLEANFIELDVALUE_R,@TBOOLEANFIELDVALUE_W,'VALUE'); + RegisterPropertyHelper(@TBOOLEANFIELDDISPLAYVALUES_R,@TBOOLEANFIELDDISPLAYVALUES_W,'DISPLAYVALUES'); + end; +end; + +procedure RIRegisterTCURRENCYFIELD(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TCURRENCYFIELD) do + begin + end; +end; + +procedure RIRegisterTFLOATFIELD(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TFLOATFIELD) do + begin + {$IFNDEF FPC} + RegisterPropertyHelper(@TFLOATFIELDCURRENCY_R,@TFLOATFIELDCURRENCY_W,'CURRENCY'); + {$ENDIF} + RegisterPropertyHelper(@TFLOATFIELDVALUE_R,@TFLOATFIELDVALUE_W,'VALUE'); + RegisterPropertyHelper(@TFLOATFIELDMAXVALUE_R,@TFLOATFIELDMAXVALUE_W,'MAXVALUE'); + RegisterPropertyHelper(@TFLOATFIELDMINVALUE_R,@TFLOATFIELDMINVALUE_W,'MINVALUE'); + RegisterPropertyHelper(@TFLOATFIELDPRECISION_R,@TFLOATFIELDPRECISION_W,'PRECISION'); + end; +end; + +procedure RIRegisterTAUTOINCFIELD(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TAUTOINCFIELD) do + begin + end; +end; + +procedure RIRegisterTWORDFIELD(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TWORDFIELD) do + begin + end; +end; + +procedure RIRegisterTLARGEINTFIELD(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TLARGEINTFIELD) do + begin + RegisterPropertyHelper(@TLARGEINTFIELDASLARGEINT_R,@TLARGEINTFIELDASLARGEINT_W,'ASLARGEINT'); + RegisterPropertyHelper(@TLARGEINTFIELDVALUE_R,@TLARGEINTFIELDVALUE_W,'VALUE'); + RegisterPropertyHelper(@TLARGEINTFIELDMAXVALUE_R,@TLARGEINTFIELDMAXVALUE_W,'MAXVALUE'); + RegisterPropertyHelper(@TLARGEINTFIELDMINVALUE_R,@TLARGEINTFIELDMINVALUE_W,'MINVALUE'); + end; +end; + +procedure RIRegisterTSMALLINTFIELD(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TSMALLINTFIELD) do + begin + end; +end; + +procedure RIRegisterTINTEGERFIELD(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TINTEGERFIELD) do + begin + RegisterPropertyHelper(@TINTEGERFIELDVALUE_R,@TINTEGERFIELDVALUE_W,'VALUE'); + RegisterPropertyHelper(@TINTEGERFIELDMAXVALUE_R,@TINTEGERFIELDMAXVALUE_W,'MAXVALUE'); + RegisterPropertyHelper(@TINTEGERFIELDMINVALUE_R,@TINTEGERFIELDMINVALUE_W,'MINVALUE'); + end; +end; + +procedure RIRegisterTNUMERICFIELD(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TNUMERICFIELD) do + begin + RegisterPropertyHelper(@TNUMERICFIELDDISPLAYFORMAT_R,@TNUMERICFIELDDISPLAYFORMAT_W,'DISPLAYFORMAT'); + RegisterPropertyHelper(@TNUMERICFIELDEDITFORMAT_R,@TNUMERICFIELDEDITFORMAT_W,'EDITFORMAT'); + end; +end; + +{$IFNDEF FPC} +procedure RIRegisterTWIDESTRINGFIELD(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TWIDESTRINGFIELD) do + begin + RegisterPropertyHelper(@TWIDESTRINGFIELDVALUE_R,@TWIDESTRINGFIELDVALUE_W,'VALUE'); + end; +end; +{$ENDIF} + +procedure RIRegisterTSTRINGFIELD(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TSTRINGFIELD) do + begin + RegisterPropertyHelper(@TSTRINGFIELDVALUE_R,@TSTRINGFIELDVALUE_W,'VALUE'); + {$IFNDEF FPC} + RegisterPropertyHelper(@TSTRINGFIELDFIXEDCHAR_R,@TSTRINGFIELDFIXEDCHAR_W,'FIXEDCHAR'); + RegisterPropertyHelper(@TSTRINGFIELDTRANSLITERATE_R,@TSTRINGFIELDTRANSLITERATE_W,'TRANSLITERATE'); + {$ENDIF} + end; +end; + +procedure RIRegisterTFIELD(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TFIELD) do + begin + RegisterMethod(@TFIELD.ASSIGNVALUE, 'ASSIGNVALUE'); + RegisterVirtualMethod(@TFIELD.CLEAR, 'CLEAR'); + RegisterMethod(@TFIELD.FOCUSCONTROL, 'FOCUSCONTROL'); +// RegisterMethod(@TFIELD.GETDATA, 'GETDATA'); + RegisterVirtualMethod(@TFIELD.ISVALIDCHAR, 'ISVALIDCHAR'); + RegisterMethod(@TFIELD.REFRESHLOOKUPLIST, 'REFRESHLOOKUPLIST'); +// RegisterMethod(@TFIELD.SETDATA, 'SETDATA'); + RegisterVirtualMethod(@TFIELD.SETFIELDTYPE, 'SETFIELDTYPE'); +// RegisterMethod(@TFIELD.VALIDATE, 'VALIDATE'); +{$IFNDEF FPC} + + RegisterPropertyHelper(@TFIELDEDITMASK_R,@TFIELDEDITMASK_W,'EDITMASK'); + RegisterPropertyHelper(@TFIELDEDITMASKPTR_R,nil,'EDITMASKPTR'); + RegisterPropertyHelper(@TFIELDEDITMASK_R,@TFIELDEDITMASK_W,'EDITMASK'); + RegisterPropertyHelper(@TFIELDEDITMASKPTR_R,nil,'EDITMASKPTR'); + RegisterPropertyHelper(@TFIELDFULLNAME_R,nil,'FULLNAME'); + RegisterPropertyHelper(@TFIELDLOOKUP_R,@TFIELDLOOKUP_W,'LOOKUP'); + RegisterPropertyHelper(@TFIELDPARENTFIELD_R,@TFIELDPARENTFIELD_W,'PARENTFIELD'); + RegisterPropertyHelper(@TFIELDVALIDCHARS_R,@TFIELDVALIDCHARS_W,'VALIDCHARS'); + RegisterPropertyHelper(@TFIELDAUTOGENERATEVALUE_R,@TFIELDAUTOGENERATEVALUE_W,'AUTOGENERATEVALUE'); + +{$IFDEF DELPHI6UP} + RegisterPropertyHelper(@TFIELDASBCD_R,@TFIELDASBCD_W,'ASBCD'); +{$ENDIF} +{$ENDIF} + RegisterPropertyHelper(@TFIELDASBOOLEAN_R,@TFIELDASBOOLEAN_W,'ASBOOLEAN'); + RegisterPropertyHelper(@TFIELDASCURRENCY_R,@TFIELDASCURRENCY_W,'ASCURRENCY'); + RegisterPropertyHelper(@TFIELDASDATETIME_R,@TFIELDASDATETIME_W,'ASDATETIME'); + RegisterPropertyHelper(@TFIELDASFLOAT_R,@TFIELDASFLOAT_W,'ASFLOAT'); + RegisterPropertyHelper(@TFIELDASINTEGER_R,@TFIELDASINTEGER_W,'ASINTEGER'); + RegisterPropertyHelper(@TFIELDASSTRING_R,@TFIELDASSTRING_W,'ASSTRING'); + RegisterPropertyHelper(@TFIELDASVARIANT_R,@TFIELDASVARIANT_W,'ASVARIANT'); + RegisterPropertyHelper(@TFIELDATTRIBUTESET_R,@TFIELDATTRIBUTESET_W,'ATTRIBUTESET'); + RegisterPropertyHelper(@TFIELDCALCULATED_R,@TFIELDCALCULATED_W,'CALCULATED'); + RegisterPropertyHelper(@TFIELDCANMODIFY_R,nil,'CANMODIFY'); + RegisterPropertyHelper(@TFIELDCURVALUE_R,nil,'CURVALUE'); + RegisterPropertyHelper(@TFIELDDATASET_R,@TFIELDDATASET_W,'DATASET'); + RegisterPropertyHelper(@TFIELDDATASIZE_R,nil,'DATASIZE'); + RegisterPropertyHelper(@TFIELDDATATYPE_R,nil,'DATATYPE'); + RegisterPropertyHelper(@TFIELDDISPLAYNAME_R,nil,'DISPLAYNAME'); + RegisterPropertyHelper(@TFIELDDISPLAYTEXT_R,nil,'DISPLAYTEXT'); + RegisterPropertyHelper(@TFIELDFIELDNO_R,nil,'FIELDNO'); + RegisterPropertyHelper(@TFIELDISINDEXFIELD_R,nil,'ISINDEXFIELD'); + RegisterPropertyHelper(@TFIELDISNULL_R,nil,'ISNULL'); + RegisterPropertyHelper(@TFIELDLOOKUPLIST_R,nil,'LOOKUPLIST'); + RegisterPropertyHelper(@TFIELDNEWVALUE_R,@TFIELDNEWVALUE_W,'NEWVALUE'); + RegisterPropertyHelper(@TFIELDOFFSET_R,nil,'OFFSET'); + RegisterPropertyHelper(@TFIELDOLDVALUE_R,nil,'OLDVALUE'); + RegisterPropertyHelper(@TFIELDSIZE_R,@TFIELDSIZE_W,'SIZE'); + RegisterPropertyHelper(@TFIELDTEXT_R,@TFIELDTEXT_W,'TEXT'); + RegisterPropertyHelper(@TFIELDVALUE_R,@TFIELDVALUE_W,'VALUE'); + RegisterPropertyHelper(@TFIELDALIGNMENT_R,@TFIELDALIGNMENT_W,'ALIGNMENT'); + RegisterPropertyHelper(@TFIELDCUSTOMCONSTRAINT_R,@TFIELDCUSTOMCONSTRAINT_W,'CUSTOMCONSTRAINT'); + RegisterPropertyHelper(@TFIELDCONSTRAINTERRORMESSAGE_R,@TFIELDCONSTRAINTERRORMESSAGE_W,'CONSTRAINTERRORMESSAGE'); + RegisterPropertyHelper(@TFIELDDEFAULTEXPRESSION_R,@TFIELDDEFAULTEXPRESSION_W,'DEFAULTEXPRESSION'); + RegisterPropertyHelper(@TFIELDDISPLAYLABEL_R,@TFIELDDISPLAYLABEL_W,'DISPLAYLABEL'); + RegisterPropertyHelper(@TFIELDDISPLAYWIDTH_R,@TFIELDDISPLAYWIDTH_W,'DISPLAYWIDTH'); + RegisterPropertyHelper(@TFIELDFIELDKIND_R,@TFIELDFIELDKIND_W,'FIELDKIND'); + RegisterPropertyHelper(@TFIELDFIELDNAME_R,@TFIELDFIELDNAME_W,'FIELDNAME'); + RegisterPropertyHelper(@TFIELDHASCONSTRAINTS_R,nil,'HASCONSTRAINTS'); + RegisterPropertyHelper(@TFIELDINDEX_R,@TFIELDINDEX_W,'INDEX'); + RegisterPropertyHelper(@TFIELDIMPORTEDCONSTRAINT_R,@TFIELDIMPORTEDCONSTRAINT_W,'IMPORTEDCONSTRAINT'); + RegisterPropertyHelper(@TFIELDLOOKUPDATASET_R,@TFIELDLOOKUPDATASET_W,'LOOKUPDATASET'); + RegisterPropertyHelper(@TFIELDLOOKUPKEYFIELDS_R,@TFIELDLOOKUPKEYFIELDS_W,'LOOKUPKEYFIELDS'); + RegisterPropertyHelper(@TFIELDLOOKUPRESULTFIELD_R,@TFIELDLOOKUPRESULTFIELD_W,'LOOKUPRESULTFIELD'); + RegisterPropertyHelper(@TFIELDKEYFIELDS_R,@TFIELDKEYFIELDS_W,'KEYFIELDS'); + RegisterPropertyHelper(@TFIELDLOOKUPCACHE_R,@TFIELDLOOKUPCACHE_W,'LOOKUPCACHE'); + RegisterPropertyHelper(@TFIELDORIGIN_R,@TFIELDORIGIN_W,'ORIGIN'); + RegisterPropertyHelper(@TFIELDPROVIDERFLAGS_R,@TFIELDPROVIDERFLAGS_W,'PROVIDERFLAGS'); + RegisterPropertyHelper(@TFIELDREADONLY_R,@TFIELDREADONLY_W,'READONLY'); + RegisterPropertyHelper(@TFIELDREQUIRED_R,@TFIELDREQUIRED_W,'REQUIRED'); + RegisterPropertyHelper(@TFIELDVISIBLE_R,@TFIELDVISIBLE_W,'VISIBLE'); + RegisterEventPropertyHelper(@TFIELDONCHANGE_R,@TFIELDONCHANGE_W,'ONCHANGE'); + RegisterEventPropertyHelper(@TFIELDONGETTEXT_R,@TFIELDONGETTEXT_W,'ONGETTEXT'); + RegisterEventPropertyHelper(@TFIELDONSETTEXT_R,@TFIELDONSETTEXT_W,'ONSETTEXT'); + RegisterEventPropertyHelper(@TFIELDONVALIDATE_R,@TFIELDONVALIDATE_W,'ONVALIDATE'); + end; +end; + +procedure RIRegisterTLOOKUPLIST(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TLOOKUPLIST) do + begin + RegisterConstructor(@TLOOKUPLIST.CREATE, 'CREATE'); + {$IFDEF DELPHI2009UP} + RegisterVirtualAbstractMethod(TDefaultLookupList, @TDefaultLookupList.ADD, 'ADD'); + RegisterVirtualAbstractMethod(TDefaultLookupList, @TDefaultLookupList.CLEAR, 'CLEAR'); + RegisterVirtualAbstractMethod(TDefaultLookupList, @TDefaultLookupList.VALUEOFKEY, 'VALUEOFKEY'); + {$ELSE} + RegisterMethod(@TLOOKUPLIST.ADD, 'ADD'); + RegisterMethod(@TLOOKUPLIST.CLEAR, 'CLEAR'); + RegisterMethod(@TLOOKUPLIST.VALUEOFKEY, 'VALUEOFKEY'); + {$ENDIF} + end; +end; + +procedure RIRegisterTFIELDS(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TFIELDS) do + begin + RegisterConstructor(@TFIELDS.CREATE, 'CREATE'); + RegisterMethod(@TFIELDS.ADD, 'ADD'); + RegisterMethod(@TFIELDS.CHECKFIELDNAME, 'CHECKFIELDNAME'); + RegisterMethod(@TFIELDS.CHECKFIELDNAMES, 'CHECKFIELDNAMES'); + RegisterMethod(@TFIELDS.CLEAR, 'CLEAR'); + RegisterMethod(@TFIELDS.FINDFIELD, 'FINDFIELD'); + RegisterMethod(@TFIELDS.FIELDBYNAME, 'FIELDBYNAME'); + RegisterMethod(@TFIELDS.FIELDBYNUMBER, 'FIELDBYNUMBER'); + RegisterMethod(@TFIELDS.GETFIELDNAMES, 'GETFIELDNAMES'); + RegisterMethod(@TFIELDS.INDEXOF, 'INDEXOF'); + RegisterMethod(@TFIELDS.REMOVE, 'REMOVE'); + RegisterPropertyHelper(@TFIELDSCOUNT_R,nil,'COUNT'); + RegisterPropertyHelper(@TFIELDSDATASET_R,nil,'DATASET'); + RegisterPropertyHelper(@TFIELDSFIELDS_R,@TFIELDSFIELDS_W,'FIELDS'); + end; +end; + +{$IFNDEF FPC} +procedure RIRegisterTFIELDLIST(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TFIELDLIST) do + begin + RegisterMethod(@TFIELDLIST.FIELDBYNAME, 'FIELDBYNAME'); + RegisterMethod(@TFIELDLIST.FIND, 'FIND'); + RegisterPropertyHelper(@TFIELDLISTFIELDS_R,nil,'FIELDS'); + end; +end; + +procedure RIRegisterTFIELDDEFLIST(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TFIELDDEFLIST) do + begin + RegisterMethod(@TFIELDDEFLIST.FIELDBYNAME, 'FIELDBYNAME'); + RegisterMethod(@TFIELDDEFLIST.FIND, 'FIND'); + RegisterPropertyHelper(@TFIELDDEFLISTFIELDDEFS_R,nil,'FIELDDEFS'); + end; +end; + + +procedure RIRegisterTFLATLIST(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TFLATLIST) do + begin + RegisterConstructor(@TFLATLIST.CREATE, 'CREATE'); + RegisterMethod(@TFLATLIST.UPDATE, 'UPDATE'); + RegisterPropertyHelper(@TFLATLISTDATASET_R,nil,'DATASET'); + end; +end; +{$ENDIF} + + +procedure RIRegisterTINDEXDEFS(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TINDEXDEFS) do + begin + RegisterConstructor(@TINDEXDEFS.CREATE, 'CREATE'); + RegisterMethod(@TINDEXDEFS.ADDINDEXDEF, 'ADDINDEXDEF'); + RegisterMethod(@TINDEXDEFS.FIND, 'FIND'); + RegisterMethod(@TINDEXDEFS.UPDATE, 'UPDATE'); + RegisterMethod(@TINDEXDEFS.FINDINDEXFORFIELDS, 'FINDINDEXFORFIELDS'); + RegisterMethod(@TINDEXDEFS.GETINDEXFORFIELDS, 'GETINDEXFORFIELDS'); + RegisterMethod(@TINDEXDEFS.ADD, 'ADD'); + RegisterPropertyHelper(@TINDEXDEFSITEMS_R,@TINDEXDEFSITEMS_W,'ITEMS'); + end; +end; + +procedure RIRegisterTINDEXDEF(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TINDEXDEF) do + begin + RegisterConstructor(@TINDEXDEF.CREATE, 'CREATE'); +{$IFNDEF FPC} + RegisterPropertyHelper(@TINDEXDEFFIELDEXPRESSION_R,nil,'FIELDEXPRESSION'); + RegisterPropertyHelper(@TINDEXDEFCASEINSFIELDS_R,@TINDEXDEFCASEINSFIELDS_W,'CASEINSFIELDS'); + RegisterPropertyHelper(@TINDEXDEFGROUPINGLEVEL_R,@TINDEXDEFGROUPINGLEVEL_W,'GROUPINGLEVEL'); + RegisterPropertyHelper(@TINDEXDEFDESCFIELDS_R,@TINDEXDEFDESCFIELDS_W,'DESCFIELDS'); + +{$ENDIF} + RegisterPropertyHelper(@TINDEXDEFEXPRESSION_R,@TINDEXDEFEXPRESSION_W,'EXPRESSION'); + RegisterPropertyHelper(@TINDEXDEFFIELDS_R,@TINDEXDEFFIELDS_W,'FIELDS'); + RegisterPropertyHelper(@TINDEXDEFOPTIONS_R,@TINDEXDEFOPTIONS_W,'OPTIONS'); + RegisterPropertyHelper(@TINDEXDEFSOURCE_R,@TINDEXDEFSOURCE_W,'SOURCE'); + end; +end; + +procedure RIRegisterTFIELDDEFS(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TFIELDDEFS) do + begin + RegisterConstructor(@TFIELDDEFS.CREATE, 'CREATE'); + RegisterMethod(@TFIELDDEFS.ADDFIELDDEF, 'ADDFIELDDEF'); + RegisterMethod(@TFIELDDEFS.FIND, 'FIND'); + RegisterMethod(@TFIELDDEFS.UPDATE, 'UPDATE'); +{$IFNDEF FPC} + RegisterMethod(@TFIELDDEFS.ADD, 'ADD'); + RegisterPropertyHelper(@TFIELDDEFSPARENTDEF_R,nil,'PARENTDEF'); + +{$ENDIF} + RegisterPropertyHelper(@TFIELDDEFSHIDDENFIELDS_R,@TFIELDDEFSHIDDENFIELDS_W,'HIDDENFIELDS'); + RegisterPropertyHelper(@TFIELDDEFSITEMS_R,@TFIELDDEFSITEMS_W,'ITEMS'); + end; +end; + +procedure RIRegisterTFIELDDEF(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TFIELDDEF) do + begin +// RegisterConstructor(@TFIELDDEF.CREATE, 'CREATE'); +{$IFNDEF FPC} + RegisterMethod(@TFIELDDEF.ADDCHILD, 'ADDCHILD'); + RegisterMethod(@TFIELDDEF.HASCHILDDEFS, 'HASCHILDDEFS'); + +{$ENDIF} + RegisterMethod(@TFIELDDEF.CREATEFIELD, 'CREATEFIELD'); +{$IFNDEF FPC} + RegisterPropertyHelper(@TFIELDDEFFIELDNO_R,@TFIELDDEFFIELDNO_W,'FIELDNO'); + RegisterPropertyHelper(@TFIELDDEFPARENTDEF_R,nil,'PARENTDEF'); + RegisterPropertyHelper(@TFIELDDEFCHILDDEFS_R,@TFIELDDEFCHILDDEFS_W,'CHILDDEFS'); + RegisterPropertyHelper(@TFIELDDEFREQUIRED_R,@TFIELDDEFREQUIRED_W,'REQUIRED'); + +{$ENDIF} + RegisterPropertyHelper(@TFIELDDEFFIELDCLASS_R,nil,'FIELDCLASS'); + RegisterPropertyHelper(@TFIELDDEFINTERNALCALCFIELD_R,@TFIELDDEFINTERNALCALCFIELD_W,'INTERNALCALCFIELD'); + RegisterPropertyHelper(@TFIELDDEFATTRIBUTES_R,@TFIELDDEFATTRIBUTES_W,'ATTRIBUTES'); + RegisterPropertyHelper(@TFIELDDEFDATATYPE_R,@TFIELDDEFDATATYPE_W,'DATATYPE'); + RegisterPropertyHelper(@TFIELDDEFPRECISION_R,@TFIELDDEFPRECISION_W,'PRECISION'); + RegisterPropertyHelper(@TFIELDDEFSIZE_R,@TFIELDDEFSIZE_W,'SIZE'); + end; +end; + +{$IFNDEF FPC} +procedure RIRegisterTDEFCOLLECTION(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TDEFCOLLECTION) do + begin + RegisterConstructor(@TDEFCOLLECTION.CREATE, 'CREATE'); + RegisterMethod(@TDEFCOLLECTION.FIND, 'FIND'); + RegisterMethod(@TDEFCOLLECTION.GETITEMNAMES, 'GETITEMNAMES'); + RegisterMethod(@TDEFCOLLECTION.INDEXOF, 'INDEXOF'); + RegisterPropertyHelper(@TDEFCOLLECTIONDATASET_R,nil,'DATASET'); + RegisterPropertyHelper(@TDEFCOLLECTIONUPDATED_R,@TDEFCOLLECTIONUPDATED_W,'UPDATED'); + end; +end; + +procedure RIRegisterTNAMEDITEM(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TNAMEDITEM) do + begin + RegisterPropertyHelper(@TNAMEDITEMNAME_R,@TNAMEDITEMNAME_W,'NAME'); + end; +end; +{$ENDIF} + + +procedure RIRegister_DB(CL: TPSRuntimeClassImporter); +Begin +RIRegisterTFIELDDEF(Cl); +RIRegisterTFIELDDEFS(Cl); +RIRegisterTINDEXDEF(Cl); +RIRegisterTINDEXDEFS(Cl); +RIRegisterTFIELDS(Cl); +RIRegisterTLOOKUPLIST(Cl); +RIRegisterTFIELD(Cl); +RIRegisterTSTRINGFIELD(Cl); +RIRegisterTNUMERICFIELD(Cl); +RIRegisterTINTEGERFIELD(Cl); +RIRegisterTSMALLINTFIELD(Cl); +RIRegisterTLARGEINTFIELD(Cl); +RIRegisterTWORDFIELD(Cl); +RIRegisterTAUTOINCFIELD(Cl); +RIRegisterTFLOATFIELD(Cl); +RIRegisterTCURRENCYFIELD(Cl); +RIRegisterTBOOLEANFIELD(Cl); +RIRegisterTDATETIMEFIELD(Cl); +RIRegisterTDATEFIELD(Cl); +RIRegisterTTIMEFIELD(Cl); +RIRegisterTBINARYFIELD(Cl); +RIRegisterTBYTESFIELD(Cl); +RIRegisterTVARBYTESFIELD(Cl); +{$IFNDEF FPC} +RIRegisterTNAMEDITEM(Cl); +RIRegisterTDEFCOLLECTION(Cl); +RIRegisterTWIDESTRINGFIELD(Cl); +RIRegisterTFLATLIST(Cl); +RIRegisterTFIELDDEFLIST(Cl); +RIRegisterTFIELDLIST(Cl); +RIRegisterTBCDFIELD(Cl); +{$IFDEF DELPHI6UP} +RIRegisterTFMTBCDFIELD(Cl); +{$ENDIF} +{$ENDIF} + +RIRegisterTBLOBFIELD(Cl); +RIRegisterTMEMOFIELD(Cl); +RIRegisterTGRAPHICFIELD(Cl); +{$IFNDEF FPC} +RIRegisterTOBJECTFIELD(Cl); +RIRegisterTADTFIELD(Cl); +RIRegisterTARRAYFIELD(Cl); +RIRegisterTDATASETFIELD(Cl); +RIRegisterTREFERENCEFIELD(Cl); +RIRegisterTVARIANTFIELD(Cl); +RIRegisterTGUIDFIELD(Cl); +{$ENDIF} +RIRegisterTPARAM(Cl); +RIRegisterTPARAMS(Cl); +RIRegisterTDATASET(Cl); +end; + +{$IFDEF USEIMPORTER} +initialization +RIImporter.Invoke(RIRegister_DB); +{$ENDIF} +end. diff --git a/Units/PascalScript/uPSR_buttons.pas b/Units/PascalScript/uPSR_buttons.pas new file mode 100644 index 0000000..8117e4e --- /dev/null +++ b/Units/PascalScript/uPSR_buttons.pas @@ -0,0 +1,38 @@ + +unit uPSR_buttons; +{$I PascalScript.inc} +interface +uses + uPSRuntime, uPSUtils; + + +procedure RIRegisterTSPEEDBUTTON(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTBITBTN(Cl: TPSRuntimeClassImporter); + +procedure RIRegister_Buttons(Cl: TPSRuntimeClassImporter); + +implementation +uses + Classes{$IFDEF CLX}, QControls, QButtons{$ELSE}, Controls, Buttons{$ENDIF}; + +procedure RIRegisterTSPEEDBUTTON(Cl: TPSRuntimeClassImporter); +begin + Cl.Add(TSPEEDBUTTON); +end; + + +procedure RIRegisterTBITBTN(Cl: TPSRuntimeClassImporter); +begin + Cl.Add(TBITBTN); +end; + +procedure RIRegister_Buttons(Cl: TPSRuntimeClassImporter); +begin + RIRegisterTSPEEDBUTTON(cl); + RIRegisterTBITBTN(cl); +end; + +// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl) + + +end. diff --git a/Units/PascalScript/uPSR_classes.pas b/Units/PascalScript/uPSR_classes.pas new file mode 100644 index 0000000..b29abc8 --- /dev/null +++ b/Units/PascalScript/uPSR_classes.pas @@ -0,0 +1,383 @@ + +unit uPSR_classes; + +{$I PascalScript.inc} +interface +uses + uPSRuntime, uPSUtils; + + +procedure RIRegisterTStrings(cl: TPSRuntimeClassImporter; Streams: Boolean); +procedure RIRegisterTStringList(cl: TPSRuntimeClassImporter); +{$IFNDEF PS_MINIVCL} +procedure RIRegisterTBITS(Cl: TPSRuntimeClassImporter); +{$ENDIF} +procedure RIRegisterTSTREAM(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTHANDLESTREAM(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTFILESTREAM(Cl: TPSRuntimeClassImporter); +{$IFNDEF PS_MINIVCL} +procedure RIRegisterTCUSTOMMEMORYSTREAM(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTMEMORYSTREAM(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTRESOURCESTREAM(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTPARSER(Cl: TPSRuntimeClassImporter); +{$IFDEF DELPHI3UP} +procedure RIRegisterTOWNEDCOLLECTION(Cl: TPSRuntimeClassImporter); +{$ENDIF} +procedure RIRegisterTCOLLECTION(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTCOLLECTIONITEM(Cl: TPSRuntimeClassImporter); +{$ENDIF} + +procedure RIRegister_Classes(Cl: TPSRuntimeClassImporter; Streams: Boolean{$IFDEF D4PLUS}=True{$ENDIF}); + +implementation +uses + Classes; + +procedure TStringsCountR(Self: TStrings; var T: Longint); begin T := Self.Count; end; + +procedure TStringsTextR(Self: TStrings; var T: string); begin T := Self.Text; end; +procedure TStringsTextW(Self: TStrings; T: string); begin Self.Text:= T; end; + +procedure TStringsCommaTextR(Self: TStrings; var T: string); begin T := Self.CommaText; end; +procedure TStringsCommaTextW(Self: TStrings; T: string); begin Self.CommaText:= T; end; + +procedure TStringsObjectsR(Self: TStrings; var T: TObject; I: Longint); +begin +T := Self.Objects[I]; +end; +procedure TStringsObjectsW(Self: TStrings; const T: TObject; I: Longint); +begin + Self.Objects[I]:= T; +end; + +procedure TStringsStringsR(Self: TStrings; var T: string; I: Longint); +begin +T := Self.Strings[I]; +end; +procedure TStringsStringsW(Self: TStrings; const T: string; I: Longint); +begin + Self.Strings[I]:= T; +end; + +procedure TStringsNamesR(Self: TStrings; var T: string; I: Longint); +begin +T := Self.Names[I]; +end; +procedure TStringsValuesR(Self: TStrings; var T: string; const I: string); +begin +T := Self.Values[I]; +end; +procedure TStringsValuesW(Self: TStrings; Const T, I: String); +begin + Self.Values[I]:= T; +end; + +procedure RIRegisterTStrings(cl: TPSRuntimeClassImporter; Streams: Boolean); // requires TPersistent +begin + with Cl.Add(TStrings) do + begin + RegisterVirtualMethod(@TStrings.Add, 'ADD'); + RegisterMethod(@TStrings.Append, 'APPEND'); + RegisterVirtualMethod(@TStrings.AddStrings, 'ADDSTRINGS'); + RegisterVirtualAbstractMethod(TStringList, @TStringList.Clear, 'CLEAR'); + RegisterVirtualAbstractMethod(TStringList, @TStringList.Delete, 'DELETE'); + RegisterVirtualMethod(@TStrings.IndexOf, 'INDEXOF'); + RegisterVirtualAbstractMethod(TStringList, @TStringList.Insert, 'INSERT'); + RegisterPropertyHelper(@TStringsCountR, nil, 'COUNT'); + RegisterPropertyHelper(@TStringsTextR, @TStringsTextW, 'TEXT'); + RegisterPropertyHelper(@TStringsCommaTextR, @TStringsCommatextW, 'COMMATEXT'); + if Streams then + begin + RegisterVirtualMethod(@TStrings.LoadFromFile, 'LOADFROMFILE'); + RegisterVirtualMethod(@TStrings.SaveToFile, 'SAVETOFILE'); + end; + RegisterPropertyHelper(@TStringsStringsR, @TStringsStringsW, 'STRINGS'); + RegisterPropertyHelper(@TStringsObjectsR, @TStringsObjectsW, 'OBJECTS'); + + {$IFNDEF PS_MINIVCL} + RegisterMethod(@TStrings.BeginUpdate, 'BEGINUPDATE'); + RegisterMethod(@TStrings.EndUpdate, 'ENDUPDATE'); + RegisterMethod(@TStrings.Equals, 'EQUALS'); + RegisterVirtualMethod(@TStrings.Exchange, 'EXCHANGE'); + RegisterMethod(@TStrings.IndexOfName, 'INDEXOFNAME'); + if Streams then + RegisterVirtualMethod(@TStrings.LoadFromStream, 'LOADFROMSTREAM'); + RegisterVirtualMethod(@TStrings.Move, 'MOVE'); + if Streams then + RegisterVirtualMethod(@TStrings.SaveToStream, 'SAVETOSTREAM'); + RegisterVirtualMethod(@TStrings.SetText, 'SETTEXT'); + RegisterPropertyHelper(@TStringsNamesR, nil, 'NAMES'); + RegisterPropertyHelper(@TStringsValuesR, @TStringsValuesW, 'VALUES'); + RegisterVirtualMethod(@TSTRINGS.ADDOBJECT, 'ADDOBJECT'); + RegisterVirtualMethod(@TSTRINGS.GETTEXT, 'GETTEXT'); + RegisterMethod(@TSTRINGS.INDEXOFOBJECT, 'INDEXOFOBJECT'); + RegisterMethod(@TSTRINGS.INSERTOBJECT, 'INSERTOBJECT'); + {$ENDIF} + end; +end; + +procedure TSTRINGLISTDUPLICATES_R(Self: TSTRINGLIST; var T: TDUPLICATES); begin T := Self.DUPLICATES; end; +procedure TSTRINGLISTDUPLICATES_W(Self: TSTRINGLIST; const T: TDUPLICATES); begin Self.DUPLICATES := T; end; +procedure TSTRINGLISTSORTED_R(Self: TSTRINGLIST; var T: BOOLEAN); begin T := Self.SORTED; end; +procedure TSTRINGLISTSORTED_W(Self: TSTRINGLIST; const T: BOOLEAN); begin Self.SORTED := T; end; +procedure TSTRINGLISTONCHANGE_R(Self: TSTRINGLIST; var T: TNOTIFYEVENT); +begin +T := Self.ONCHANGE; end; +procedure TSTRINGLISTONCHANGE_W(Self: TSTRINGLIST; const T: TNOTIFYEVENT); +begin +Self.ONCHANGE := T; end; +procedure TSTRINGLISTONCHANGING_R(Self: TSTRINGLIST; var T: TNOTIFYEVENT); begin T := Self.ONCHANGING; end; +procedure TSTRINGLISTONCHANGING_W(Self: TSTRINGLIST; const T: TNOTIFYEVENT); begin Self.ONCHANGING := T; end; +procedure RIRegisterTSTRINGLIST(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TSTRINGLIST) do + begin + RegisterVirtualMethod(@TSTRINGLIST.FIND, 'FIND'); + RegisterVirtualMethod(@TSTRINGLIST.SORT, 'SORT'); + RegisterPropertyHelper(@TSTRINGLISTDUPLICATES_R, @TSTRINGLISTDUPLICATES_W, 'DUPLICATES'); + RegisterPropertyHelper(@TSTRINGLISTSORTED_R, @TSTRINGLISTSORTED_W, 'SORTED'); + RegisterEventPropertyHelper(@TSTRINGLISTONCHANGE_R, @TSTRINGLISTONCHANGE_W, 'ONCHANGE'); + RegisterEventPropertyHelper(@TSTRINGLISTONCHANGING_R, @TSTRINGLISTONCHANGING_W, 'ONCHANGING'); + end; +end; + +{$IFNDEF PS_MINIVCL} +procedure TBITSBITS_W(Self: TBITS; T: BOOLEAN; t1: INTEGER); begin Self.BITS[t1] := T; end; +procedure TBITSBITS_R(Self: TBITS; var T: BOOLEAN; t1: INTEGER); begin T := Self.Bits[t1]; end; +procedure TBITSSIZE_R(Self: TBITS; T: INTEGER); begin Self.SIZE := T; end; +procedure TBITSSIZE_W(Self: TBITS; var T: INTEGER); begin T := Self.SIZE; end; + +procedure RIRegisterTBITS(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TBITS) do + begin + RegisterMethod(@TBITS.OPENBIT, 'OPENBIT'); + RegisterPropertyHelper(@TBITSBITS_R, @TBITSBITS_W, 'BITS'); + RegisterPropertyHelper(@TBITSSIZE_R, @TBITSSIZE_W, 'SIZE'); + end; +end; +{$ENDIF} + +procedure TSTREAMPOSITION_R(Self: TSTREAM; var T: LONGINT); begin t := Self.POSITION; end; +procedure TSTREAMPOSITION_W(Self: TSTREAM; T: LONGINT); begin Self.POSITION := t; end; +procedure TSTREAMSIZE_R(Self: TSTREAM; var T: LONGINT); begin t := Self.SIZE; end; +{$IFDEF DELPHI3UP} +procedure TSTREAMSIZE_W(Self: TSTREAM; T: LONGINT); begin Self.SIZE := t; end; +{$ENDIF} + +procedure RIRegisterTSTREAM(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TSTREAM) do + begin + RegisterVirtualAbstractMethod(TMemoryStream, @TMemoryStream.READ, 'READ'); + RegisterVirtualAbstractMethod(TMemoryStream, @TMemoryStream.WRITE, 'WRITE'); + RegisterVirtualAbstractMethod(TMemoryStream, @TMemoryStream.SEEK, 'SEEK'); + RegisterMethod(@TSTREAM.READBUFFER, 'READBUFFER'); + RegisterMethod(@TSTREAM.WRITEBUFFER, 'WRITEBUFFER'); + RegisterMethod(@TSTREAM.COPYFROM, 'COPYFROM'); + RegisterPropertyHelper(@TSTREAMPOSITION_R, @TSTREAMPOSITION_W, 'POSITION'); + RegisterPropertyHelper(@TSTREAMSIZE_R, {$IFDEF DELPHI3UP}@TSTREAMSIZE_W, {$ELSE}nil, {$ENDIF}'SIZE'); + end; +end; + +procedure THANDLESTREAMHANDLE_R(Self: THANDLESTREAM; var T: INTEGER); begin T := Self.HANDLE; end; + +procedure RIRegisterTHANDLESTREAM(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(THANDLESTREAM) do + begin + RegisterConstructor(@THANDLESTREAM.CREATE, 'CREATE'); + RegisterPropertyHelper(@THANDLESTREAMHANDLE_R, nil, 'HANDLE'); + end; +end; + +{$IFDEF FPC} +// mh: because FPC doesn't handle pointers to overloaded functions +function TFileStreamCreate(filename: string; mode: word): TFileStream; +begin + result := TFilestream.Create(filename, mode); +end; +{$ENDIF} + +procedure RIRegisterTFILESTREAM(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TFILESTREAM) do + begin + {$IFDEF FPC} + RegisterConstructor(@TFileStreamCreate, 'CREATE'); + {$ELSE} + RegisterConstructor(@TFILESTREAM.CREATE, 'CREATE'); + {$ENDIF} + end; +end; + +{$IFNDEF PS_MINIVCL} +procedure RIRegisterTCUSTOMMEMORYSTREAM(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TCUSTOMMEMORYSTREAM) do + begin + RegisterMethod(@TCUSTOMMEMORYSTREAM.SAVETOSTREAM, 'SAVETOSTREAM'); + RegisterMethod(@TCUSTOMMEMORYSTREAM.SAVETOFILE, 'SAVETOFILE'); + end; +end; + +procedure RIRegisterTMEMORYSTREAM(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TMEMORYSTREAM) do + begin + RegisterMethod(@TMEMORYSTREAM.CLEAR, 'CLEAR'); + RegisterMethod(@TMEMORYSTREAM.LOADFROMSTREAM, 'LOADFROMSTREAM'); + RegisterMethod(@TMEMORYSTREAM.LOADFROMFILE, 'LOADFROMFILE'); + RegisterMethod(@TMEMORYSTREAM.SETSIZE, 'SETSIZE'); + end; +end; + +procedure RIRegisterTRESOURCESTREAM(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TRESOURCESTREAM) do + begin + RegisterConstructor(@TRESOURCESTREAM.CREATE, 'CREATE'); + RegisterConstructor(@TRESOURCESTREAM.CREATEFROMID, 'CREATEFROMID'); + end; +end; + +procedure TPARSERSOURCELINE_R(Self: TPARSER; var T: INTEGER); begin T := Self.SOURCELINE; end; +procedure TPARSERTOKEN_R(Self: TPARSER; var T: CHAR); begin T := Self.TOKEN; end; + +procedure RIRegisterTPARSER(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TPARSER) do + begin + RegisterConstructor(@TPARSER.CREATE, 'CREATE'); + RegisterMethod(@TPARSER.CHECKTOKEN, 'CHECKTOKEN'); + RegisterMethod(@TPARSER.CHECKTOKENSYMBOL, 'CHECKTOKENSYMBOL'); + RegisterMethod(@TPARSER.ERROR, 'ERROR'); + RegisterMethod(@TPARSER.ERRORSTR, 'ERRORSTR'); + RegisterMethod(@TPARSER.HEXTOBINARY, 'HEXTOBINARY'); + RegisterMethod(@TPARSER.NEXTTOKEN, 'NEXTTOKEN'); + RegisterMethod(@TPARSER.SOURCEPOS, 'SOURCEPOS'); + RegisterMethod(@TPARSER.TOKENCOMPONENTIDENT, 'TOKENCOMPONENTIDENT'); + RegisterMethod(@TPARSER.TOKENFLOAT, 'TOKENFLOAT'); + RegisterMethod(@TPARSER.TOKENINT, 'TOKENINT'); + RegisterMethod(@TPARSER.TOKENSTRING, 'TOKENSTRING'); + RegisterMethod(@TPARSER.TOKENSYMBOLIS, 'TOKENSYMBOLIS'); + RegisterPropertyHelper(@TPARSERSOURCELINE_R, nil, 'SOURCELINE'); + RegisterPropertyHelper(@TPARSERTOKEN_R, nil, 'TOKEN'); + end; +end; + +procedure TCOLLECTIONITEMS_W(Self: TCOLLECTION; const T: TCOLLECTIONITEM; const t1: INTEGER); +begin Self.ITEMS[t1] := T; end; + +procedure TCOLLECTIONITEMS_R(Self: TCOLLECTION; var T: TCOLLECTIONITEM; const t1: INTEGER); +begin T := Self.ITEMS[t1]; end; + +{$IFDEF DELPHI3UP} +procedure TCOLLECTIONITEMCLASS_R(Self: TCOLLECTION; var T: TCOLLECTIONITEMCLASS); +begin T := Self.ITEMCLASS; end; +{$ENDIF} + +procedure TCOLLECTIONCOUNT_R(Self: TCOLLECTION; var T: INTEGER); +begin T := Self.COUNT; end; + +{$IFDEF DELPHI3UP} +procedure TCOLLECTIONITEMDISPLAYNAME_W(Self: TCOLLECTIONITEM; const T: STRING); +begin Self.DISPLAYNAME := T; end; +{$ENDIF} + +{$IFDEF DELPHI3UP} +procedure TCOLLECTIONITEMDISPLAYNAME_R(Self: TCOLLECTIONITEM; var T: STRING); +begin T := Self.DISPLAYNAME; end; +{$ENDIF} + +procedure TCOLLECTIONITEMINDEX_W(Self: TCOLLECTIONITEM; const T: INTEGER); +begin Self.INDEX := T; end; + +procedure TCOLLECTIONITEMINDEX_R(Self: TCOLLECTIONITEM; var T: INTEGER); +begin T := Self.INDEX; end; + +{$IFDEF DELPHI3UP} +procedure TCOLLECTIONITEMID_R(Self: TCOLLECTIONITEM; var T: INTEGER); +begin T := Self.ID; end; +{$ENDIF} + +procedure TCOLLECTIONITEMCOLLECTION_W(Self: TCOLLECTIONITEM; const T: TCOLLECTION); +begin Self.COLLECTION := T; end; + +procedure TCOLLECTIONITEMCOLLECTION_R(Self: TCOLLECTIONITEM; var T: TCOLLECTION); +begin T := Self.COLLECTION; end; + +{$IFDEF DELPHI3UP} +procedure RIRegisterTOWNEDCOLLECTION(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TOWNEDCOLLECTION) do + begin + RegisterConstructor(@TOWNEDCOLLECTION.CREATE, 'CREATE'); + end; +end; +{$ENDIF} + +procedure RIRegisterTCOLLECTION(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TCOLLECTION) do + begin + RegisterConstructor(@TCOLLECTION.CREATE, 'CREATE'); +{$IFDEF DELPHI6UP} {$IFNDEF FPC} RegisterMethod(@TCOLLECTION.OWNER, 'OWNER'); {$ENDIF} {$ENDIF} // no owner in FPC + RegisterMethod(@TCOLLECTION.ADD, 'ADD'); + RegisterVirtualMethod(@TCOLLECTION.BEGINUPDATE, 'BEGINUPDATE'); + RegisterMethod(@TCOLLECTION.CLEAR, 'CLEAR'); +{$IFDEF DELPHI5UP} RegisterMethod(@TCOLLECTION.DELETE, 'DELETE'); {$ENDIF} + RegisterVirtualMethod(@TCOLLECTION.ENDUPDATE, 'ENDUPDATE'); +{$IFDEF DELPHI3UP} RegisterMethod(@TCOLLECTION.FINDITEMID, 'FINDITEMID'); {$ENDIF} +{$IFDEF DELPHI3UP} RegisterMethod(@TCOLLECTION.INSERT, 'INSERT'); {$ENDIF} + RegisterPropertyHelper(@TCOLLECTIONCOUNT_R,nil,'COUNT'); +{$IFDEF DELPHI3UP} RegisterPropertyHelper(@TCOLLECTIONITEMCLASS_R,nil,'ITEMCLASS'); {$ENDIF} + RegisterPropertyHelper(@TCOLLECTIONITEMS_R,@TCOLLECTIONITEMS_W,'ITEMS'); + end; +end; + +procedure RIRegisterTCOLLECTIONITEM(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TCOLLECTIONITEM) do + begin + RegisterVirtualConstructor(@TCOLLECTIONITEM.CREATE, 'CREATE'); + RegisterPropertyHelper(@TCOLLECTIONITEMCOLLECTION_R,@TCOLLECTIONITEMCOLLECTION_W,'COLLECTION'); +{$IFDEF DELPHI3UP} RegisterPropertyHelper(@TCOLLECTIONITEMID_R,nil,'ID'); {$ENDIF} + RegisterPropertyHelper(@TCOLLECTIONITEMINDEX_R,@TCOLLECTIONITEMINDEX_W,'INDEX'); +{$IFDEF DELPHI3UP} RegisterPropertyHelper(@TCOLLECTIONITEMDISPLAYNAME_R,@TCOLLECTIONITEMDISPLAYNAME_W,'DISPLAYNAME'); {$ENDIF} + end; +end; +{$ENDIF} + +procedure RIRegister_Classes(Cl: TPSRuntimeClassImporter; Streams: Boolean); +begin + if Streams then + RIRegisterTSTREAM(Cl); + RIRegisterTStrings(cl, Streams); + RIRegisterTStringList(cl); + {$IFNDEF PS_MINIVCL} + RIRegisterTBITS(cl); + {$ENDIF} + if Streams then + begin + RIRegisterTHANDLESTREAM(Cl); + RIRegisterTFILESTREAM(Cl); + {$IFNDEF PS_MINIVCL} + RIRegisterTCUSTOMMEMORYSTREAM(Cl); + RIRegisterTMEMORYSTREAM(Cl); + RIRegisterTRESOURCESTREAM(Cl); + {$ENDIF} + end; + {$IFNDEF PS_MINIVCL} + RIRegisterTPARSER(Cl); + RIRegisterTCOLLECTIONITEM(Cl); + RIRegisterTCOLLECTION(Cl); + {$IFDEF DELPHI3UP} + RIRegisterTOWNEDCOLLECTION(Cl); + {$ENDIF} + {$ENDIF} +end; + +// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl) + +end. diff --git a/Units/PascalScript/uPSR_comobj.pas b/Units/PascalScript/uPSR_comobj.pas new file mode 100644 index 0000000..67ec7df --- /dev/null +++ b/Units/PascalScript/uPSR_comobj.pas @@ -0,0 +1,96 @@ + + +unit uPSR_comobj; + +{$I PascalScript.inc} +interface +uses + uPSRuntime, uPSUtils; + + +procedure RIRegister_ComObj(cl: TPSExec); + +implementation +uses +{$IFDEF DELPHI3UP} + ComObj; +{$ELSE} + SysUtils, Ole2; +{$ENDIF} +{$IFNDEF DELPHI3UP} + +{$IFDEF DELPHI3UP } +resourceString +{$ELSE } +const +{$ENDIF } + + RPS_OLEError = 'OLE error %.8x'; +function OleErrorMessage(ErrorCode: HResult): String; +begin + Result := SysErrorMessage(ErrorCode); + if Result = '' then + Result := Format(RPS_OLEError, [ErrorCode]); +end; + +procedure OleError(ErrorCode: HResult); +begin + raise Exception.Create(OleErrorMessage(ErrorCode)); +end; + +procedure OleCheck(Result: HResult); +begin + if Result < 0 then OleError(Result); +end; + +procedure CreateOleObject(const ClassName: string; var Disp: IDispatch); +var + OldDisp: IDispatch; + ClassID: TCLSID; + WideCharBuf: array[0..127] of WideChar; +begin + StringToWideChar(ClassName, WideCharBuf, SizeOf(WideCharBuf) div SizeOf(WideCharBuf[0])); + OleCheck(CLSIDFromProgID(WideCharBuf, ClassID)); + if Disp <> nil then + begin + OldDisp := Disp; + Disp := nil; + OldDisp.Release; + end; + OleCheck(CoCreateInstance(ClassID, nil, CLSCTX_INPROC_SERVER or + CLSCTX_LOCAL_SERVER, IID_IDispatch, Disp)); +end; + +procedure GetActiveOleObject(const ClassName: string; var Disp: IDispatch); +var + Unknown: IUnknown; + OldDisp: IDispatch; + ClassID: TCLSID; + WideCharBuf: array[0..127] of WideChar; +begin + StringToWideChar(ClassName, WideCharBuf, SizeOf(WideCharBuf) div SizeOf(WideCharBuf[0])); + OleCheck(CLSIDFromProgID(WideCharBuf, ClassID)); + OleCheck(GetActiveObject(ClassID, nil, Unknown)); + try + if Disp <> nil then + begin + OldDisp := Disp; + Disp := nil; + OldDisp.Release; + end; + OleCheck(Unknown.QueryInterface(IID_IDispatch, Disp)); + finally + Unknown.Release; + end; +end; + +{$ENDIF} + + +procedure RIRegister_ComObj(cl: TPSExec); +begin + cl.RegisterDelphiFunction(@CreateOleObject, 'CREATEOLEOBJECT', cdRegister); + cl.RegisterDelphiFunction(@GetActiveOleObject, 'GETACTIVEOLEOBJECT', cdRegister); +end; + +end. diff --git a/Units/PascalScript/uPSR_controls.pas b/Units/PascalScript/uPSR_controls.pas new file mode 100644 index 0000000..4bac801 --- /dev/null +++ b/Units/PascalScript/uPSR_controls.pas @@ -0,0 +1,249 @@ + +unit uPSR_controls; + +{$I PascalScript.inc} +interface +uses + uPSRuntime, uPSUtils; + + + + +procedure RIRegisterTControl(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTWinControl(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTGraphicControl(cl: TPSRuntimeClassImporter); +procedure RIRegisterTCustomControl(cl: TPSRuntimeClassImporter); +procedure RIRegister_TDragObject(CL: TPSRuntimeClassImporter); + +procedure RIRegister_Controls(Cl: TPSRuntimeClassImporter); + +implementation +{$IFNDEF FPC} +uses + Classes{$IFDEF CLX}, QControls, QGraphics{$ELSE}, Controls, Graphics, Windows{$ENDIF}; +{$ELSE} +uses + Classes, Controls, Graphics; +{$ENDIF} + +procedure TControlAlignR(Self: TControl; var T: Byte); begin T := Byte(Self.Align); end; +procedure TControlAlignW(Self: TControl; T: Byte); begin Self.Align:= TAlign(T); end; + +procedure TControlClientHeightR(Self: TControl; var T: Longint); begin T := Self.ClientHeight; end; +procedure TControlClientHeightW(Self: TControl; T: Longint); begin Self.ClientHeight := T; end; + +procedure TControlClientWidthR(Self: TControl; var T: Longint); begin T := Self.ClientWidth; end; +procedure TControlClientWidthW(Self: TControl; T: Longint); begin Self.ClientWidth:= T; end; + +procedure TControlShowHintR(Self: TControl; var T: Boolean); begin T := Self.ShowHint; end; +procedure TControlShowHintW(Self: TControl; T: Boolean); begin Self.ShowHint:= T; end; + +procedure TControlVisibleR(Self: TControl; var T: Boolean); begin T := Self.Visible; end; +procedure TControlVisibleW(Self: TControl; T: Boolean); begin Self.Visible:= T; end; + +procedure TControlParentR(Self: TControl; var T: TWinControl); begin T := Self.Parent; end; +procedure TControlParentW(Self: TControl; T: TWinControl); begin Self.Parent:= T; end; + + +procedure TCONTROLSHOWHINT_W(Self: TCONTROL; T: BOOLEAN); begin Self.SHOWHINT := T; end; +procedure TCONTROLSHOWHINT_R(Self: TCONTROL; var T: BOOLEAN); begin T := Self.SHOWHINT; end; +procedure TCONTROLENABLED_W(Self: TCONTROL; T: BOOLEAN); begin Self.ENABLED := T; end; +procedure TCONTROLENABLED_R(Self: TCONTROL; var T: BOOLEAN); begin T := Self.ENABLED; end; + +procedure RIRegisterTControl(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TControl) do + begin + RegisterVirtualConstructor(@TControl.Create, 'CREATE'); + RegisterMethod(@TControl.BRingToFront, 'BRINGTOFRONT'); + RegisterMethod(@TControl.Hide, 'HIDE'); + RegisterVirtualMethod(@TControl.Invalidate, 'INVALIDATE'); + RegisterMethod(@TControl.Refresh, 'REFRESH'); + RegisterVirtualMethod(@TControl.Repaint, 'REPAINT'); + RegisterMethod(@TControl.SendToBack, 'SENDTOBACK'); + RegisterMethod(@TControl.Show, 'SHOW'); + RegisterVirtualMethod(@TControl.Update, 'UPDATE'); + RegisterVirtualMethod(@TControl.SetBounds, 'SETBOUNDS'); + + RegisterPropertyHelper(@TControlShowHintR, @TControlShowHintW, 'SHOWHINT'); + RegisterPropertyHelper(@TControlAlignR, @TControlAlignW, 'ALIGN'); + RegisterPropertyHelper(@TControlClientHeightR, @TControlClientHeightW, 'CLIENTHEIGHT'); + RegisterPropertyHelper(@TControlClientWidthR, @TControlClientWidthW, 'CLIENTWIDTH'); + RegisterPropertyHelper(@TControlVisibleR, @TControlVisibleW, 'VISIBLE'); + RegisterPropertyHelper(@TCONTROLENABLED_R, @TCONTROLENABLED_W, 'ENABLED'); + + RegisterPropertyHelper(@TControlParentR, @TControlParentW, 'PARENT'); + + {$IFNDEF PS_MINIVCL} + RegisterMethod(@TControl.Dragging, 'DRAGGING'); + RegisterMethod(@TControl.HasParent, 'HASPARENT'); + RegisterMethod(@TCONTROL.CLIENTTOSCREEN, 'CLIENTTOSCREEN'); + RegisterMethod(@TCONTROL.DRAGGING, 'DRAGGING'); + {$IFNDEF FPC} + RegisterMethod(@TCONTROL.BEGINDRAG, 'BEGINDRAG'); + RegisterMethod(@TCONTROL.ENDDRAG, 'ENDDRAG'); + {$ENDIF} + {$IFNDEF CLX} + RegisterMethod(@TCONTROL.GETTEXTBUF, 'GETTEXTBUF'); + RegisterMethod(@TCONTROL.GETTEXTLEN, 'GETTEXTLEN'); + RegisterMethod(@TCONTROL.PERFORM, 'PERFORM'); + RegisterMethod(@TCONTROL.SETTEXTBUF, 'SETTEXTBUF'); + {$ENDIF} + RegisterMethod(@TCONTROL.SCREENTOCLIENT, 'SCREENTOCLIENT'); + {$ENDIF} + end; +end; +{$IFNDEF CLX} +procedure TWinControlHandleR(Self: TWinControl; var T: Longint); begin T := Self.Handle; end; +{$ENDIF} +procedure TWinControlShowingR(Self: TWinControl; var T: Boolean); begin T := Self.Showing; end; + + +procedure TWinControlTabOrderR(Self: TWinControl; var T: Longint); begin T := Self.TabOrder; end; +procedure TWinControlTabOrderW(Self: TWinControl; T: Longint); begin Self.TabOrder:= T; end; + +procedure TWinControlTabStopR(Self: TWinControl; var T: Boolean); begin T := Self.TabStop; end; +procedure TWinControlTabStopW(Self: TWinControl; T: Boolean); begin Self.TabStop:= T; end; +procedure TWINCONTROLBRUSH_R(Self: TWINCONTROL; var T: TBRUSH); begin T := Self.BRUSH; end; +procedure TWINCONTROLCONTROLS_R(Self: TWINCONTROL; var T: TCONTROL; t1: INTEGER); begin t := Self.CONTROLS[t1]; end; +procedure TWINCONTROLCONTROLCOUNT_R(Self: TWINCONTROL; var T: INTEGER); begin t := Self.CONTROLCOUNT; end; + +procedure RIRegisterTWinControl(Cl: TPSRuntimeClassImporter); // requires TControl +begin + with Cl.Add(TWinControl) do + begin + {$IFNDEF CLX} + RegisterPropertyHelper(@TWinControlHandleR, nil, 'HANDLE'); + {$ENDIF} + RegisterPropertyHelper(@TWinControlShowingR, nil, 'SHOWING'); + RegisterPropertyHelper(@TWinControlTabOrderR, @TWinControlTabOrderW, 'TABORDER'); + RegisterPropertyHelper(@TWinControlTabStopR, @TWinControlTabStopW, 'TABSTOP'); + RegisterMethod(@TWINCONTROL.CANFOCUS, 'CANFOCUS'); + RegisterMethod(@TWINCONTROL.FOCUSED, 'FOCUSED'); + RegisterPropertyHelper(@TWINCONTROLCONTROLS_R, nil, 'CONTROLS'); + RegisterPropertyHelper(@TWINCONTROLCONTROLCOUNT_R, nil, 'CONTROLCOUNT'); + {$IFNDEF PS_MINIVCL} + RegisterMethod(@TWinControl.HandleAllocated, 'HANDLEALLOCATED'); + RegisterMethod(@TWinControl.HandleNeeded, 'HANDLENEEDED'); + RegisterMethod(@TWinControl.EnableAlign, 'ENABLEALIGN'); + RegisterMethod(@TWinControl.RemoveControl, 'REMOVECONTROL'); + {$IFNDEF FPC} + RegisterMethod(@TWinControl.InsertControl, 'INSERTCONTROL'); + RegisterMethod(@TWinControl.ScaleBy, 'SCALEBY'); + RegisterMethod(@TWinControl.ScrollBy, 'SCROLLBY'); + {$IFNDEF CLX} + RegisterMethod(@TWINCONTROL.PAINTTO, 'PAINTTO'); + {$ENDIF} + {$ENDIF}{FPC} + RegisterMethod(@TWinControl.Realign, 'REALIGN'); + RegisterVirtualMethod(@TWinControl.SetFocus, 'SETFOCUS'); + RegisterMethod(@TWINCONTROL.CONTAINSCONTROL, 'CONTAINSCONTROL'); + RegisterMethod(@TWINCONTROL.DISABLEALIGN, 'DISABLEALIGN'); + RegisterMethod(@TWINCONTROL.UPDATECONTROLSTATE, 'UPDATECONTROLSTATE'); + RegisterPropertyHelper(@TWINCONTROLBRUSH_R, nil, 'BRUSH'); + {$ENDIF} + end; +end; + +procedure RIRegisterTGraphicControl(cl: TPSRuntimeClassImporter); // requires TControl +begin + Cl.Add(TGraphicControl); +end; +procedure RIRegisterTCustomControl(cl: TPSRuntimeClassImporter); // requires TControl +begin + Cl.Add(TCustomControl); +end; + +{$IFDEF DELPHI4UP} +(* === run-time registration functions === *) +(*----------------------------------------------------------------------------*) +procedure TDragObjectMouseDeltaY_R(Self: TDragObject; var T: Double); +begin T := Self.MouseDeltaY; end; + +(*----------------------------------------------------------------------------*) +procedure TDragObjectMouseDeltaX_R(Self: TDragObject; var T: Double); +begin T := Self.MouseDeltaX; end; + +(*----------------------------------------------------------------------------*) +procedure TDragObjectDragTarget_W(Self: TDragObject; const T: Pointer); +begin Self.DragTarget := T; end; + +(*----------------------------------------------------------------------------*) +procedure TDragObjectDragTarget_R(Self: TDragObject; var T: Pointer); +begin T := Self.DragTarget; end; + +(*----------------------------------------------------------------------------*) +procedure TDragObjectDragTargetPos_W(Self: TDragObject; const T: TPoint); +begin Self.DragTargetPos := T; end; + +(*----------------------------------------------------------------------------*) +procedure TDragObjectDragTargetPos_R(Self: TDragObject; var T: TPoint); +begin T := Self.DragTargetPos; end; + +(*----------------------------------------------------------------------------*) +procedure TDragObjectDragPos_W(Self: TDragObject; const T: TPoint); +begin Self.DragPos := T; end; + +(*----------------------------------------------------------------------------*) +procedure TDragObjectDragPos_R(Self: TDragObject; var T: TPoint); +begin T := Self.DragPos; end; + +(*----------------------------------------------------------------------------*) +procedure TDragObjectDragHandle_W(Self: TDragObject; const T: HWND); +begin Self.DragHandle := T; end; + +(*----------------------------------------------------------------------------*) +procedure TDragObjectDragHandle_R(Self: TDragObject; var T: HWND); +begin T := Self.DragHandle; end; + +(*----------------------------------------------------------------------------*) +procedure TDragObjectCancelling_W(Self: TDragObject; const T: Boolean); +begin Self.Cancelling := T; end; + +(*----------------------------------------------------------------------------*) +procedure TDragObjectCancelling_R(Self: TDragObject; var T: Boolean); +begin T := Self.Cancelling; end; +{$ENDIF} +(*----------------------------------------------------------------------------*) +procedure RIRegister_TDragObject(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TDragObject) do + begin +{$IFNDEF PS_MINIVCL} +{$IFDEF DELPHI4UP} + RegisterVirtualMethod(@TDragObject.Assign, 'Assign'); +{$ENDIF} +{$IFNDEF FPC} + RegisterVirtualMethod(@TDragObject.GetName, 'GetName'); + RegisterVirtualMethod(@TDragObject.Instance, 'Instance'); +{$ENDIF} + RegisterVirtualMethod(@TDragObject.HideDragImage, 'HideDragImage'); + RegisterVirtualMethod(@TDragObject.ShowDragImage, 'ShowDragImage'); +{$IFDEF DELPHI4UP} + RegisterPropertyHelper(@TDragObjectCancelling_R,@TDragObjectCancelling_W,'Cancelling'); + RegisterPropertyHelper(@TDragObjectDragHandle_R,@TDragObjectDragHandle_W,'DragHandle'); + RegisterPropertyHelper(@TDragObjectDragPos_R,@TDragObjectDragPos_W,'DragPos'); + RegisterPropertyHelper(@TDragObjectDragTargetPos_R,@TDragObjectDragTargetPos_W,'DragTargetPos'); + RegisterPropertyHelper(@TDragObjectDragTarget_R,@TDragObjectDragTarget_W,'DragTarget'); + RegisterPropertyHelper(@TDragObjectMouseDeltaX_R,nil,'MouseDeltaX'); + RegisterPropertyHelper(@TDragObjectMouseDeltaY_R,nil,'MouseDeltaY'); +{$ENDIF} +{$ENDIF} + end; +end; + + +procedure RIRegister_Controls(Cl: TPSRuntimeClassImporter); +begin + RIRegisterTControl(Cl); + RIRegisterTWinControl(Cl); + RIRegisterTGraphicControl(cl); + RIRegisterTCustomControl(cl); + RIRegister_TDragObject(cl); + +end; + +// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl) + + +end. diff --git a/Units/PascalScript/uPSR_dateutils.pas b/Units/PascalScript/uPSR_dateutils.pas new file mode 100644 index 0000000..9c0fd5b --- /dev/null +++ b/Units/PascalScript/uPSR_dateutils.pas @@ -0,0 +1,63 @@ + +unit uPSR_dateutils; +{$I PascalScript.inc} +interface +uses + SysUtils, uPSRuntime; + + + +procedure RegisterDateTimeLibrary_R(S: TPSExec); + +implementation + +function TryEncodeDate(Year, Month, Day: Word; var Date: TDateTime): Boolean; +begin + try + Date := EncodeDate(Year, Month, Day); + Result := true; + except + Result := false; + end; +end; + +function TryEncodeTime(Hour, Min, Sec, MSec: Word; var Time: TDateTime): Boolean; +begin + try + Time := EncodeTime(hour, Min, Sec, MSec); + Result := true; + except + Result := false; + end; +end; + +function DateTimeToUnix(D: TDateTime): Int64; +begin + Result := Round((D - 25569) * 86400); +end; + +function UnixToDateTime(U: Int64): TDateTime; +begin + Result := U / 86400 + 25569; +end; + +procedure RegisterDateTimeLibrary_R(S: TPSExec); +begin + S.RegisterDelphiFunction(@EncodeDate, 'ENCODEDATE', cdRegister); + S.RegisterDelphiFunction(@EncodeTime, 'ENCODETIME', cdRegister); + S.RegisterDelphiFunction(@TryEncodeDate, 'TRYENCODEDATE', cdRegister); + S.RegisterDelphiFunction(@TryEncodeTime, 'TRYENCODETIME', cdRegister); + S.RegisterDelphiFunction(@DecodeDate, 'DECODEDATE', cdRegister); + S.RegisterDelphiFunction(@DecodeTime, 'DECODETIME', cdRegister); + S.RegisterDelphiFunction(@DayOfWeek, 'DAYOFWEEK', cdRegister); + S.RegisterDelphiFunction(@Date, 'DATE', cdRegister); + S.RegisterDelphiFunction(@Time, 'TIME', cdRegister); + S.RegisterDelphiFunction(@Now, 'NOW', cdRegister); + S.RegisterDelphiFunction(@DateTimeToUnix, 'DATETIMETOUNIX', cdRegister); + S.RegisterDelphiFunction(@UnixToDateTime, 'UNIXTODATETIME', cdRegister); + S.RegisterDelphiFunction(@DateToStr, 'DATETOSTR', cdRegister); + S.RegisterDelphiFunction(@FormatDateTime, 'FORMATDATETIME', cdRegister); + S.RegisterDelphiFunction(@StrToDate, 'STRTODATE', cdRegister); +end; + +end. diff --git a/Units/PascalScript/uPSR_dll.pas b/Units/PascalScript/uPSR_dll.pas new file mode 100644 index 0000000..94ff209 --- /dev/null +++ b/Units/PascalScript/uPSR_dll.pas @@ -0,0 +1,312 @@ + +unit uPSR_dll; + +{$I PascalScript.inc} +interface +uses + uPSRuntime, uPSUtils; + +procedure RegisterDLLRuntime(Caller: TPSExec); +procedure RegisterDLLRuntimeEx(Caller: TPSExec; AddDllProcImport: Boolean); + +function ProcessDllImport(Caller: TPSExec; P: TPSExternalProcRec): Boolean; +function ProcessDllImportEx(Caller: TPSExec; P: TPSExternalProcRec; ForceDelayLoad: Boolean): Boolean; +function UnloadProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; + +implementation +uses + {$IFDEF UNIX} + {$IFDEF Darwin} + LCLIntf, Unix, baseunix, dynlibs, termio, sockets; + {$ELSE} + LibC{$IFNDEF FPC}, Windows{$ENDIF}; + {$ENDIF} + {$ELSE} + Windows; + {$ENDIF} + +{ +p^.Ext1 contains the pointer to the Proc function +p^.ExportDecl: + 'dll:'+DllName+#0+FunctionName+#0+chr(Cc)+Chr(DelayLoad)+Chr(AlternateSearchPath)+VarParams +} + +type + PLoadedDll = ^TLoadedDll; + TLoadedDll = record + dllnamehash: Longint; + dllname: tbtstring; + {$IFDEF LINUX} + dllhandle: Pointer; + {$ELSE} + dllhandle: THandle; + {$ENDIF} + end; + TMyExec = class(TPSExec); + PInteger = ^Integer; + +procedure LAstErrorFree(Sender: TPSExec; P: PInteger); +begin + dispose(p); +end; + +procedure DLLSetLastError(Sender: TPSExec; P: Integer); +var + pz: PInteger; +begin + pz := Sender.FindProcResource(@LastErrorFree); + if pz = nil then + begin + new(pz); + Sender.AddResource(@LastErrorFree, PZ); + end; + pz^ := p; +end; + +function DLLGetLastError(Sender: TPSExec): Integer; +var + pz: PInteger; +begin + pz := Sender.FindProcResource(@LastErrorFree); + if pz = nil then + result := 0 + else + result := pz^; +end; + + +procedure DllFree(Sender: TPSExec; P: PLoadedDll); +begin + {$IFDEF LINUX} + dlclose(p^.dllhandle); + {$ELSE} + FreeLibrary(p^.dllhandle); + {$ENDIF} + Dispose(p); +end; + +function LoadDll(Caller: TPSExec; P: TPSExternalProcRec): Boolean; +var + s, s2, s3: tbtstring; + h, i: Longint; + ph: PLoadedDll; + {$IFDEF LINUX} + dllhandle: Pointer; + {$ELSE} + dllhandle: THandle; + {$ENDIF} + loadwithalteredsearchpath: Boolean; +begin + s := p.Decl; + Delete(s, 1, 4); + s2 := copy(s, 1, pos(tbtchar(#0), s)-1); + delete(s, 1, length(s2)+1); + h := makehash(s2); + s3 := copy(s, 1, pos(tbtchar(#0), s)-1); + delete(s, 1, length(s3)+1); + loadwithalteredsearchpath := bytebool(s[3]); + i := 2147483647; // maxint + dllhandle := 0; + repeat + ph := Caller.FindProcResource2(@dllFree, i); + if (ph = nil) then + begin + if s2 = '' then + begin + // don't pass an empty filename to LoadLibrary, just treat it as uncallable + p.Ext2 := Pointer(1); + Result := False; + exit; + end; + {$IFDEF UNIX} + {$IFDEF DARWIN} + dllhandle := LoadLibrary(PChar(s2)); + {$ELSE} + dllhandle := dlopen(PChar(s2), RTLD_LAZY); + {$ENDIF} + {$ELSE} + if loadwithalteredsearchpath then + dllhandle := LoadLibraryExA(PAnsiChar(AnsiString(s2)), 0, LOAD_WITH_ALTERED_SEARCH_PATH) + else + dllhandle := LoadLibraryA(PAnsiChar(AnsiString(s2))); + {$ENDIF} + if dllhandle = {$IFDEF LINUX}nil{$ELSE}0{$ENDIF}then + begin + p.Ext2 := Pointer(1); + Result := False; + exit; + end; + new(ph); + ph^.dllnamehash := h; + ph^.dllname := s2; + ph^.dllhandle := dllhandle; + Caller.AddResource(@DllFree, ph); + end; + if (ph^.dllnamehash = h) and (ph^.dllname = s2) then + begin + dllhandle := ph^.dllhandle; + end; + until dllhandle <> {$IFDEF LINUX}nil{$ELSE}0{$ENDIF}; + {$IFDEF LINUX} + p.Ext1 := dlsym(dllhandle, pchar(s3)); + {$ELSE} + p.Ext1 := GetProcAddress(dllhandle, pansichar(s3)); + {$ENDIF} + if p.Ext1 = nil then + begin + p.Ext2 := Pointer(1); + Result := false; + exit; + end; + Result := True; +end; + + +function DllProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; + +var + i: Longint; + MyList: TIfList; + n: PPSVariantIFC; + CurrStack: Cardinal; + cc: TPSCallingConvention; + s: tbtstring; +begin + if p.Ext2 <> nil then // error + begin + Result := false; + exit; + end; + if p.Ext1 = nil then + begin + if not LoadDll(Caller, P) then + begin + Result := false; + exit; + end; + end; + s := p.Decl; + delete(S, 1, pos(tbtchar(#0), s)); + delete(S, 1, pos(tbtchar(#0), s)); + if length(S) < 2 then + begin + Result := False; + exit; + end; + cc := TPSCallingConvention(s[1]); + delete(s, 1, 3); // cc + delayload + alternatesearchpath (delayload might also be forced!) + CurrStack := Cardinal(Stack.Count) - Cardinal(length(s)); + if s[1] = #0 then inc(CurrStack); + MyList := tIfList.Create; + for i := 2 to length(s) do + begin + MyList.Add(nil); + end; + for i := length(s) downto 2 do + begin + MyList[i - 2] := NewPPSVariantIFC(Stack[CurrStack], s[i] <> #0); + inc(CurrStack); + end; + if s[1] <> #0 then + begin + n := NewPPSVariantIFC(Stack[CurrStack], true); + end else n := nil; + try + TMYExec(Caller).InnerfuseCall(nil, p.Ext1, cc, MyList, n); + {$IFNDEF LINUX} + DLLSetLastError(Caller, GetLastError); + {$ENDIF} + finally + DisposePPSvariantIFC(n); + DisposePPSVariantIFCList(MyList); + end; + result := true; +end; + +function ProcessDllImport(Caller: TPSExec; P: TPSExternalProcRec): Boolean; +begin + Result := ProcessDllImportEx(Caller, P, False); +end; + +function ProcessDllImportEx(Caller: TPSExec; P: TPSExternalProcRec; ForceDelayLoad: Boolean): Boolean; +var + DelayLoad: Boolean; + s: tbtstring; +begin + if not ForceDelayLoad then begin + s := p.Decl; + Delete(s,1,pos(tbtchar(#0), s)); + Delete(s,1,pos(tbtchar(#0), s)); + DelayLoad := bytebool(s[2]); + end else + DelayLoad := True; + + if DelayLoad then begin + p.ProcPtr := DllProc; + Result := True; + end else begin + p.ProcPtr := DllProc; + Result := LoadDll(Caller, p); + end; +end; + + +function GetLastErrorProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +begin + Stack.SetInt(-1, DLLGetLastError(Caller)); + Result := true; +end; + +function UnloadProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +var + h, i: Longint; + pv: TPSProcRec; + ph: PLoadedDll; + sname, s: tbtstring; +begin + sname := Stack.GetAnsiString(-1); + for i := Caller.GetProcCount -1 downto 0 do + begin + pv := Caller.GetProcNo(i); + if not (pv is TPSExternalProcRec) then continue; + if @TPSExternalProcRec(pv).ProcPtr <> @DllProc then continue; + s := (TPSExternalProcRec(pv).Decl); + delete(s,1,4); + if copy(s,1,pos(tbtchar(#0),s)-1) = sname then + begin + TPSExternalProcRec(pv).Ext1 := nil; + end; + end; + h := MakeHash(sname); + i := 2147483647; // maxint + repeat + ph := Caller.FindProcResource2(@dllFree, i); + if (ph = nil) then break; + if (ph.dllnamehash = h) and (ph.dllname = sname) then + begin + {$IFDEF LINUX} + dlclose(ph^.dllhandle); + {$ELSE} + FreeLibrary(ph^.dllhandle); + {$ENDIF} + Caller.DeleteResource(ph); + dispose(ph); + end; + until false; + result := true; +end; + +procedure RegisterDLLRuntime(Caller: TPSExec); +begin + RegisterDLLRuntimeEx(Caller, True); +end; + +procedure RegisterDLLRuntimeEx(Caller: TPSExec; AddDllProcImport: Boolean); +begin + if AddDllProcImport then + Caller.AddSpecialProcImport('dll', @ProcessDllImport, nil); + Caller.RegisterFunctionName('UNLOADDLL', UnloadProc, nil, nil); + Caller.RegisterFunctionName('DLLGETLASTERROR', GetLastErrorProc, nil, nil); +end; + +end. diff --git a/Units/PascalScript/uPSR_extctrls.pas b/Units/PascalScript/uPSR_extctrls.pas new file mode 100644 index 0000000..0f4a129 --- /dev/null +++ b/Units/PascalScript/uPSR_extctrls.pas @@ -0,0 +1,150 @@ + +unit uPSR_extctrls; + +{$I PascalScript.inc} +interface +uses + uPSRuntime, uPSUtils; + + +procedure RIRegister_ExtCtrls(cl: TPSRuntimeClassImporter); + +procedure RIRegisterTSHAPE(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTIMAGE(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTPAINTBOX(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTBEVEL(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTTIMER(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTCUSTOMPANEL(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTPANEL(Cl: TPSRuntimeClassImporter); +{$IFNDEF CLX} +procedure RIRegisterTPAGE(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTNOTEBOOK(Cl: TPSRuntimeClassImporter); +{$IFNDEF FPC}procedure RIRegisterTHEADER(Cl: TPSRuntimeClassImporter);{$ENDIF} +{$ENDIF} +procedure RIRegisterTCUSTOMRADIOGROUP(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTRADIOGROUP(Cl: TPSRuntimeClassImporter); + +implementation + +uses + {$IFDEF CLX} + QExtCtrls, QGraphics; + {$ELSE} + ExtCtrls, Graphics; + {$ENDIF} + +procedure RIRegisterTSHAPE(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TSHAPE) do + begin + {$IFNDEF PS_MINIVCL} + RegisterMethod(@TSHAPE.STYLECHANGED, 'STYLECHANGED'); + {$ENDIF} + end; +end; + +procedure TIMAGECANVAS_R(Self: TIMAGE; var T: TCANVAS); begin T := Self.CANVAS; end; + +procedure RIRegisterTIMAGE(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TIMAGE) do + begin + RegisterPropertyHelper(@TIMAGECANVAS_R, nil, 'CANVAS'); + end; +end; + +procedure TPAINTBOXCANVAS_R(Self: TPAINTBOX; var T: TCanvas); begin T := Self.CANVAS; end; + +procedure RIRegisterTPAINTBOX(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TPAINTBOX) do + begin + RegisterPropertyHelper(@TPAINTBOXCANVAS_R, nil, 'CANVAS'); + end; +end; + +procedure RIRegisterTBEVEL(Cl: TPSRuntimeClassImporter); +begin + Cl.Add(TBEVEL); +end; + +procedure RIRegisterTTIMER(Cl: TPSRuntimeClassImporter); +begin + Cl.Add(TTIMER); +end; + +procedure RIRegisterTCUSTOMPANEL(Cl: TPSRuntimeClassImporter); +begin + Cl.Add(TCUSTOMPANEL); +end; + +procedure RIRegisterTPANEL(Cl: TPSRuntimeClassImporter); +begin + Cl.Add(TPANEL); +end; +{$IFNDEF CLX} +procedure RIRegisterTPAGE(Cl: TPSRuntimeClassImporter); +begin + Cl.Add(TPAGE); +end; + +procedure RIRegisterTNOTEBOOK(Cl: TPSRuntimeClassImporter); +begin + Cl.Add(TNOTEBOOK); +end; + +{$IFNDEF FPC} +procedure THEADERSECTIONWIDTH_R(Self: THEADER; var T: INTEGER; t1: INTEGER); begin T := Self.SECTIONWIDTH[t1]; end; +procedure THEADERSECTIONWIDTH_W(Self: THEADER; T: INTEGER; t1: INTEGER); begin Self.SECTIONWIDTH[t1] := T; end; + +procedure RIRegisterTHEADER(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(THEADER) do + begin + RegisterPropertyHelper(@THEADERSECTIONWIDTH_R, @THEADERSECTIONWIDTH_W, 'SECTIONWIDTH'); + end; +end; +{$ENDIF} +{$ENDIF} + +procedure RIRegisterTCUSTOMRADIOGROUP(Cl: TPSRuntimeClassImporter); +begin + Cl.Add(TCUSTOMRADIOGROUP); +end; + +procedure RIRegisterTRADIOGROUP(Cl: TPSRuntimeClassImporter); +begin + Cl.Add(TRADIOGROUP); +end; + +procedure RIRegister_ExtCtrls(cl: TPSRuntimeClassImporter); +begin + {$IFNDEF PS_MINIVCL} + RIRegisterTSHAPE(Cl); + RIRegisterTIMAGE(Cl); + RIRegisterTPAINTBOX(Cl); + {$ENDIF} + RIRegisterTBEVEL(Cl); + {$IFNDEF PS_MINIVCL} + RIRegisterTTIMER(Cl); + {$ENDIF} + RIRegisterTCUSTOMPANEL(Cl); +{$IFNDEF CLX} + RIRegisterTPANEL(Cl); +{$ENDIF} + {$IFNDEF PS_MINIVCL} +{$IFNDEF CLX} + RIRegisterTPAGE(Cl); + RIRegisterTNOTEBOOK(Cl); + {$IFNDEF FPC} + RIRegisterTHEADER(Cl); + {$ENDIF}{FPC} +{$ENDIF} + RIRegisterTCUSTOMRADIOGROUP(Cl); + RIRegisterTRADIOGROUP(Cl); + {$ENDIF} +end; + +end. + + diff --git a/Units/PascalScript/uPSR_forms.pas b/Units/PascalScript/uPSR_forms.pas new file mode 100644 index 0000000..4a0f8f7 --- /dev/null +++ b/Units/PascalScript/uPSR_forms.pas @@ -0,0 +1,264 @@ + +unit uPSR_forms; + +{$I PascalScript.inc} +interface +uses + uPSRuntime, uPSUtils; + +procedure RIRegisterTCONTROLSCROLLBAR(Cl: TPSRuntimeClassImporter); +{$IFNDEF FPC} procedure RIRegisterTSCROLLINGWINCONTROL(Cl: TPSRuntimeClassImporter);{$ENDIF} +procedure RIRegisterTSCROLLBOX(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTFORM(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTAPPLICATION(Cl: TPSRuntimeClassImporter); + +procedure RIRegister_Forms(Cl: TPSRuntimeClassImporter); + +implementation +uses + sysutils, classes, {$IFDEF CLX}QControls, QForms, QGraphics{$ELSE}Controls, Forms, Graphics{$ENDIF}; + +procedure TCONTROLSCROLLBARKIND_R(Self: TCONTROLSCROLLBAR; var T: TSCROLLBARKIND); begin T := Self.KIND; end; +procedure TCONTROLSCROLLBARSCROLLPOS_R(Self: TCONTROLSCROLLBAR; var T: INTEGER); begin t := Self.SCROLLPOS; end; + +procedure RIRegisterTCONTROLSCROLLBAR(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TCONTROLSCROLLBAR) do + begin + RegisterPropertyHelper(@TCONTROLSCROLLBARKIND_R, nil, 'KIND'); + RegisterPropertyHelper(@TCONTROLSCROLLBARSCROLLPOS_R, nil, 'SCROLLPOS'); + end; +end; + +{$IFNDEF FPC} +procedure RIRegisterTSCROLLINGWINCONTROL(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TSCROLLINGWINCONTROL) do + begin + RegisterMethod(@TSCROLLINGWINCONTROL.SCROLLINVIEW, 'SCROLLINVIEW'); + end; +end; +{$ENDIF} + +procedure RIRegisterTSCROLLBOX(Cl: TPSRuntimeClassImporter); +begin + Cl.Add(TSCROLLBOX); +end; +{$IFNDEF FPC} +{$IFNDEF CLX} +procedure TFORMACTIVEOLECONTROL_W(Self: TFORM; T: TWINCONTROL); begin Self.ACTIVEOLECONTROL := T; end; +procedure TFORMACTIVEOLECONTROL_R(Self: TFORM; var T: TWINCONTROL); begin T := Self.ACTIVEOLECONTROL; +end; +procedure TFORMTILEMODE_W(Self: TFORM; T: TTILEMODE); begin Self.TILEMODE := T; end; +procedure TFORMTILEMODE_R(Self: TFORM; var T: TTILEMODE); begin T := Self.TILEMODE; end; +{$ENDIF}{CLX} +procedure TFORMACTIVEMDICHILD_R(Self: TFORM; var T: TFORM); begin T := Self.ACTIVEMDICHILD; end; +procedure TFORMDROPTARGET_W(Self: TFORM; T: BOOLEAN); begin Self.DROPTARGET := T; end; +procedure TFORMDROPTARGET_R(Self: TFORM; var T: BOOLEAN); begin T := Self.DROPTARGET; end; +procedure TFORMMDICHILDCOUNT_R(Self: TFORM; var T: INTEGER); begin T := Self.MDICHILDCOUNT; end; +procedure TFORMMDICHILDREN_R(Self: TFORM; var T: TFORM; t1: INTEGER); begin T := Self.MDICHILDREN[T1]; +end; +{$ENDIF}{FPC} + +procedure TFORMMODALRESULT_W(Self: TFORM; T: TMODALRESULT); begin Self.MODALRESULT := T; end; +procedure TFORMMODALRESULT_R(Self: TFORM; var T: TMODALRESULT); begin T := Self.MODALRESULT; end; +procedure TFORMACTIVE_R(Self: TFORM; var T: BOOLEAN); begin T := Self.ACTIVE; end; +procedure TFORMCANVAS_R(Self: TFORM; var T: TCANVAS); begin T := Self.CANVAS; end; +{$IFNDEF CLX} +procedure TFORMCLIENTHANDLE_R(Self: TFORM; var T: Longint); begin T := Self.CLIENTHANDLE; end; +{$ENDIF} + +{ Innerfuse Pascal Script Class Import Utility (runtime) } + +procedure RIRegisterTFORM(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TFORM) do + begin + {$IFDEF DELPHI4UP} + RegisterVirtualConstructor(@TFORM.CREATENEW, 'CREATENEW'); + {$ELSE} + RegisterConstructor(@TFORM.CREATENEW, 'CREATENEW'); + {$ENDIF} + RegisterMethod(@TFORM.CLOSE, 'CLOSE'); + RegisterMethod(@TFORM.HIDE, 'HIDE'); + RegisterMethod(@TFORM.SHOW, 'SHOW'); + RegisterMethod(@TFORM.SHOWMODAL, 'SHOWMODAL'); + RegisterMethod(@TFORM.RELEASE, 'RELEASE'); + RegisterPropertyHelper(@TFORMACTIVE_R, nil, 'ACTIVE'); + + {$IFNDEF PS_MINIVCL} + {$IFNDEF FPC} +{$IFNDEF CLX} + RegisterMethod(@TFORM.ARRANGEICONS, 'ARRANGEICONS'); + RegisterMethod(@TFORM.GETFORMIMAGE, 'GETFORMIMAGE'); + RegisterMethod(@TFORM.PRINT, 'PRINT'); + RegisterMethod(@TFORM.SENDCANCELMODE, 'SENDCANCELMODE'); + RegisterPropertyHelper(@TFORMACTIVEOLECONTROL_R, @TFORMACTIVEOLECONTROL_W, 'ACTIVEOLECONTROL'); + RegisterPropertyHelper(@TFORMCLIENTHANDLE_R, nil, 'CLIENTHANDLE'); + RegisterPropertyHelper(@TFORMTILEMODE_R, @TFORMTILEMODE_W, 'TILEMODE'); +{$ENDIF}{CLX} + RegisterMethod(@TFORM.CASCADE, 'CASCADE'); + RegisterMethod(@TFORM.NEXT, 'NEXT'); + RegisterMethod(@TFORM.PREVIOUS, 'PREVIOUS'); + RegisterMethod(@TFORM.TILE, 'TILE'); + RegisterPropertyHelper(@TFORMACTIVEMDICHILD_R, nil, 'ACTIVEMDICHILD'); + RegisterPropertyHelper(@TFORMDROPTARGET_R, @TFORMDROPTARGET_W, 'DROPTARGET'); + RegisterPropertyHelper(@TFORMMDICHILDCOUNT_R, nil, 'MDICHILDCOUNT'); + RegisterPropertyHelper(@TFORMMDICHILDREN_R, nil, 'MDICHILDREN'); + {$ENDIF}{FPC} + RegisterMethod(@TFORM.CLOSEQUERY, 'CLOSEQUERY'); + RegisterMethod(@TFORM.DEFOCUSCONTROL, 'DEFOCUSCONTROL'); + RegisterMethod(@TFORM.FOCUSCONTROL, 'FOCUSCONTROL'); + RegisterMethod(@TFORM.SETFOCUSEDCONTROL, 'SETFOCUSEDCONTROL'); + RegisterPropertyHelper(@TFORMCANVAS_R, nil, 'CANVAS'); + RegisterPropertyHelper(@TFORMMODALRESULT_R, @TFORMMODALRESULT_W, 'MODALRESULT'); + {$ENDIF}{PS_MINIVCL} + end; +end; + + {$IFNDEF FPC} +procedure TAPPLICATIONACTIVE_R(Self: TAPPLICATION; var T: BOOLEAN); begin T := Self.ACTIVE; end; +{$IFNDEF CLX} +procedure TAPPLICATIONDIALOGHANDLE_R(Self: TAPPLICATION; var T: Longint); begin T := Self.DIALOGHANDLE; end; +procedure TAPPLICATIONDIALOGHANDLE_W(Self: TAPPLICATION; T: Longint); begin Self.DIALOGHANDLE := T; end; +procedure TAPPLICATIONHANDLE_R(Self: TAPPLICATION; var T: Longint); begin T := Self.HANDLE; end; +procedure TAPPLICATIONHANDLE_W(Self: TAPPLICATION; T: Longint); begin Self.HANDLE := T; end; +procedure TAPPLICATIONUPDATEFORMATSETTINGS_R(Self: TAPPLICATION; var T: BOOLEAN); begin T := Self.UPDATEFORMATSETTINGS; end; +procedure TAPPLICATIONUPDATEFORMATSETTINGS_W(Self: TAPPLICATION; T: BOOLEAN); begin Self.UPDATEFORMATSETTINGS := T; end; +{$ENDIF} +{$ENDIF}{FPC} + + +procedure TAPPLICATIONEXENAME_R(Self: TAPPLICATION; var T: STRING); begin T := Self.EXENAME; end; +procedure TAPPLICATIONHELPFILE_R(Self: TAPPLICATION; var T: STRING); begin T := Self.HELPFILE; end; +procedure TAPPLICATIONHELPFILE_W(Self: TAPPLICATION; T: STRING); begin Self.HELPFILE := T; end; +procedure TAPPLICATIONHINT_R(Self: TAPPLICATION; var T: STRING); begin T := Self.HINT; end; +procedure TAPPLICATIONHINT_W(Self: TAPPLICATION; T: STRING); begin Self.HINT := T; end; +procedure TAPPLICATIONHINTCOLOR_R(Self: TAPPLICATION; var T: TCOLOR); begin T := Self.HINTCOLOR; end; +procedure TAPPLICATIONHINTCOLOR_W(Self: TAPPLICATION; T: TCOLOR); begin Self.HINTCOLOR := T; end; +procedure TAPPLICATIONHINTPAUSE_R(Self: TAPPLICATION; var T: INTEGER); begin T := Self.HINTPAUSE; end; +procedure TAPPLICATIONHINTPAUSE_W(Self: TAPPLICATION; T: INTEGER); begin Self.HINTPAUSE := T; end; +procedure TAPPLICATIONHINTSHORTPAUSE_R(Self: TAPPLICATION; var T: INTEGER); begin T := Self.HINTSHORTPAUSE; end; +procedure TAPPLICATIONHINTSHORTPAUSE_W(Self: TAPPLICATION; T: INTEGER); begin Self.HINTSHORTPAUSE := T; end; +procedure TAPPLICATIONHINTHIDEPAUSE_R(Self: TAPPLICATION; var T: INTEGER); begin T := Self.HINTHIDEPAUSE; end; +procedure TAPPLICATIONHINTHIDEPAUSE_W(Self: TAPPLICATION; T: INTEGER); begin Self.HINTHIDEPAUSE := T; end; +procedure TAPPLICATIONMAINFORM_R(Self: TAPPLICATION; var T: {$IFDEF DELPHI3UP}TCustomForm{$ELSE}TFORM{$ENDIF}); begin T := Self.MAINFORM; end; +procedure TAPPLICATIONSHOWHINT_R(Self: TAPPLICATION; var T: BOOLEAN); begin T := Self.SHOWHINT; end; +procedure TAPPLICATIONSHOWHINT_W(Self: TAPPLICATION; T: BOOLEAN); begin Self.SHOWHINT := T; end; +procedure TAPPLICATIONSHOWMAINFORM_R(Self: TAPPLICATION; var T: BOOLEAN); begin T := Self.SHOWMAINFORM; end; +procedure TAPPLICATIONSHOWMAINFORM_W(Self: TAPPLICATION; T: BOOLEAN); begin Self.SHOWMAINFORM := T; end; +procedure TAPPLICATIONTERMINATED_R(Self: TAPPLICATION; var T: BOOLEAN); begin T := Self.TERMINATED; end; +procedure TAPPLICATIONTITLE_R(Self: TAPPLICATION; var T: STRING); begin T := Self.TITLE; end; +procedure TAPPLICATIONTITLE_W(Self: TAPPLICATION; T: STRING); begin Self.TITLE := T; end; + +{$IFNDEF FPC} +procedure TAPPLICATIONONACTIVATE_R(Self: TAPPLICATION; var T: TNOTIFYEVENT); begin T := Self.ONACTIVATE; end; +procedure TAPPLICATIONONACTIVATE_W(Self: TAPPLICATION; T: TNOTIFYEVENT); begin Self.ONACTIVATE := T; end; +procedure TAPPLICATIONONDEACTIVATE_R(Self: TAPPLICATION; var T: TNOTIFYEVENT); begin T := Self.ONDEACTIVATE; end; +procedure TAPPLICATIONONDEACTIVATE_W(Self: TAPPLICATION; T: TNOTIFYEVENT); begin Self.ONDEACTIVATE := T; end; +{$ENDIF} + +procedure TAPPLICATIONONIDLE_R(Self: TAPPLICATION; var T: TIDLEEVENT); begin T := Self.ONIDLE; end; +procedure TAPPLICATIONONIDLE_W(Self: TAPPLICATION; T: TIDLEEVENT); begin Self.ONIDLE := T; end; +procedure TAPPLICATIONONHELP_R(Self: TAPPLICATION; var T: THELPEVENT); begin T := Self.ONHELP; end; +procedure TAPPLICATIONONHELP_W(Self: TAPPLICATION; T: THELPEVENT); begin Self.ONHELP := T; end; +procedure TAPPLICATIONONHINT_R(Self: TAPPLICATION; var T: TNOTIFYEVENT); begin T := Self.ONHINT; end; +procedure TAPPLICATIONONHINT_W(Self: TAPPLICATION; T: TNOTIFYEVENT); begin Self.ONHINT := T; end; + +{$IFNDEF FPC} +procedure TAPPLICATIONONMINIMIZE_R(Self: TAPPLICATION; var T: TNOTIFYEVENT); begin T := Self.ONMINIMIZE; end; +procedure TAPPLICATIONONMINIMIZE_W(Self: TAPPLICATION; T: TNOTIFYEVENT); begin Self.ONMINIMIZE := T; end; + +procedure TAPPLICATIONONRESTORE_R(Self: TAPPLICATION; var T: TNOTIFYEVENT); begin T := Self.ONRESTORE; end; +procedure TAPPLICATIONONRESTORE_W(Self: TAPPLICATION; T: TNOTIFYEVENT); begin Self.ONRESTORE := T; end; +{$ENDIF} + +procedure RIRegisterTAPPLICATION(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TAPPLICATION) do + begin + {$IFNDEF FPC} + RegisterMethod(@TAPPLICATION.MINIMIZE, 'MINIMIZE'); + RegisterMethod(@TAPPLICATION.RESTORE, 'RESTORE'); + RegisterPropertyHelper(@TAPPLICATIONACTIVE_R, nil, 'ACTIVE'); + RegisterPropertyHelper(@TAPPLICATIONONACTIVATE_R, @TAPPLICATIONONACTIVATE_W, 'ONACTIVATE'); + RegisterPropertyHelper(@TAPPLICATIONONDEACTIVATE_R, @TAPPLICATIONONDEACTIVATE_W, 'ONDEACTIVATE'); + RegisterPropertyHelper(@TAPPLICATIONONMINIMIZE_R, @TAPPLICATIONONMINIMIZE_W, 'ONMINIMIZE'); + RegisterPropertyHelper(@TAPPLICATIONONRESTORE_R, @TAPPLICATIONONRESTORE_W, 'ONRESTORE'); + RegisterPropertyHelper(@TAPPLICATIONDIALOGHANDLE_R, @TAPPLICATIONDIALOGHANDLE_W, 'DIALOGHANDLE'); + RegisterMethod(@TAPPLICATION.CREATEHANDLE, 'CREATEHANDLE'); + RegisterMethod(@TAPPLICATION.NORMALIZETOPMOSTS, 'NORMALIZETOPMOSTS'); + RegisterMethod(@TAPPLICATION.RESTORETOPMOSTS, 'RESTORETOPMOSTS'); + {$IFNDEF CLX} + RegisterPropertyHelper(@TAPPLICATIONHANDLE_R, @TAPPLICATIONHANDLE_W, 'HANDLE'); + RegisterPropertyHelper(@TAPPLICATIONUPDATEFORMATSETTINGS_R, @TAPPLICATIONUPDATEFORMATSETTINGS_W, 'UPDATEFORMATSETTINGS'); + {$ENDIF} + {$ENDIF} + RegisterMethod(@TAPPLICATION.BRINGTOFRONT, 'BRINGTOFRONT'); + RegisterMethod(@TAPPLICATION.MESSAGEBOX, 'MESSAGEBOX'); + RegisterMethod(@TAPPLICATION.PROCESSMESSAGES, 'PROCESSMESSAGES'); + RegisterMethod(@TAPPLICATION.TERMINATE, 'TERMINATE'); + RegisterPropertyHelper(@TAPPLICATIONEXENAME_R, nil, 'EXENAME'); + RegisterPropertyHelper(@TAPPLICATIONHINT_R, @TAPPLICATIONHINT_W, 'HINT'); + RegisterPropertyHelper(@TAPPLICATIONMAINFORM_R, nil, 'MAINFORM'); + RegisterPropertyHelper(@TAPPLICATIONSHOWHINT_R, @TAPPLICATIONSHOWHINT_W, 'SHOWHINT'); + RegisterPropertyHelper(@TAPPLICATIONSHOWMAINFORM_R, @TAPPLICATIONSHOWMAINFORM_W, 'SHOWMAINFORM'); + RegisterPropertyHelper(@TAPPLICATIONTERMINATED_R, nil, 'TERMINATED'); + RegisterPropertyHelper(@TAPPLICATIONTITLE_R, @TAPPLICATIONTITLE_W, 'TITLE'); + RegisterPropertyHelper(@TAPPLICATIONONIDLE_R, @TAPPLICATIONONIDLE_W, 'ONIDLE'); + RegisterPropertyHelper(@TAPPLICATIONONHINT_R, @TAPPLICATIONONHINT_W, 'ONHINT'); + {$IFNDEF PS_MINIVCL} + RegisterMethod(@TAPPLICATION.CONTROLDESTROYED, 'CONTROLDESTROYED'); + RegisterMethod(@TAPPLICATION.CANCELHINT, 'CANCELHINT'); + {$IFNDEF CLX} + {$IFNDEF FPC} + RegisterMethod(@TAPPLICATION.HELPCOMMAND, 'HELPCOMMAND'); + {$ENDIF} + RegisterMethod(@TAPPLICATION.HELPCONTEXT, 'HELPCONTEXT'); + {$IFNDEF FPC} + RegisterMethod(@TAPPLICATION.HELPJUMP, 'HELPJUMP'); + {$ENDIF} + {$ENDIF} +// RegisterMethod(@TAPPLICATION.HANDLEEXCEPTION, 'HANDLEEXCEPTION'); +// RegisterMethod(@TAPPLICATION.HOOKMAINWINDOW, 'HOOKMAINWINDOW'); +// RegisterMethod(@TAPPLICATION.UNHOOKMAINWINDOW, 'UNHOOKMAINWINDOW'); + + RegisterMethod(@TAPPLICATION.HANDLEMESSAGE, 'HANDLEMESSAGE'); + RegisterMethod(@TAPPLICATION.HIDEHINT, 'HIDEHINT'); + RegisterMethod(@TAPPLICATION.HINTMOUSEMESSAGE, 'HINTMOUSEMESSAGE'); + RegisterMethod(@TAPPLICATION.INITIALIZE, 'INITIALIZE'); + RegisterMethod(@TAPPLICATION.RUN, 'RUN'); +// RegisterMethod(@TAPPLICATION.SHOWEXCEPTION, 'SHOWEXCEPTION'); + RegisterPropertyHelper(@TAPPLICATIONHELPFILE_R, @TAPPLICATIONHELPFILE_W, 'HELPFILE'); + RegisterPropertyHelper(@TAPPLICATIONHINTCOLOR_R, @TAPPLICATIONHINTCOLOR_W, 'HINTCOLOR'); + RegisterPropertyHelper(@TAPPLICATIONHINTPAUSE_R, @TAPPLICATIONHINTPAUSE_W, 'HINTPAUSE'); + RegisterPropertyHelper(@TAPPLICATIONHINTSHORTPAUSE_R, @TAPPLICATIONHINTSHORTPAUSE_W, 'HINTSHORTPAUSE'); + RegisterPropertyHelper(@TAPPLICATIONHINTHIDEPAUSE_R, @TAPPLICATIONHINTHIDEPAUSE_W, 'HINTHIDEPAUSE'); + RegisterPropertyHelper(@TAPPLICATIONONHELP_R, @TAPPLICATIONONHELP_W, 'ONHELP'); + {$ENDIF} + end; +end; + +procedure RIRegister_Forms(Cl: TPSRuntimeClassImporter); +begin + {$IFNDEF PS_MINIVCL} + RIRegisterTCONTROLSCROLLBAR(cl); + RIRegisterTSCROLLBOX(cl); + {$ENDIF} +{$IFNDEF FPC} RIRegisterTScrollingWinControl(cl);{$ENDIF} + RIRegisterTForm(Cl); + {$IFNDEF PS_MINIVCL} + RIRegisterTApplication(Cl); + {$ENDIF} +end; + + +// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl) +// FPC changes by Boguslaw brandys (brandys at o2 _dot_ pl) + +end. + + + + + diff --git a/Units/PascalScript/uPSR_graphics.pas b/Units/PascalScript/uPSR_graphics.pas new file mode 100644 index 0000000..7a7643a --- /dev/null +++ b/Units/PascalScript/uPSR_graphics.pas @@ -0,0 +1,218 @@ + +unit uPSR_graphics; +{$I PascalScript.inc} +interface +uses + uPSRuntime, uPSUtils; + + + +procedure RIRegisterTGRAPHICSOBJECT(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTFont(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTPEN(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTBRUSH(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTCanvas(cl: TPSRuntimeClassImporter); +procedure RIRegisterTGraphic(CL: TPSRuntimeClassImporter); +procedure RIRegisterTBitmap(CL: TPSRuntimeClassImporter; Streams: Boolean); + +procedure RIRegister_Graphics(Cl: TPSRuntimeClassImporter; Streams: Boolean); + +implementation +{$IFNDEF FPC} +uses + Classes{$IFDEF CLX}, QGraphics{$ELSE}, Windows, Graphics{$ENDIF}; +{$ELSE} +uses + Classes, Graphics,LCLType; +{$ENDIF} + +{$IFNDEF CLX} +procedure TFontHandleR(Self: TFont; var T: Longint); begin T := Self.Handle; end; +procedure TFontHandleW(Self: TFont; T: Longint); begin Self.Handle := T; end; +{$ENDIF} +procedure TFontPixelsPerInchR(Self: TFont; var T: Longint); begin T := Self.PixelsPerInch; end; +procedure TFontPixelsPerInchW(Self: TFont; T: Longint); begin {$IFNDEF FPC} Self.PixelsPerInch := T;{$ENDIF} end; +procedure TFontStyleR(Self: TFont; var T: TFontStyles); begin T := Self.Style; end; +procedure TFontStyleW(Self: TFont; T: TFontStyles); begin Self.Style:= T; end; + +procedure RIRegisterTFont(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TFont) do + begin + RegisterConstructor(@TFont.Create, 'CREATE'); +{$IFNDEF CLX} + RegisterPropertyHelper(@TFontHandleR, @TFontHandleW, 'HANDLE'); +{$ENDIF} + RegisterPropertyHelper(@TFontPixelsPerInchR, @TFontPixelsPerInchW, 'PIXELSPERINCH'); + RegisterPropertyHelper(@TFontStyleR, @TFontStyleW, 'STYLE'); + end; +end; +{$IFNDEF CLX} +procedure TCanvasHandleR(Self: TCanvas; var T: Longint); begin T := Self.Handle; end; +procedure TCanvasHandleW(Self: TCanvas; T: Longint); begin Self.Handle:= T; end; +{$ENDIF} + +procedure TCanvasPixelsR(Self: TCanvas; var T: Longint; X,Y: Longint); begin T := Self.Pixels[X,Y]; end; +procedure TCanvasPixelsW(Self: TCanvas; T, X, Y: Longint); begin Self.Pixels[X,Y]:= T; end; + +procedure RIRegisterTCanvas(cl: TPSRuntimeClassImporter); // requires TPersistent +begin + with Cl.Add(TCanvas) do + begin +{$IFNDEF FPC} + RegisterMethod(@TCanvas.Arc, 'ARC'); + RegisterMethod(@TCanvas.Chord, 'CHORD'); + RegisterMethod(@TCanvas.Rectangle, 'RECTANGLE'); + RegisterMethod(@TCanvas.RoundRect, 'ROUNDRECT'); + RegisterMethod(@TCanvas.Ellipse, 'ELLIPSE'); + RegisterMethod(@TCanvas.FillRect, 'FILLRECT'); +{$ENDIF} + RegisterMethod(@TCanvas.Draw, 'DRAW'); +{$IFNDEF CLX} + RegisterMethod(@TCanvas.FloodFill, 'FLOODFILL'); +{$ENDIF} + RegisterMethod(@TCanvas.Lineto, 'LINETO'); + RegisterMethod(@TCanvas.Moveto, 'MOVETO'); + RegisterMethod(@TCanvas.Pie, 'PIE'); + RegisterMethod(@TCanvas.Refresh, 'REFRESH'); + RegisterMethod(@TCanvas.TextHeight, 'TEXTHEIGHT'); + RegisterMethod(@TCanvas.TextOut, 'TEXTOUT'); + RegisterMethod(@TCanvas.TextWidth, 'TEXTWIDTH'); +{$IFNDEF CLX} + RegisterPropertyHelper(@TCanvasHandleR, @TCanvasHandleW, 'HANDLE'); +{$ENDIF} + RegisterPropertyHelper(@TCanvasPixelsR, @TCanvasPixelsW, 'PIXELS'); + end; +end; + + +procedure TGRAPHICSOBJECTONCHANGE_W(Self: TGraphicsObject; T: TNotifyEvent); begin Self.OnChange := t; end; +procedure TGRAPHICSOBJECTONCHANGE_R(Self: TGraphicsObject; var T: TNotifyEvent); begin T :=Self.OnChange; end; + + +procedure RIRegisterTGRAPHICSOBJECT(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TGRAPHICSOBJECT) do + begin + RegisterPropertyHelper(@TGRAPHICSOBJECTONCHANGE_R, @TGRAPHICSOBJECTONCHANGE_W, 'ONCHANGE'); + end; +end; + +procedure RIRegisterTPEN(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TPEN) do + begin + RegisterConstructor(@TPEN.CREATE, 'CREATE'); + end; +end; + +procedure RIRegisterTBRUSH(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TBRUSH) do + begin + RegisterConstructor(@TBRUSH.CREATE, 'CREATE'); + end; +end; + +procedure TGraphicOnChange_W(Self: TGraphic; const T: TNotifyEvent); begin Self.OnChange := T; end; +procedure TGraphicOnChange_R(Self: TGraphic; var T: TNotifyEvent); begin T := Self.OnChange; end; +procedure TGraphicWidth_W(Self: TGraphic; const T: Integer); begin Self.Width := T; end; +procedure TGraphicWidth_R(Self: TGraphic; var T: Integer); begin T := Self.Width; end; +procedure TGraphicModified_W(Self: TGraphic; const T: Boolean); begin Self.Modified := T; end; +procedure TGraphicModified_R(Self: TGraphic; var T: Boolean); begin T := Self.Modified; end; +procedure TGraphicHeight_W(Self: TGraphic; const T: Integer); begin Self.Height := T; end; +procedure TGraphicHeight_R(Self: TGraphic; var T: Integer); begin T := Self.Height; end; +procedure TGraphicEmpty_R(Self: TGraphic; var T: Boolean); begin T := Self.Empty; end; + +procedure RIRegisterTGraphic(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TGraphic) do + begin + RegisterVirtualConstructor(@TGraphic.Create, 'Create'); + RegisterVirtualMethod(@TGraphic.LoadFromFile, 'LoadFromFile'); + RegisterVirtualMethod(@TGraphic.SaveToFile, 'SaveToFile'); + RegisterPropertyHelper(@TGraphicEmpty_R,nil,'Empty'); + RegisterPropertyHelper(@TGraphicHeight_R,@TGraphicHeight_W,'Height'); + RegisterPropertyHelper(@TGraphicWidth_R,@TGraphicWidth_W,'Width'); + RegisterPropertyHelper(@TGraphicOnChange_R,@TGraphicOnChange_W,'OnChange'); + + {$IFNDEF PS_MINIVCL} + RegisterPropertyHelper(@TGraphicModified_R,@TGraphicModified_W,'Modified'); + {$ENDIF} + end; +end; + +procedure TBitmapTransparentColor_R(Self: TBitmap; var T: TColor); begin T := Self.TransparentColor; end; +{$IFNDEF CLX} +{$IFNDEF FPC} +procedure TBitmapIgnorePalette_W(Self: TBitmap; const T: Boolean); begin Self.IgnorePalette := T; end; +procedure TBitmapIgnorePalette_R(Self: TBitmap; var T: Boolean); begin T := Self.IgnorePalette; end; +{$ENDIF} +procedure TBitmapPalette_W(Self: TBitmap; const T: HPALETTE); begin Self.Palette := T; end; +procedure TBitmapPalette_R(Self: TBitmap; var T: HPALETTE); begin T := Self.Palette; end; +{$ENDIF} +procedure TBitmapMonochrome_W(Self: TBitmap; const T: Boolean); begin Self.Monochrome := T; end; +procedure TBitmapMonochrome_R(Self: TBitmap; var T: Boolean); begin T := Self.Monochrome; end; +{$IFNDEF CLX} +procedure TBitmapHandle_W(Self: TBitmap; const T: HBITMAP); begin Self.Handle := T; end; +procedure TBitmapHandle_R(Self: TBitmap; var T: HBITMAP); begin T := Self.Handle; end; +{$ENDIF} +procedure TBitmapCanvas_R(Self: TBitmap; var T: TCanvas); begin T := Self.Canvas; end; + +procedure RIRegisterTBitmap(CL: TPSRuntimeClassImporter; Streams: Boolean); +begin + with CL.Add(TBitmap) do + begin + if Streams then begin + RegisterMethod(@TBitmap.LoadFromStream, 'LoadFromStream'); + RegisterMethod(@TBitmap.SaveToStream, 'SaveToStream'); + end; + RegisterPropertyHelper(@TBitmapCanvas_R,nil,'Canvas'); +{$IFNDEF CLX} + RegisterPropertyHelper(@TBitmapHandle_R,@TBitmapHandle_W,'Handle'); +{$ENDIF} + + {$IFNDEF PS_MINIVCL} +{$IFNDEF FPC} + RegisterMethod(@TBitmap.Dormant, 'Dormant'); +{$ENDIF} + RegisterMethod(@TBitmap.FreeImage, 'FreeImage'); +{$IFNDEF CLX} + RegisterMethod(@TBitmap.LoadFromClipboardFormat, 'LoadFromClipboardFormat'); +{$ENDIF} + RegisterMethod(@TBitmap.LoadFromResourceName, 'LoadFromResourceName'); + RegisterMethod(@TBitmap.LoadFromResourceID, 'LoadFromResourceID'); +{$IFNDEF CLX} + RegisterMethod(@TBitmap.ReleaseHandle, 'ReleaseHandle'); + RegisterMethod(@TBitmap.ReleasePalette, 'ReleasePalette'); + RegisterMethod(@TBitmap.SaveToClipboardFormat, 'SaveToClipboardFormat'); + RegisterPropertyHelper(@TBitmapMonochrome_R,@TBitmapMonochrome_W,'Monochrome'); + RegisterPropertyHelper(@TBitmapPalette_R,@TBitmapPalette_W,'Palette'); +{$IFNDEF FPC} + RegisterPropertyHelper(@TBitmapIgnorePalette_R,@TBitmapIgnorePalette_W,'IgnorePalette'); +{$ENDIF} +{$ENDIF} + RegisterPropertyHelper(@TBitmapTransparentColor_R,nil,'TransparentColor'); + {$ENDIF} + end; +end; + +procedure RIRegister_Graphics(Cl: TPSRuntimeClassImporter; Streams: Boolean); +begin + RIRegisterTGRAPHICSOBJECT(cl); + RIRegisterTFont(Cl); + RIRegisterTCanvas(cl); + RIRegisterTPEN(cl); + RIRegisterTBRUSH(cl); + RIRegisterTGraphic(CL); + RIRegisterTBitmap(CL, Streams); +end; + +// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl) + +end. + + + + + diff --git a/Units/PascalScript/uPSR_menus.pas b/Units/PascalScript/uPSR_menus.pas new file mode 100644 index 0000000..a4b4206 --- /dev/null +++ b/Units/PascalScript/uPSR_menus.pas @@ -0,0 +1,460 @@ + +Unit uPSR_menus; +{$I PascalScript.inc} +Interface +Uses uPSRuntime; + +procedure RIRegister_Menus_Routines(S: TPSExec); +{$IFNDEF FPC} +procedure RIRegisterTMENUITEMSTACK(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTPOPUPLIST(Cl: TPSRuntimeClassImporter); +{$ENDIF} +procedure RIRegisterTPOPUPMENU(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTMAINMENU(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTMENU(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTMENUITEM(Cl: TPSRuntimeClassImporter); +procedure RIRegister_Menus(CL: TPSRuntimeClassImporter); + +implementation +{$IFDEF LINUX} +{$IFNDEF FPC} +Uses + Libc, SysUtils, Classes, QControls, QMenus, QGraphics; +{$ELSE} +Uses + Libc, SysUtils, Classes, Controls, Menus, Graphics, LCLType, ImgList; +{$ENDIF} +{$ELSE} +Uses {$IFNDEF FPC}WINDOWS,{$ELSE} LCLType,{$ENDIF} SYSUTILS, CLASSES, CONTNRS, MESSAGES, GRAPHICS, IMGLIST, ACTNLIST, Menus; +{$ENDIF} + + +{$IFNDEF FPC} +procedure TPOPUPLISTWINDOW_R(Self: TPOPUPLIST; var T: HWND); +begin T := Self.WINDOW; end; +{$ENDIF} + +procedure TPOPUPMENUONPOPUP_W(Self: TPOPUPMENU; const T: TNOTIFYEVENT); +begin Self.ONPOPUP := T; end; + +procedure TPOPUPMENUONPOPUP_R(Self: TPOPUPMENU; var T: TNOTIFYEVENT); +begin T := Self.ONPOPUP; end; + +{$IFNDEF FPC} +procedure TPOPUPMENUTRACKBUTTON_W(Self: TPOPUPMENU; const T: TTRACKBUTTON); +begin Self.TRACKBUTTON := T; end; + +procedure TPOPUPMENUTRACKBUTTON_R(Self: TPOPUPMENU; var T: TTRACKBUTTON); +begin T := Self.TRACKBUTTON; end; + + +procedure TPOPUPMENUMENUANIMATION_W(Self: TPOPUPMENU; const T: TMENUANIMATION); +begin Self.MENUANIMATION := T; end; + +procedure TPOPUPMENUMENUANIMATION_R(Self: TPOPUPMENU; var T: TMENUANIMATION); +begin T := Self.MENUANIMATION; end; + +procedure TPOPUPMENUHELPCONTEXT_W(Self: TPOPUPMENU; const T: THELPCONTEXT); +begin Self.HELPCONTEXT := T; end; + +procedure TPOPUPMENUHELPCONTEXT_R(Self: TPOPUPMENU; var T: THELPCONTEXT); +begin T := Self.HELPCONTEXT; end; +{$ENDIF} + +procedure TPOPUPMENUAUTOPOPUP_W(Self: TPOPUPMENU; const T: BOOLEAN); +begin Self.AUTOPOPUP := T; end; + +procedure TPOPUPMENUAUTOPOPUP_R(Self: TPOPUPMENU; var T: BOOLEAN); +begin T := Self.AUTOPOPUP; end; + +{$IFNDEF FPC} +procedure TPOPUPMENUALIGNMENT_W(Self: TPOPUPMENU; const T: TPOPUPALIGNMENT); +begin Self.ALIGNMENT := T; end; + +procedure TPOPUPMENUALIGNMENT_R(Self: TPOPUPMENU; var T: TPOPUPALIGNMENT); +begin T := Self.ALIGNMENT; end; +{$ENDIF} + +procedure TPOPUPMENUPOPUPCOMPONENT_W(Self: TPOPUPMENU; const T: TCOMPONENT); +begin Self.POPUPCOMPONENT := T; end; + +procedure TPOPUPMENUPOPUPCOMPONENT_R(Self: TPOPUPMENU; var T: TCOMPONENT); +begin T := Self.POPUPCOMPONENT; end; + +{$IFNDEF FPC} +procedure TMAINMENUAUTOMERGE_W(Self: TMAINMENU; const T: BOOLEAN); +begin Self.AUTOMERGE := T; end; + +procedure TMAINMENUAUTOMERGE_R(Self: TMAINMENU; var T: BOOLEAN); +begin T := Self.AUTOMERGE; end; +{$ENDIF} + +procedure TMENUITEMS_R(Self: TMENU; var T: TMENUITEM); +begin T := Self.ITEMS; end; + + +{$IFNDEF FPC} +procedure TMENUWINDOWHANDLE_W(Self: TMENU; const T: HWND); +begin Self.WINDOWHANDLE := T; end; + +procedure TMENUWINDOWHANDLE_R(Self: TMENU; var T: HWND); +begin T := Self.WINDOWHANDLE; end; + +procedure TMENUPARENTBIDIMODE_W(Self: TMENU; const T: BOOLEAN); +begin Self.PARENTBIDIMODE := T; end; + +procedure TMENUPARENTBIDIMODE_R(Self: TMENU; var T: BOOLEAN); +begin T := Self.PARENTBIDIMODE; end; + +procedure TMENUOWNERDRAW_W(Self: TMENU; const T: BOOLEAN); +begin Self.OWNERDRAW := T; end; + +procedure TMENUOWNERDRAW_R(Self: TMENU; var T: BOOLEAN); +begin T := Self.OWNERDRAW; end; + +procedure TMENUBIDIMODE_W(Self: TMENU; const T: TBIDIMODE); +begin Self.BIDIMODE := T; end; + +procedure TMENUBIDIMODE_R(Self: TMENU; var T: TBIDIMODE); +begin T := Self.BIDIMODE; end; + +procedure TMENUAUTOLINEREDUCTION_W(Self: TMENU; const T: TMENUAUTOFLAG); +begin Self.AUTOLINEREDUCTION := T; end; + +procedure TMENUAUTOLINEREDUCTION_R(Self: TMENU; var T: TMENUAUTOFLAG); +begin T := Self.AUTOLINEREDUCTION; end; + +procedure TMENUAUTOHOTKEYS_W(Self: TMENU; const T: TMENUAUTOFLAG); +begin Self.AUTOHOTKEYS := T; end; + +procedure TMENUAUTOHOTKEYS_R(Self: TMENU; var T: TMENUAUTOFLAG); +begin T := Self.AUTOHOTKEYS; end; + +{$ENDIF} + + +procedure TMENUHANDLE_R(Self: TMENU; var T: HMENU); +begin T := Self.HANDLE; end; + + + + +procedure TMENUIMAGES_W(Self: TMENU; const T: TCUSTOMIMAGELIST); +begin Self.IMAGES := T; end; + +procedure TMENUIMAGES_R(Self: TMENU; var T: TCUSTOMIMAGELIST); +begin T := Self.IMAGES; end; + +{$IFNDEF FPC} +procedure TMENUITEMONMEASUREITEM_W(Self: TMENUITEM; const T: TMENUMEASUREITEMEVENT); +begin Self.ONMEASUREITEM := T; end; + +procedure TMENUITEMONMEASUREITEM_R(Self: TMENUITEM; var T: TMENUMEASUREITEMEVENT); +begin T := Self.ONMEASUREITEM; end; + +procedure TMENUITEMONADVANCEDDRAWITEM_W(Self: TMENUITEM; const T: TADVANCEDMENUDRAWITEMEVENT); +begin Self.ONADVANCEDDRAWITEM := T; end; + +procedure TMENUITEMONADVANCEDDRAWITEM_R(Self: TMENUITEM; var T: TADVANCEDMENUDRAWITEMEVENT); +begin T := Self.ONADVANCEDDRAWITEM; end; + +procedure TMENUITEMONDRAWITEM_W(Self: TMENUITEM; const T: TMENUDRAWITEMEVENT); +begin Self.ONDRAWITEM := T; end; + +procedure TMENUITEMONDRAWITEM_R(Self: TMENUITEM; var T: TMENUDRAWITEMEVENT); +begin T := Self.ONDRAWITEM; end; +{$ENDIF} + +procedure TMENUITEMONCLICK_W(Self: TMENUITEM; const T: TNOTIFYEVENT); +begin Self.ONCLICK := T; end; + +procedure TMENUITEMONCLICK_R(Self: TMENUITEM; var T: TNOTIFYEVENT); +begin T := Self.ONCLICK; end; + +procedure TMENUITEMVISIBLE_W(Self: TMENUITEM; const T: BOOLEAN); +begin Self.VISIBLE := T; end; + +procedure TMENUITEMVISIBLE_R(Self: TMENUITEM; var T: BOOLEAN); +begin T := Self.VISIBLE; end; + +procedure TMENUITEMSHORTCUT_W(Self: TMENUITEM; const T: TSHORTCUT); +begin Self.SHORTCUT := T; end; + +procedure TMENUITEMSHORTCUT_R(Self: TMENUITEM; var T: TSHORTCUT); +begin T := Self.SHORTCUT; end; + +procedure TMENUITEMRADIOITEM_W(Self: TMENUITEM; const T: BOOLEAN); +begin Self.RADIOITEM := T; end; + +procedure TMENUITEMRADIOITEM_R(Self: TMENUITEM; var T: BOOLEAN); +begin T := Self.RADIOITEM; end; + +procedure TMENUITEMIMAGEINDEX_W(Self: TMENUITEM; const T: TIMAGEINDEX); +begin Self.IMAGEINDEX := T; end; + +procedure TMENUITEMIMAGEINDEX_R(Self: TMENUITEM; var T: TIMAGEINDEX); +begin T := Self.IMAGEINDEX; end; + +procedure TMENUITEMHINT_W(Self: TMENUITEM; const T: STRING); +begin Self.HINT := T; end; + +procedure TMENUITEMHINT_R(Self: TMENUITEM; var T: STRING); +begin T := Self.HINT; end; + +procedure TMENUITEMHELPCONTEXT_W(Self: TMENUITEM; const T: THELPCONTEXT); +begin Self.HELPCONTEXT := T; end; + +procedure TMENUITEMHELPCONTEXT_R(Self: TMENUITEM; var T: THELPCONTEXT); +begin T := Self.HELPCONTEXT; end; + +procedure TMENUITEMGROUPINDEX_W(Self: TMENUITEM; const T: BYTE); +begin Self.GROUPINDEX := T; end; + +procedure TMENUITEMGROUPINDEX_R(Self: TMENUITEM; var T: BYTE); +begin T := Self.GROUPINDEX; end; + +procedure TMENUITEMENABLED_W(Self: TMENUITEM; const T: BOOLEAN); +begin Self.ENABLED := T; end; + +procedure TMENUITEMENABLED_R(Self: TMENUITEM; var T: BOOLEAN); +begin T := Self.ENABLED; end; + +procedure TMENUITEMDEFAULT_W(Self: TMENUITEM; const T: BOOLEAN); +begin Self.DEFAULT := T; end; + +procedure TMENUITEMDEFAULT_R(Self: TMENUITEM; var T: BOOLEAN); +begin T := Self.DEFAULT; end; + +procedure TMENUITEMSUBMENUIMAGES_W(Self: TMENUITEM; const T: TCUSTOMIMAGELIST); +begin Self.SUBMENUIMAGES := T; end; + +procedure TMENUITEMSUBMENUIMAGES_R(Self: TMENUITEM; var T: TCUSTOMIMAGELIST); +begin T := Self.SUBMENUIMAGES; end; + +procedure TMENUITEMCHECKED_W(Self: TMENUITEM; const T: BOOLEAN); +begin Self.CHECKED := T; end; + +procedure TMENUITEMCHECKED_R(Self: TMENUITEM; var T: BOOLEAN); +begin T := Self.CHECKED; end; + +procedure TMENUITEMCAPTION_W(Self: TMENUITEM; const T: STRING); +begin Self.CAPTION := T; end; + +procedure TMENUITEMCAPTION_R(Self: TMENUITEM; var T: STRING); +begin T := Self.CAPTION; end; + +procedure TMENUITEMBITMAP_W(Self: TMENUITEM; const T: TBITMAP); +begin Self.BITMAP := T; end; + +procedure TMENUITEMBITMAP_R(Self: TMENUITEM; var T: TBITMAP); +begin T := Self.BITMAP; end; + +{$IFNDEF FPC} +procedure TMENUITEMAUTOLINEREDUCTION_W(Self: TMENUITEM; const T: TMENUITEMAUTOFLAG); +begin Self.AUTOLINEREDUCTION := T; end; + +procedure TMENUITEMAUTOLINEREDUCTION_R(Self: TMENUITEM; var T: TMENUITEMAUTOFLAG); +begin T := Self.AUTOLINEREDUCTION; end; + +procedure TMENUITEMAUTOHOTKEYS_W(Self: TMENUITEM; const T: TMENUITEMAUTOFLAG); +begin Self.AUTOHOTKEYS := T; end; + +procedure TMENUITEMAUTOHOTKEYS_R(Self: TMENUITEM; var T: TMENUITEMAUTOFLAG); +begin T := Self.AUTOHOTKEYS; end; +{$ENDIF} + +procedure TMENUITEMACTION_W(Self: TMENUITEM; const T: TBASICACTION); +begin Self.ACTION := T; end; + +procedure TMENUITEMACTION_R(Self: TMENUITEM; var T: TBASICACTION); +begin T := Self.ACTION; end; + +procedure TMENUITEMPARENT_R(Self: TMENUITEM; var T: TMENUITEM); +begin T := Self.PARENT; end; + +procedure TMENUITEMMENUINDEX_W(Self: TMENUITEM; const T: INTEGER); +begin Self.MENUINDEX := T; end; + +procedure TMENUITEMMENUINDEX_R(Self: TMENUITEM; var T: INTEGER); +begin T := Self.MENUINDEX; end; + +procedure TMENUITEMITEMS_R(Self: TMENUITEM; var T: TMENUITEM; const t1: INTEGER); +begin T := Self.ITEMS[t1]; end; + +procedure TMENUITEMCOUNT_R(Self: TMENUITEM; var T: INTEGER); +begin T := Self.COUNT; end; + +procedure TMENUITEMHANDLE_R(Self: TMENUITEM; var T: HMENU); +begin T := Self.HANDLE; end; + +procedure TMENUITEMCOMMAND_R(Self: TMENUITEM; var T: WORD); +begin T := Self.COMMAND; end; + +procedure RIRegister_Menus_Routines(S: TPSExec); +begin + S.RegisterDelphiFunction(@SHORTCUT, 'SHORTCUT', cdRegister); + S.RegisterDelphiFunction(@SHORTCUTTOKEY, 'SHORTCUTTOKEY', cdRegister); +{$IFNDEF FPC} + S.RegisterDelphiFunction(@SHORTCUTTOTEXT, 'SHORTCUTTOTEXT', cdRegister); + S.RegisterDelphiFunction(@TEXTTOSHORTCUT, 'TEXTTOSHORTCUT', cdRegister); + S.RegisterDelphiFunction(@NEWMENU, 'NEWMENU', cdRegister); + S.RegisterDelphiFunction(@NEWPOPUPMENU, 'NEWPOPUPMENU', cdRegister); + S.RegisterDelphiFunction(@NEWSUBMENU, 'NEWSUBMENU', cdRegister); + S.RegisterDelphiFunction(@NEWITEM, 'NEWITEM', cdRegister); + S.RegisterDelphiFunction(@NEWLINE, 'NEWLINE', cdRegister); + S.RegisterDelphiFunction(@DRAWMENUITEM, 'DRAWMENUITEM', cdRegister); +{$ENDIF} +end; + +{$IFNDEF FPC} +procedure RIRegisterTMENUITEMSTACK(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TMENUITEMSTACK) do + begin + RegisterMethod(@TMENUITEMSTACK.CLEARITEM, 'CLEARITEM'); + end; +end; + +procedure RIRegisterTPOPUPLIST(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TPOPUPLIST) do + begin + RegisterPropertyHelper(@TPOPUPLISTWINDOW_R,nil,'WINDOW'); + RegisterMethod(@TPOPUPLIST.ADD, 'ADD'); + RegisterMethod(@TPOPUPLIST.REMOVE, 'REMOVE'); + end; +end; +{$ENDIF} + + +procedure RIRegisterTPOPUPMENU(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TPOPUPMENU) do + begin + RegisterConstructor(@TPOPUPMENU.CREATE, 'CREATE'); + RegisterVirtualMethod(@TPOPUPMENU.POPUP, 'POPUP'); + RegisterPropertyHelper(@TPOPUPMENUPOPUPCOMPONENT_R,@TPOPUPMENUPOPUPCOMPONENT_W,'POPUPCOMPONENT'); + RegisterEventPropertyHelper(@TPOPUPMENUONPOPUP_R,@TPOPUPMENUONPOPUP_W,'ONPOPUP'); +{$IFNDEF FPC} + RegisterPropertyHelper(@TPOPUPMENUALIGNMENT_R,@TPOPUPMENUALIGNMENT_W,'ALIGNMENT'); + RegisterPropertyHelper(@TPOPUPMENUAUTOPOPUP_R,@TPOPUPMENUAUTOPOPUP_W,'AUTOPOPUP'); + RegisterPropertyHelper(@TPOPUPMENUHELPCONTEXT_R,@TPOPUPMENUHELPCONTEXT_W,'HELPCONTEXT'); + RegisterPropertyHelper(@TPOPUPMENUMENUANIMATION_R,@TPOPUPMENUMENUANIMATION_W,'MENUANIMATION'); + RegisterPropertyHelper(@TPOPUPMENUTRACKBUTTON_R,@TPOPUPMENUTRACKBUTTON_W,'TRACKBUTTON'); +{$ENDIF} + end; +end; + +procedure RIRegisterTMAINMENU(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TMAINMENU) do + begin +{$IFNDEF FPC} + RegisterMethod(@TMAINMENU.MERGE, 'MERGE'); + RegisterMethod(@TMAINMENU.UNMERGE, 'UNMERGE'); + RegisterMethod(@TMAINMENU.POPULATEOLE2MENU, 'POPULATEOLE2MENU'); + RegisterMethod(@TMAINMENU.GETOLE2ACCELERATORTABLE, 'GETOLE2ACCELERATORTABLE'); + RegisterMethod(@TMAINMENU.SETOLE2MENUHANDLE, 'SETOLE2MENUHANDLE'); + RegisterPropertyHelper(@TMAINMENUAUTOMERGE_R,@TMAINMENUAUTOMERGE_W,'AUTOMERGE'); +{$ENDIF} + end; +end; + + +procedure RIRegisterTMENU(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TMENU) do + begin + RegisterConstructor(@TMENU.CREATE, 'CREATE'); + RegisterMethod(@TMENU.DISPATCHCOMMAND, 'DISPATCHCOMMAND'); + RegisterMethod(@TMENU.FINDITEM, 'FINDITEM'); + RegisterPropertyHelper(@TMENUIMAGES_R,@TMENUIMAGES_W,'IMAGES'); + RegisterMethod(@TMENU.ISRIGHTTOLEFT, 'ISRIGHTTOLEFT'); + RegisterPropertyHelper(@TMENUHANDLE_R,nil,'HANDLE'); + RegisterPropertyHelper(@TMENUITEMS_R,nil,'ITEMS'); +{$IFNDEF FPC} + RegisterMethod(@TMENU.DISPATCHPOPUP, 'DISPATCHPOPUP'); + RegisterMethod(@TMENU.PARENTBIDIMODECHANGED, 'PARENTBIDIMODECHANGED'); + RegisterMethod(@TMENU.PROCESSMENUCHAR, 'PROCESSMENUCHAR'); + RegisterPropertyHelper(@TMENUAUTOHOTKEYS_R,@TMENUAUTOHOTKEYS_W,'AUTOHOTKEYS'); + RegisterPropertyHelper(@TMENUAUTOLINEREDUCTION_R,@TMENUAUTOLINEREDUCTION_W,'AUTOLINEREDUCTION'); + RegisterPropertyHelper(@TMENUBIDIMODE_R,@TMENUBIDIMODE_W,'BIDIMODE'); + RegisterMethod(@TMENU.GETHELPCONTEXT, 'GETHELPCONTEXT'); + RegisterPropertyHelper(@TMENUOWNERDRAW_R,@TMENUOWNERDRAW_W,'OWNERDRAW'); + RegisterPropertyHelper(@TMENUPARENTBIDIMODE_R,@TMENUPARENTBIDIMODE_W,'PARENTBIDIMODE'); + RegisterPropertyHelper(@TMENUWINDOWHANDLE_R,@TMENUWINDOWHANDLE_W,'WINDOWHANDLE'); +{$ENDIF} + end; +end; + +procedure RIRegisterTMENUITEM(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TMENUITEM) do + begin + RegisterConstructor(@TMENUITEM.CREATE, 'CREATE'); + RegisterVirtualMethod(@TMENUITEM.INITIATEACTION, 'INITIATEACTION'); + RegisterMethod(@TMENUITEM.INSERT, 'INSERT'); + RegisterMethod(@TMENUITEM.DELETE, 'DELETE'); + RegisterMethod(@TMENUITEM.CLEAR, 'CLEAR'); + RegisterVirtualMethod(@TMENUITEM.CLICK, 'CLICK'); +{$IFNDEF FPC} + RegisterMethod(@TMENUITEM.FIND, 'FIND'); + RegisterMethod(@TMENUITEM.NEWTOPLINE, 'NEWTOPLINE'); + RegisterMethod(@TMENUITEM.NEWBOTTOMLINE, 'NEWBOTTOMLINE'); + RegisterMethod(@TMENUITEM.INSERTNEWLINEBEFORE, 'INSERTNEWLINEBEFORE'); + RegisterMethod(@TMENUITEM.INSERTNEWLINEAFTER, 'INSERTNEWLINEAFTER'); + RegisterMethod(@TMENUITEM.RETHINKHOTKEYS, 'RETHINKHOTKEYS'); + RegisterMethod(@TMENUITEM.RETHINKLINES, 'RETHINKLINES'); + RegisterMethod(@TMENUITEM.ISLINE, 'ISLINE'); +{$ENDIF} + RegisterMethod(@TMENUITEM.INDEXOF, 'INDEXOF'); + RegisterMethod(@TMENUITEM.GETIMAGELIST, 'GETIMAGELIST'); + RegisterMethod(@TMENUITEM.GETPARENTCOMPONENT, 'GETPARENTCOMPONENT'); + RegisterMethod(@TMENUITEM.GETPARENTMENU, 'GETPARENTMENU'); + RegisterMethod(@TMENUITEM.HASPARENT, 'HASPARENT'); + RegisterMethod(@TMENUITEM.ADD, 'ADD'); + RegisterMethod(@TMENUITEM.REMOVE, 'REMOVE'); +{$IFNDEF FPC} + RegisterPropertyHelper(@TMENUITEMAUTOHOTKEYS_R,@TMENUITEMAUTOHOTKEYS_W,'AUTOHOTKEYS'); + RegisterPropertyHelper(@TMENUITEMAUTOLINEREDUCTION_R,@TMENUITEMAUTOLINEREDUCTION_W,'AUTOLINEREDUCTION'); + RegisterEventPropertyHelper(@TMENUITEMONDRAWITEM_R,@TMENUITEMONDRAWITEM_W,'ONDRAWITEM'); + RegisterEventPropertyHelper(@TMENUITEMONADVANCEDDRAWITEM_R,@TMENUITEMONADVANCEDDRAWITEM_W,'ONADVANCEDDRAWITEM'); + RegisterEventPropertyHelper(@TMENUITEMONMEASUREITEM_R,@TMENUITEMONMEASUREITEM_W,'ONMEASUREITEM'); +{$ENDIF} + RegisterPropertyHelper(@TMENUITEMCOMMAND_R,nil,'COMMAND'); + RegisterPropertyHelper(@TMENUITEMHANDLE_R,nil,'HANDLE'); + RegisterPropertyHelper(@TMENUITEMCOUNT_R,nil,'COUNT'); + RegisterPropertyHelper(@TMENUITEMITEMS_R,nil,'ITEMS'); + RegisterPropertyHelper(@TMENUITEMMENUINDEX_R,@TMENUITEMMENUINDEX_W,'MENUINDEX'); + RegisterPropertyHelper(@TMENUITEMPARENT_R,nil,'PARENT'); + RegisterPropertyHelper(@TMENUITEMACTION_R,@TMENUITEMACTION_W,'ACTION'); + RegisterPropertyHelper(@TMENUITEMBITMAP_R,@TMENUITEMBITMAP_W,'BITMAP'); + RegisterPropertyHelper(@TMENUITEMCAPTION_R,@TMENUITEMCAPTION_W,'CAPTION'); + RegisterPropertyHelper(@TMENUITEMCHECKED_R,@TMENUITEMCHECKED_W,'CHECKED'); + RegisterPropertyHelper(@TMENUITEMSUBMENUIMAGES_R,@TMENUITEMSUBMENUIMAGES_W,'SUBMENUIMAGES'); + RegisterPropertyHelper(@TMENUITEMDEFAULT_R,@TMENUITEMDEFAULT_W,'DEFAULT'); + RegisterPropertyHelper(@TMENUITEMENABLED_R,@TMENUITEMENABLED_W,'ENABLED'); + RegisterPropertyHelper(@TMENUITEMGROUPINDEX_R,@TMENUITEMGROUPINDEX_W,'GROUPINDEX'); + RegisterPropertyHelper(@TMENUITEMHELPCONTEXT_R,@TMENUITEMHELPCONTEXT_W,'HELPCONTEXT'); + RegisterPropertyHelper(@TMENUITEMHINT_R,@TMENUITEMHINT_W,'HINT'); + RegisterPropertyHelper(@TMENUITEMIMAGEINDEX_R,@TMENUITEMIMAGEINDEX_W,'IMAGEINDEX'); + RegisterPropertyHelper(@TMENUITEMRADIOITEM_R,@TMENUITEMRADIOITEM_W,'RADIOITEM'); + RegisterPropertyHelper(@TMENUITEMSHORTCUT_R,@TMENUITEMSHORTCUT_W,'SHORTCUT'); + RegisterPropertyHelper(@TMENUITEMVISIBLE_R,@TMENUITEMVISIBLE_W,'VISIBLE'); + RegisterEventPropertyHelper(@TMENUITEMONCLICK_R,@TMENUITEMONCLICK_W,'ONCLICK'); + end; +end; + +procedure RIRegister_Menus(CL: TPSRuntimeClassImporter); +begin + RIRegisterTMENUITEM(Cl); + RIRegisterTMENU(Cl); + RIRegisterTPOPUPMENU(Cl); + RIRegisterTMAINMENU(Cl); + {$IFNDEF FPC} + RIRegisterTPOPUPLIST(Cl); + RIRegisterTMENUITEMSTACK(Cl); + {$ENDIF} +end; + +end. diff --git a/Units/PascalScript/uPSR_std.pas b/Units/PascalScript/uPSR_std.pas new file mode 100644 index 0000000..a67946e --- /dev/null +++ b/Units/PascalScript/uPSR_std.pas @@ -0,0 +1,85 @@ + +unit uPSR_std; +{$I PascalScript.inc} +interface +uses + uPSRuntime, uPSUtils; + + +procedure RIRegisterTObject(CL: TPSRuntimeClassImporter); +procedure RIRegisterTPersistent(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTComponent(Cl: TPSRuntimeClassImporter); +procedure RIRegister_Std(Cl: TPSRuntimeClassImporter); + +implementation +uses + Classes; + + + +procedure RIRegisterTObject(CL: TPSRuntimeClassImporter); +begin + with cl.Add(TObject) do + begin + RegisterConstructor(@TObject.Create, 'CREATE'); + RegisterMethod(@TObject.Free, 'FREE'); + end; +end; + +procedure RIRegisterTPersistent(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TPersistent) do + begin + RegisterVirtualMethod(@TPersistent.Assign, 'ASSIGN'); + end; +end; + +procedure TComponentOwnerR(Self: TComponent; var T: TComponent); begin T := Self.Owner; end; + + +procedure TCOMPONENTCOMPONENTS_R(Self: TCOMPONENT; var T: TCOMPONENT; t1: INTEGER); begin T := Self.COMPONENTS[t1]; end; +procedure TCOMPONENTCOMPONENTCOUNT_R(Self: TCOMPONENT; var T: INTEGER); begin t := Self.COMPONENTCOUNT; end; +procedure TCOMPONENTCOMPONENTINDEX_R(Self: TCOMPONENT; var T: INTEGER); begin t := Self.COMPONENTINDEX; end; +procedure TCOMPONENTCOMPONENTINDEX_W(Self: TCOMPONENT; T: INTEGER); begin Self.COMPONENTINDEX := t; end; +procedure TCOMPONENTCOMPONENTSTATE_R(Self: TCOMPONENT; var T: TCOMPONENTSTATE); begin t := Self.COMPONENTSTATE; end; +procedure TCOMPONENTDESIGNINFO_R(Self: TCOMPONENT; var T: LONGINT); begin t := Self.DESIGNINFO; end; +procedure TCOMPONENTDESIGNINFO_W(Self: TCOMPONENT; T: LONGINT); begin Self.DESIGNINFO := t; end; + + +procedure RIRegisterTComponent(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TComponent) do + begin + RegisterMethod(@TComponent.FindComponent, 'FINDCOMPONENT'); + RegisterVirtualConstructor(@TComponent.Create, 'CREATE'); + RegisterPropertyHelper(@TComponentOwnerR, nil, 'OWNER'); + + RegisterMethod(@TCOMPONENT.DESTROYCOMPONENTS, 'DESTROYCOMPONENTS'); + RegisterPropertyHelper(@TCOMPONENTCOMPONENTS_R, nil, 'COMPONENTS'); + RegisterPropertyHelper(@TCOMPONENTCOMPONENTCOUNT_R, nil, 'COMPONENTCOUNT'); + RegisterPropertyHelper(@TCOMPONENTCOMPONENTINDEX_R, @TCOMPONENTCOMPONENTINDEX_W, 'COMPONENTINDEX'); + RegisterPropertyHelper(@TCOMPONENTCOMPONENTSTATE_R, nil, 'COMPONENTSTATE'); + RegisterPropertyHelper(@TCOMPONENTDESIGNINFO_R, @TCOMPONENTDESIGNINFO_W, 'DESIGNINFO'); + end; +end; + + + + + + + +procedure RIRegister_Std(Cl: TPSRuntimeClassImporter); +begin + RIRegisterTObject(CL); + RIRegisterTPersistent(Cl); + RIRegisterTComponent(Cl); +end; +// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl) + +end. + + + + + diff --git a/Units/PascalScript/uPSR_stdctrls.pas b/Units/PascalScript/uPSR_stdctrls.pas new file mode 100644 index 0000000..87eeab9 --- /dev/null +++ b/Units/PascalScript/uPSR_stdctrls.pas @@ -0,0 +1,287 @@ +{ STDCtrls import unit } +unit uPSR_stdctrls; + +{$I PascalScript.inc} +interface +uses + uPSRuntime, uPSUtils; + + +procedure RIRegisterTCUSTOMGROUPBOX(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTGROUPBOX(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTCUSTOMLABEL(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTLABEL(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTCUSTOMEDIT(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTEDIT(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTCUSTOMMEMO(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTMEMO(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTCUSTOMCOMBOBOX(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTCOMBOBOX(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTBUTTONCONTROL(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTBUTTON(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTCUSTOMCHECKBOX(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTCHECKBOX(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTRADIOBUTTON(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTCUSTOMLISTBOX(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTLISTBOX(Cl: TPSRuntimeClassImporter); +procedure RIRegisterTSCROLLBAR(Cl: TPSRuntimeClassImporter); + +procedure RIRegister_stdctrls(cl: TPSRuntimeClassImporter); + +implementation +uses + sysutils, classes{$IFDEF CLX}, QControls, QStdCtrls, QGraphics{$ELSE}, controls, stdctrls, Graphics{$ENDIF}{$IFDEF FPC},buttons{$ENDIF}; + +procedure RIRegisterTCUSTOMGROUPBOX(Cl: TPSRuntimeClassImporter); +begin + Cl.Add(TCUSTOMGROUPBOX); +end; + + +procedure RIRegisterTGROUPBOX(Cl: TPSRuntimeClassImporter); +begin + Cl.Add(TGROUPBOX); +end; +{$IFNDEF CLX} +procedure TCUSTOMLABELCANVAS_R(Self: TCUSTOMLABEL; var T: TCanvas); begin T := Self.CANVAS; end; +{$ENDIF} + +procedure RIRegisterTCUSTOMLABEL(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TCUSTOMLABEL) do + begin + {$IFNDEF PS_MINIVCL} +{$IFNDEF CLX} + RegisterPropertyHelper(@TCUSTOMLABELCANVAS_R, nil, 'CANVAS'); +{$ENDIF} + {$ENDIF} + end; +end; + +procedure RIRegisterTLABEL(Cl: TPSRuntimeClassImporter); +begin + Cl.Add(TLABEL); +end; +procedure TCUSTOMEDITMODIFIED_R(Self: TCUSTOMEDIT; var T: BOOLEAN); begin T := Self.MODIFIED; end; +procedure TCUSTOMEDITMODIFIED_W(Self: TCUSTOMEDIT; T: BOOLEAN); begin Self.MODIFIED := T; end; +procedure TCUSTOMEDITSELLENGTH_R(Self: TCUSTOMEDIT; var T: INTEGER); begin T := Self.SELLENGTH; end; +procedure TCUSTOMEDITSELLENGTH_W(Self: TCUSTOMEDIT; T: INTEGER); begin Self.SELLENGTH := T; end; +procedure TCUSTOMEDITSELSTART_R(Self: TCUSTOMEDIT; var T: INTEGER); begin T := Self.SELSTART; end; +procedure TCUSTOMEDITSELSTART_W(Self: TCUSTOMEDIT; T: INTEGER); begin Self.SELSTART := T; end; +procedure TCUSTOMEDITSELTEXT_R(Self: TCUSTOMEDIT; var T: STRING); begin T := Self.SELTEXT; end; +procedure TCUSTOMEDITSELTEXT_W(Self: TCUSTOMEDIT; T: STRING); begin Self.SELTEXT := T; end; +procedure TCUSTOMEDITTEXT_R(Self: TCUSTOMEDIT; var T: string); begin T := Self.TEXT; end; +procedure TCUSTOMEDITTEXT_W(Self: TCUSTOMEDIT; T: string); begin Self.TEXT := T; end; + + +procedure RIRegisterTCUSTOMEDIT(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TCUSTOMEDIT) do + begin + RegisterMethod(@TCUSTOMEDIT.CLEAR, 'CLEAR'); + RegisterMethod(@TCUSTOMEDIT.CLEARSELECTION, 'CLEARSELECTION'); + RegisterMethod(@TCUSTOMEDIT.SELECTALL, 'SELECTALL'); + RegisterPropertyHelper(@TCUSTOMEDITMODIFIED_R, @TCUSTOMEDITMODIFIED_W, 'MODIFIED'); + RegisterPropertyHelper(@TCUSTOMEDITSELLENGTH_R, @TCUSTOMEDITSELLENGTH_W, 'SELLENGTH'); + RegisterPropertyHelper(@TCUSTOMEDITSELSTART_R, @TCUSTOMEDITSELSTART_W, 'SELSTART'); + RegisterPropertyHelper(@TCUSTOMEDITSELTEXT_R, @TCUSTOMEDITSELTEXT_W, 'SELTEXT'); + RegisterPropertyHelper(@TCUSTOMEDITTEXT_R, @TCUSTOMEDITTEXT_W, 'TEXT'); + + {$IFNDEF PS_MINIVCL} + RegisterMethod(@TCUSTOMEDIT.COPYTOCLIPBOARD, 'COPYTOCLIPBOARD'); + RegisterMethod(@TCUSTOMEDIT.CUTTOCLIPBOARD, 'CUTTOCLIPBOARD'); + RegisterMethod(@TCUSTOMEDIT.PASTEFROMCLIPBOARD, 'PASTEFROMCLIPBOARD'); + {$IFNDEF FPC} + RegisterMethod(@TCUSTOMEDIT.GETSELTEXTBUF, 'GETSELTEXTBUF'); + RegisterMethod(@TCUSTOMEDIT.SETSELTEXTBUF, 'SETSELTEXTBUF'); + {$ENDIF}{FPC} + {$ENDIF} + end; +end; + +procedure RIRegisterTEDIT(Cl: TPSRuntimeClassImporter); +begin + Cl.Add(TEDIT); +end; + + +procedure TCUSTOMMEMOLINES_R(Self: {$IFDEF CLX}TMemo{$ELSE}TCUSTOMMEMO{$ENDIF}; var T: TSTRINGS); begin T := Self.LINES; end; +procedure TCUSTOMMEMOLINES_W(Self: {$IFDEF CLX}TMemo{$ELSE}TCUSTOMMEMO{$ENDIF}; T: TSTRINGS); begin Self.LINES := T; end; + + +procedure RIRegisterTCUSTOMMEMO(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TCUSTOMMEMO) do + begin + {$IFNDEF CLX} + RegisterPropertyHelper(@TCUSTOMMEMOLINES_R, @TCUSTOMMEMOLINES_W, 'LINES'); + {$ENDIF} + end; +end; + + +procedure RIRegisterTMEMO(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TMEMO) do + begin + {$IFDEF CLX} + RegisterPropertyHelper(@TCUSTOMMEMOLINES_R, @TCUSTOMMEMOLINES_W, 'LINES'); + {$ENDIF} + end; +end; + + +procedure TCUSTOMCOMBOBOXCANVAS_R(Self: TCUSTOMCOMBOBOX; var T: TCANVAS); begin T := Self.CANVAS; end; +procedure TCUSTOMCOMBOBOXDROPPEDDOWN_R(Self: TCUSTOMCOMBOBOX; var T: BOOLEAN); begin T := Self.DROPPEDDOWN; end; +procedure TCUSTOMCOMBOBOXDROPPEDDOWN_W(Self: TCUSTOMCOMBOBOX; T: BOOLEAN); begin Self.DROPPEDDOWN := T; end; +procedure TCUSTOMCOMBOBOXITEMS_R(Self: TCUSTOMCOMBOBOX; var T: TSTRINGS); begin T := Self.ITEMS; end; +procedure TCUSTOMCOMBOBOXITEMS_W(Self: TCUSTOMCOMBOBOX; T: TSTRINGS); begin Self.ITEMS := T; end; +procedure TCUSTOMCOMBOBOXITEMINDEX_R(Self: TCUSTOMCOMBOBOX; var T: INTEGER); begin T := Self.ITEMINDEX; end; +procedure TCUSTOMCOMBOBOXITEMINDEX_W(Self: TCUSTOMCOMBOBOX; T: INTEGER); begin Self.ITEMINDEX := T; end; +procedure TCUSTOMCOMBOBOXSELLENGTH_R(Self: TCUSTOMCOMBOBOX; var T: INTEGER); begin T := Self.SELLENGTH; end; +procedure TCUSTOMCOMBOBOXSELLENGTH_W(Self: TCUSTOMCOMBOBOX; T: INTEGER); begin Self.SELLENGTH := T; end; +procedure TCUSTOMCOMBOBOXSELSTART_R(Self: TCUSTOMCOMBOBOX; var T: INTEGER); begin T := Self.SELSTART; end; +procedure TCUSTOMCOMBOBOXSELSTART_W(Self: TCUSTOMCOMBOBOX; T: INTEGER); begin Self.SELSTART := T; end; +procedure TCUSTOMCOMBOBOXSELTEXT_R(Self: TCUSTOMCOMBOBOX; var T: STRING); begin T := Self.SELTEXT; end; +procedure TCUSTOMCOMBOBOXSELTEXT_W(Self: TCUSTOMCOMBOBOX; T: STRING); begin Self.SELTEXT := T; end; + + +procedure RIRegisterTCUSTOMCOMBOBOX(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TCUSTOMCOMBOBOX) do + begin + RegisterPropertyHelper(@TCUSTOMCOMBOBOXDROPPEDDOWN_R, @TCUSTOMCOMBOBOXDROPPEDDOWN_W, 'DROPPEDDOWN'); + RegisterPropertyHelper(@TCUSTOMCOMBOBOXITEMS_R, @TCUSTOMCOMBOBOXITEMS_W, 'ITEMS'); + RegisterPropertyHelper(@TCUSTOMCOMBOBOXITEMINDEX_R, @TCUSTOMCOMBOBOXITEMINDEX_W, 'ITEMINDEX'); + + {$IFNDEF PS_MINIVCL} + RegisterMethod(@TCUSTOMCOMBOBOX.CLEAR, 'CLEAR'); + RegisterMethod(@TCUSTOMCOMBOBOX.SELECTALL, 'SELECTALL'); + RegisterPropertyHelper(@TCUSTOMCOMBOBOXCANVAS_R, nil, 'CANVAS'); + RegisterPropertyHelper(@TCUSTOMCOMBOBOXSELLENGTH_R, @TCUSTOMCOMBOBOXSELLENGTH_W, 'SELLENGTH'); + RegisterPropertyHelper(@TCUSTOMCOMBOBOXSELSTART_R, @TCUSTOMCOMBOBOXSELSTART_W, 'SELSTART'); + RegisterPropertyHelper(@TCUSTOMCOMBOBOXSELTEXT_R, @TCUSTOMCOMBOBOXSELTEXT_W, 'SELTEXT'); + {$ENDIF} + end; +end; + + + + +procedure RIRegisterTCOMBOBOX(Cl: TPSRuntimeClassImporter); +begin + Cl.Add(TCOMBOBOX); +end; + + + +procedure RIRegisterTBUTTONCONTROL(Cl: TPSRuntimeClassImporter); +begin + Cl.Add(TBUTTONCONTROL); +end; + + + +procedure RIRegisterTBUTTON(Cl: TPSRuntimeClassImporter); +begin + Cl.Add(TBUTTON); +end; + + + + +procedure RIRegisterTCUSTOMCHECKBOX(Cl: TPSRuntimeClassImporter); +begin + Cl.Add(TCUSTOMCHECKBOX); +end; + + +procedure RIRegisterTCHECKBOX(Cl: TPSRuntimeClassImporter); +begin + Cl.Add(TCHECKBOX); +end; + + +procedure RIRegisterTRADIOBUTTON(Cl: TPSRuntimeClassImporter); +begin + Cl.Add(TRADIOBUTTON); +end; + +procedure TCUSTOMLISTBOXCANVAS_R(Self: TCUSTOMLISTBOX; var T: TCANVAS); begin T := Self.CANVAS; end; +procedure TCUSTOMLISTBOXITEMS_R(Self: TCUSTOMLISTBOX; var T: TSTRINGS); begin T := Self.ITEMS; end; +procedure TCUSTOMLISTBOXITEMS_W(Self: TCUSTOMLISTBOX; T: TSTRINGS); begin Self.ITEMS := T; end; +procedure TCUSTOMLISTBOXITEMINDEX_R(Self: TCUSTOMLISTBOX; var T: INTEGER); begin T := Self.ITEMINDEX; end; +procedure TCUSTOMLISTBOXITEMINDEX_W(Self: TCUSTOMLISTBOX; T: INTEGER); begin Self.ITEMINDEX := T; end; +procedure TCUSTOMLISTBOXSELCOUNT_R(Self: TCUSTOMLISTBOX; var T: INTEGER); begin T := Self.SELCOUNT; end; +procedure TCUSTOMLISTBOXSELECTED_R(Self: TCUSTOMLISTBOX; var T: BOOLEAN; t1: INTEGER); begin T := Self.SELECTED[t1]; end; +procedure TCUSTOMLISTBOXSELECTED_W(Self: TCUSTOMLISTBOX; T: BOOLEAN; t1: INTEGER); begin Self.SELECTED[t1] := T; end; +procedure TCUSTOMLISTBOXTOPINDEX_R(Self: TCUSTOMLISTBOX; var T: INTEGER); begin T := Self.TOPINDEX; end; +procedure TCUSTOMLISTBOXTOPINDEX_W(Self: TCUSTOMLISTBOX; T: INTEGER); begin Self.TOPINDEX := T; end; + + +procedure RIRegisterTCUSTOMLISTBOX(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TCUSTOMLISTBOX) do + begin + RegisterPropertyHelper(@TCUSTOMLISTBOXITEMS_R, @TCUSTOMLISTBOXITEMS_W, 'ITEMS'); + RegisterPropertyHelper(@TCUSTOMLISTBOXITEMINDEX_R, @TCUSTOMLISTBOXITEMINDEX_W, 'ITEMINDEX'); + RegisterPropertyHelper(@TCUSTOMLISTBOXSELCOUNT_R, nil, 'SELCOUNT'); + RegisterPropertyHelper(@TCUSTOMLISTBOXSELECTED_R, @TCUSTOMLISTBOXSELECTED_W, 'SELECTED'); + + {$IFNDEF PS_MINIVCL} + RegisterMethod(@TCUSTOMLISTBOX.CLEAR, 'CLEAR'); + RegisterMethod(@TCUSTOMLISTBOX.ITEMATPOS, 'ITEMATPOS'); + RegisterMethod(@TCUSTOMLISTBOX.ITEMRECT, 'ITEMRECT'); + RegisterPropertyHelper(@TCUSTOMLISTBOXCANVAS_R, nil, 'CANVAS'); + RegisterPropertyHelper(@TCUSTOMLISTBOXTOPINDEX_R, @TCUSTOMLISTBOXTOPINDEX_W, 'TOPINDEX'); + {$ENDIF} + end; +end; + + +procedure RIRegisterTLISTBOX(Cl: TPSRuntimeClassImporter); +begin + Cl.Add(TLISTBOX); +end; + + +procedure RIRegisterTSCROLLBAR(Cl: TPSRuntimeClassImporter); +begin + with Cl.Add(TSCROLLBAR) do + begin + RegisterMethod(@TSCROLLBAR.SETPARAMS, 'SETPARAMS'); + end; +end; + + +procedure RIRegister_stdctrls(cl: TPSRuntimeClassImporter); +begin + {$IFNDEF PS_MINIVCL} + RIRegisterTCUSTOMGROUPBOX(Cl); + RIRegisterTGROUPBOX(Cl); + {$ENDIF} + RIRegisterTCUSTOMLABEL(Cl); + RIRegisterTLABEL(Cl); + RIRegisterTCUSTOMEDIT(Cl); + RIRegisterTEDIT(Cl); + RIRegisterTCUSTOMMEMO(Cl); + RIRegisterTMEMO(Cl); + RIRegisterTCUSTOMCOMBOBOX(Cl); + RIRegisterTCOMBOBOX(Cl); + RIRegisterTBUTTONCONTROL(Cl); + RIRegisterTBUTTON(Cl); + RIRegisterTCUSTOMCHECKBOX(Cl); + RIRegisterTCHECKBOX(Cl); + RIRegisterTRADIOBUTTON(Cl); + RIRegisterTCUSTOMLISTBOX(Cl); + RIRegisterTLISTBOX(Cl); + {$IFNDEF PS_MINIVCL} + RIRegisterTSCROLLBAR(Cl); + {$ENDIF} +end; + +// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl) + +end. + + diff --git a/Units/PascalScript/uPSRuntime.pas b/Units/PascalScript/uPSRuntime.pas new file mode 100644 index 0000000..7d61acb --- /dev/null +++ b/Units/PascalScript/uPSRuntime.pas @@ -0,0 +1,12454 @@ +unit uPSRuntime; +{$I PascalScript.inc} +{ + +RemObjects Pascal Script III +Copyright (C) 2000-2009 by Carlo Kok (ck@carlo-kok.com) + +} +interface +uses + SysUtils, uPSUtils{$IFDEF DELPHI6UP}, variants{$ENDIF}{$IFNDEF PS_NOIDISPATCH}{$IFDEF DELPHI3UP}, ActiveX, Windows{$ELSE}, Ole2{$ENDIF}{$ENDIF}; + + +type + TPSExec = class; + TPSStack = class; + TPSRuntimeAttributes = class; + TPSRuntimeAttribute = class; + + TPSError = (ErNoError, erCannotImport, erInvalidType, ErInternalError, + erInvalidHeader, erInvalidOpcode, erInvalidOpcodeParameter, erNoMainProc, + erOutOfGlobalVarsRange, erOutOfProcRange, ErOutOfRange, erOutOfStackRange, + ErTypeMismatch, erUnexpectedEof, erVersionError, ErDivideByZero, ErMathError, + erCouldNotCallProc, erOutofRecordRange, erOutOfMemory, erException, + erNullPointerException, erNullVariantError, erInterfaceNotSupported, erCustomError); + + TPSStatus = (isNotLoaded, isLoaded, isRunning, isPaused); + + PByteArray = ^TByteArray; + + TByteArray = array[0..1023] of Byte; + + PDWordArray = ^TDWordArray; + + TDWordArray = array[0..1023] of Cardinal; +{@link(TPSProcRec) + PIFProcRec is a pointer to a TIProcRec record} + TPSProcRec = class; + TIFProcRec = TPSProcRec; + TPSExternalProcRec = class; + TIFPSExternalProcRec = TPSExternalProcRec; + TIFExternalProcRec = TPSExternalProcRec; + PIFProcRec = TPSProcRec; + PProcRec = ^TProcRec; + + TPSProcPtr = function(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; + + TPSFreeProc = procedure (Caller: TPSExec; p: PProcRec); + + TPSProcRec = class + private + FAttributes: TPSRuntimeAttributes; + public + + constructor Create(Owner: TPSExec); + + destructor Destroy; override; + + + property Attributes: TPSRuntimeAttributes read FAttributes; + end; + + TPSExternalProcRec = class(TPSProcRec) + private + FExt1: Pointer; + FExt2: Pointer; + FName: tbtstring; + FProcPtr: TPSProcPtr; + FDecl: tbtstring; + public + + property Name: tbtstring read FName write FName; + + property Decl: tbtstring read FDecl write FDecl; + + property Ext1: Pointer read FExt1 write FExt1; + + property Ext2: Pointer read FExt2 write FExt2; + + property ProcPtr: TPSProcPtr read FProcPtr write FProcPtr; + end; + + TPSInternalProcRec = class(TPSProcRec) + private + FData: PByteArray; + FLength: Cardinal; + FExportNameHash: Longint; + FExportDecl: tbtstring; + FExportName: tbtstring; + public + + property Data: PByteArray read FData; + + property Length: Cardinal read FLength; + + property ExportNameHash: Longint read FExportNameHash; + + property ExportName: tbtstring read FExportName write FExportName; + + property ExportDecl: tbtstring read FExportDecl write FExportDecl; + + + destructor Destroy; override; + end; + + TProcRec = record + + Name: ShortString; + + Hash: Longint; + + ProcPtr: TPSProcPtr; + + FreeProc: TPSFreeProc; + + Ext1, Ext2: Pointer; + end; + + PBTReturnAddress = ^TBTReturnAddress; + + TBTReturnAddress = packed record + + ProcNo: TPSInternalProcRec; + + Position, StackBase: Cardinal; + end; + + TPSTypeRec = class + private + FExportNameHash: Longint; + FExportName: tbtstring; + FBaseType: TPSBaseType; + FAttributes: TPSRuntimeAttributes; + protected + FRealSize: Cardinal; + public + + property RealSize: Cardinal read FRealSize; + + property BaseType: TPSBaseType read FBaseType write FBaseType; + + property ExportName: tbtstring read FExportName write FExportName; + + property ExportNameHash: Longint read FExportNameHash write FExportNameHash; + + property Attributes: TPSRuntimeAttributes read FAttributes write FAttributes; + + procedure CalcSize; virtual; + + constructor Create(Owner: TPSExec); + destructor Destroy; override; + end; + + TPSTypeRec_ProcPtr = class(TPSTypeRec) + private + FParamInfo: tbtstring; + public + + property ParamInfo: tbtstring read FParamInfo write FParamInfo; + procedure CalcSize; override; + end; + PIFTypeRec = TPSTypeRec; + + TPSTypeRec_Class = class(TPSTypeRec) + private + FCN: tbtstring; + public + + property CN: tbtstring read FCN write FCN; + end; +{$IFNDEF PS_NOINTERFACES} + + TPSTypeRec_Interface = class(TPSTypeRec) + private + FGuid: TGUID; + public + + property Guid: TGUID read FGuid write FGuid; + end; +{$ENDIF} + + TPSTypeRec_Array = class(TPSTypeRec) + private + FArrayType: TPSTypeRec; + public + + property ArrayType: TPSTypeRec read FArrayType write FArrayType; + procedure CalcSize; override; + end; + + TPSTypeRec_StaticArray = class(TPSTypeRec_Array) + private + FSize: Longint; + FStartOffset: LongInt; + public + + property Size: Longint read FSize write FSize; + property StartOffset: LongInt read FStartOffset write FStartOffset; + + procedure CalcSize; override; + end; + + TPSTypeRec_Set = class(TPSTypeRec) + private + FBitSize: Longint; + FByteSize: Longint; + public + {The number of bytes this would require (same as realsize)} + property aByteSize: Longint read FByteSize write FByteSize; + property aBitSize: Longint read FBitSize write FBitSize; + procedure CalcSize; override; + end; + + TPSTypeRec_Record = class(TPSTypeRec) + private + FFieldTypes: TPSList; + FRealFieldOffsets: TPSList; + public + + property FieldTypes: TPSList read FFieldTypes; + + property RealFieldOffsets: TPSList read FRealFieldOffsets; + + procedure CalcSize; override; + + constructor Create(Owner: TPSExec); + destructor Destroy; override; + end; + + PPSVariant = ^TPSVariant; + + PIFVariant = PPSVariant; + + TPSVariant = packed record + FType: TPSTypeRec; + end; + + PPSVariantData = ^TPSVariantData; + + TPSVariantData = packed record + VI: TPSVariant; + Data: array[0..0] of Byte; + end; + + PPSVariantU8 = ^TPSVariantU8; + + TPSVariantU8 = packed record + VI: TPSVariant; + Data: tbtU8; + end; + + + PPSVariantS8 = ^TPSVariantS8; + + TPSVariantS8 = packed record + VI: TPSVariant; + Data: tbts8; + end; + + + PPSVariantU16 = ^TPSVariantU16; + + TPSVariantU16 = packed record + VI: TPSVariant; + Data: tbtU16; + end; + + + PPSVariantS16 = ^TPSVariantS16; + + TPSVariantS16 = packed record + VI: TPSVariant; + Data: tbts16; + end; + + + PPSVariantU32 = ^TPSVariantU32; + + TPSVariantU32 = packed record + VI: TPSVariant; + Data: tbtU32; + end; + + + PPSVariantS32 = ^TPSVariantS32; + + TPSVariantS32 = packed record + VI: TPSVariant; + Data: tbts32; + end; +{$IFNDEF PS_NOINT64} + + PPSVariantS64 = ^TPSVariantS64; + + TPSVariantS64 = packed record + VI: TPSVariant; + Data: tbts64; + end; +{$ENDIF} + + PPSVariantAChar = ^TPSVariantAChar; + + TPSVariantAChar = packed record + VI: TPSVariant; + Data: tbtChar; + end; + +{$IFNDEF PS_NOWIDESTRING} + + PPSVariantWChar = ^TPSVariantWChar; + + TPSVariantWChar = packed record + VI: TPSVariant; + Data: tbtWideChar; + end; +{$ENDIF} + + PPSVariantAString = ^TPSVariantAString; + + TPSVariantAString = packed record + VI: TPSVariant; + Data: tbtString; + end; + +{$IFNDEF PS_NOWIDESTRING} + + PPSVariantWString = ^TPSVariantWString; + + TPSVariantWString = {$IFNDEF DELPHI2009UP}packed {$ENDIF}record + VI: TPSVariant; + Data: tbtWideString; + end; + + PPSVariantUString = ^TPSVariantUString; + + TPSVariantUString = {$IFNDEF DELPHI2009UP}packed {$ENDIF}record + VI: TPSVariant; + Data: tbtunicodestring; + end; + +{$ENDIF} + + + PPSVariantSingle = ^TPSVariantSingle; + + TPSVariantSingle = packed record + VI: TPSVariant; + Data: tbtsingle; + end; + + + PPSVariantDouble = ^TPSVariantDouble; + + TPSVariantDouble = packed record + VI: TPSVariant; + Data: tbtDouble; + end; + + + PPSVariantExtended = ^TPSVariantExtended; + + TPSVariantExtended = packed record + VI: TPSVariant; + Data: tbtExtended; + end; + + + PPSVariantCurrency = ^TPSVariantCurrency; + + TPSVariantCurrency = packed record + VI: TPSVariant; + Data: tbtCurrency; + end; + + PPSVariantSet = ^TPSVariantSet; + + TPSVariantSet = packed record + VI: TPSVariant; + Data: array[0..0] of Byte; + end; + +{$IFNDEF PS_NOINTERFACES} + + PPSVariantInterface = ^TPSVariantInterface; + + TPSVariantInterface = packed record + VI: TPSVariant; + Data: IUnknown; + end; +{$ENDIF} + + PPSVariantClass = ^TPSVariantClass; + + TPSVariantClass = packed record + VI: TPSVariant; + Data: TObject; + end; + + + PPSVariantRecord = ^TPSVariantRecord; + + TPSVariantRecord = packed record + VI: TPSVariant; + data: array[0..0] of byte; + end; + + + PPSVariantDynamicArray = ^TPSVariantDynamicArray; + + TPSVariantDynamicArray = packed record + VI: TPSVariant; + Data: Pointer; + end; + + + PPSVariantStaticArray = ^TPSVariantStaticArray; + + TPSVariantStaticArray = packed record + VI: TPSVariant; + data: array[0..0] of byte; + end; + + + PPSVariantPointer = ^TPSVariantPointer; + + TPSVariantPointer = packed record + VI: TPSVariant; + DataDest: Pointer; + DestType: TPSTypeRec; + FreeIt: LongBool; + end; + + + PPSVariantReturnAddress = ^TPSVariantReturnAddress; + + TPSVariantReturnAddress = packed record + VI: TPSVariant; + Addr: TBTReturnAddress; + end; + + + PPSVariantVariant = ^TPSVariantVariant; + + TPSVariantVariant = packed record + VI: TPSVariant; + Data: Variant; + end; + + PPSVariantProcPtr = ^TPSVariantProcPtr; + TPSVariantProcPtr = packed record + VI: TPSVariant; + ProcNo: Cardinal; + Self: Pointer; + Ptr: Pointer; + { + ProcNo = 0 means Self/Ptr become active (Ptr = nil means it's nil) + } + end; + + + TPSVarFreeType = ( + vtNone, + vtTempVar + ); + + TPSResultData = packed record + P: Pointer; + aType: TPSTypeRec; + FreeType: TPSVarFreeType; + end; + + + PPSResource = ^TPSResource; + + TPSResource = record + Proc: Pointer; + P: Pointer; + end; + + TPSAttributeUseProc = function (Sender: TPSExec; const AttribType: tbtstring; Attr: TPSRuntimeAttribute): Boolean; + + TPSAttributeType = class + private + FTypeName: tbtstring; + FUseProc: TPSAttributeUseProc; + FTypeNameHash: Longint; + public + + property UseProc: TPSAttributeUseProc read FUseProc write FUseProc; + + property TypeName: tbtstring read FTypeName write FTypeName; + + property TypeNameHash: Longint read FTypeNameHash write FTypeNameHash; + end; + + PClassItem = ^TClassItem; + + TClassItem = record + + FName: tbtstring; + + FNameHash: Longint; + + b: byte; + case byte of + 0: (Ptr: Pointer); + 1: (PointerInList: Pointer); + 3: (FReadFunc, FWriteFunc: Pointer); {Property Helper} + 4: (Ptr2: Pointer); + 5: (PointerInList2: Pointer); + 6: (); {Property helper, like 3} + 7: (); {Property helper that will pass it's name} + end; + + + PPSVariantIFC = ^TPSVariantIFC; + {Temporary variant into record} + TPSVariantIFC = packed record + Dta: Pointer; + aType: TPSTypeRec; + VarParam: Boolean; + end; + PIFPSVariantIFC = PPSVariantIFC; + TIFPSVariantIFC = TPSVariantIFC; + + TPSRuntimeAttribute = class(TObject) + private + FValues: TPSStack; + FAttribType: tbtstring; + FOwner: TPSRuntimeAttributes; + FAttribTypeHash: Longint; + function GetValue(I: Longint): PIFVariant; + function GetValueCount: Longint; + public + + property Owner: TPSRuntimeAttributes read FOwner; + + property AttribType: tbtstring read FAttribType write FAttribType; + + property AttribTypeHash: Longint read FAttribTypeHash write FAttribTypeHash; + + property ValueCount: Longint read GetValueCount; + + property Value[I: Longint]: PIFVariant read GetValue; + + function AddValue(aType: TPSTypeRec): PPSVariant; + + procedure DeleteValue(i: Longint); + + procedure AdjustSize; + + + constructor Create(Owner: TPSRuntimeAttributes); + + destructor Destroy; override; + end; + + TPSRuntimeAttributes = class(TObject) + private + FAttributes: TPSList; + FOwner: TPSExec; + function GetCount: Longint; + function GetItem(I: Longint): TPSRuntimeAttribute; + public + + property Owner: TPSExec read FOwner; + + property Count: Longint read GetCount; + + property Items[I: Longint]: TPSRuntimeAttribute read GetItem; default; + + procedure Delete(I: Longint); + + function Add: TPSRuntimeAttribute; + + function FindAttribute(const Name: tbtstring): TPSRuntimeAttribute; + + + constructor Create(AOwner: TPSExec); + + destructor Destroy; override; + end; + TPSOnGetNVariant = function (Sender: TPSExec; const Name: tbtstring): Variant; + TPSOnSetNVariant = procedure (Sender: TPSExec; const Name: tbtstring; V: Variant); + + TPSOnLineEvent = procedure(Sender: TPSExec); + + TPSOnSpecialProcImport = function (Sender: TPSExec; p: TPSExternalProcRec; Tag: Pointer): Boolean; + + TPSOnException = procedure (Sender: TPSExec; ExError: TPSError; const ExParam: tbtstring; ExObject: TObject; ProcNo, Position: Cardinal); + + TPSExec = class(TObject) + Private + FOnGetNVariant: TPSOnGetNVariant; + FOnSetNVariant: TPSOnSetNVariant; + FId: Pointer; + FJumpFlag: Boolean; + FCallCleanup: Boolean; + FOnException: TPSOnException; + function ReadData(var Data; Len: Cardinal): Boolean; + function ReadLong(var b: Cardinal): Boolean; + function DoCalc(var1, Var2: Pointer; var1Type, var2type: TPSTypeRec; CalcType: Cardinal): Boolean; + function DoBooleanCalc(var1, Var2, into: Pointer; var1Type, var2type, intotype: TPSTypeRec; Cmd: Cardinal): Boolean; + function SetVariantValue(dest, Src: Pointer; desttype, srctype: TPSTypeRec): Boolean; + function ReadVariable(var Dest: TPSResultData; UsePointer: Boolean): Boolean; + function DoBooleanNot(Dta: Pointer; aType: TPSTypeRec): Boolean; + function DoMinus(Dta: Pointer; aType: TPSTypeRec): Boolean; + function DoIntegerNot(Dta: Pointer; aType: TPSTypeRec): Boolean; + procedure RegisterStandardProcs; + Protected + + FReturnAddressType: TPSTypeRec; + + FVariantType: TPSTypeRec; + + FVariantArrayType: TPSTypeRec; + + FAttributeTypes: TPSList; + + FExceptionStack: TPSList; + + FResources: TPSList; + + FExportedVars: TPSList; + + FTypes: TPSList; + + FProcs: TPSList; + + FGlobalVars: TPSStack; + + FTempVars: TPSStack; + + FStack: TPSStack; + + FMainProc: Cardinal; + + FStatus: TPSStatus; + + FCurrProc: TPSInternalProcRec; + + FData: PByteArray; + + FDataLength: Cardinal; + + FCurrentPosition: Cardinal; + + FCurrStackBase: Cardinal; + + FOnRunLine: TPSOnLineEvent; + + FSpecialProcList: TPSList; + + FRegProcs: TPSList; + + ExObject: TObject; + + ExProc: Cardinal; + + ExPos: Cardinal; + + ExEx: TPSError; + + ExParam: tbtstring; + + function InvokeExternalMethod(At: TPSTypeRec_ProcPtr; Slf, Ptr: Pointer): Boolean; + + function InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean; + + procedure RunLine; virtual; + + function ImportProc(const Name: ShortString; proc: TPSExternalProcRec): Boolean; Virtual; + + procedure ExceptionProc(proc, Position: Cardinal; Ex: TPSError; const s: tbtstring; NewObject: TObject); Virtual; + + function FindSpecialProcImport(P: TPSOnSpecialProcImport): pointer; + Public + function LastEx: TPSError; + function LastExParam: tbtstring; + function LastExProc: Integer; + function LastExPos: Integer; + procedure CMD_Err(EC: TPSError); + + procedure CMD_Err2(EC: TPSError; const Param: tbtstring); + + procedure CMD_Err3(EC: TPSError; const Param: tbtstring; ExObject: TObject); + + property Id: Pointer read FID write FID; + + class function About: tbtstring; + + function RunProc(Params: TPSList; ProcNo: Cardinal): Boolean; + + function RunProcP(const Params: array of Variant; const Procno: Cardinal): Variant; + function RunProcPVar(var Params: array of Variant; const Procno: Cardinal): Variant; + + function RunProcPN(const Params: array of Variant; const ProcName: tbtstring): Variant; + + function FindType(StartAt: Cardinal; BaseType: TPSBaseType; var l: Cardinal): PIFTypeRec; + + function FindType2(BaseType: TPSBaseType): PIFTypeRec; + + function GetTypeNo(l: Cardinal): PIFTypeRec; + + function GetType(const Name: tbtstring): Cardinal; + + function GetProc(const Name: tbtstring): Cardinal; + + function GetVar(const Name: tbtstring): Cardinal; + + function GetVar2(const Name: tbtstring): PIFVariant; + + function GetVarNo(C: Cardinal): PIFVariant; + + function GetProcNo(C: Cardinal): PIFProcRec; + + function GetProcCount: Cardinal; + + function GetVarCount: Longint; + + function GetTypeCount: Longint; + + + constructor Create; + + destructor Destroy; Override; + + + function RunScript: Boolean; + + + function LoadData(const s: tbtstring): Boolean; virtual; + + procedure Clear; Virtual; + + procedure Cleanup; Virtual; + + procedure Stop; Virtual; + + procedure Pause; Virtual; + + property CallCleanup: Boolean read FCallCleanup write FCallCleanup; + + property Status: TPSStatus Read FStatus; + + property OnRunLine: TPSOnLineEvent Read FOnRunLine Write FOnRunLine; + + procedure ClearspecialProcImports; + + procedure AddSpecialProcImport(const FName: tbtstring; P: TPSOnSpecialProcImport; Tag: Pointer); + + function RegisterFunctionName(const Name: tbtstring; ProcPtr: TPSProcPtr; + Ext1, Ext2: Pointer): PProcRec; + + procedure RegisterDelphiFunction(ProcPtr: Pointer; const Name: tbtstring; CC: TPSCallingConvention); + + procedure RegisterDelphiMethod(Slf, ProcPtr: Pointer; const Name: tbtstring; CC: TPSCallingConvention); + + function GetProcAsMethod(const ProcNo: Cardinal): TMethod; + + function GetProcAsMethodN(const ProcName: tbtstring): TMethod; + + procedure RegisterAttributeType(useproc: TPSAttributeUseProc; const TypeName: tbtstring); + + procedure ClearFunctionList; + + property ExceptionProcNo: Cardinal Read ExProc; + + property ExceptionPos: Cardinal Read ExPos; + + property ExceptionCode: TPSError Read ExEx; + + property ExceptionString: tbtstring read ExParam; + + property ExceptionObject: TObject read ExObject write ExObject; + + procedure AddResource(Proc, P: Pointer); + + function IsValidResource(Proc, P: Pointer): Boolean; + + procedure DeleteResource(P: Pointer); + + function FindProcResource(Proc: Pointer): Pointer; + + function FindProcResource2(Proc: Pointer; var StartAt: Longint): Pointer; + + procedure RaiseCurrentException; + + property OnException: TPSOnException read FOnException write FOnException; + property OnGetNVariant: TPSOnGetNVariant read FOnGetNVariant write FOnGetNVariant; + property OnSetNVariant: TPSOnSetNVariant read FOnSetNVariant write FOnSetNVariant; + end; + + TPSStack = class(TPSList) + private + FDataPtr: Pointer; + FCapacity, + FLength: Longint; + function GetItem(I: Longint): PPSVariant; + procedure SetCapacity(const Value: Longint); + procedure AdjustLength; + public + + property DataPtr: Pointer read FDataPtr; + + property Capacity: Longint read FCapacity write SetCapacity; + + property Length: Longint read FLength; + + + constructor Create; + + destructor Destroy; override; + + procedure Clear; {$IFDEF DELPHI5UP} reintroduce;{$ELSE} override; {$ENDIF} + + function Push(TotalSize: Longint): PPSVariant; + + function PushType(aType: TPSTypeRec): PPSVariant; + + procedure Pop; + function GetInt(ItemNo: Longint): Longint; + function GetUInt(ItemNo: Longint): Cardinal; +{$IFNDEF PS_NOINT64} + function GetInt64(ItemNo: Longint): Int64; +{$ENDIF} + function GetString(ItemNo: Longint): string; // calls the native method + function GetAnsiString(ItemNo: Longint): tbtstring; +{$IFNDEF PS_NOWIDESTRING} + function GetWideString(ItemNo: Longint): tbtWideString; + function GetUnicodeString(ItemNo: Longint): tbtunicodestring; +{$ENDIF} + function GetReal(ItemNo: Longint): Extended; + function GetCurrency(ItemNo: Longint): Currency; + function GetBool(ItemNo: Longint): Boolean; + function GetClass(ItemNo: Longint): TObject; + + procedure SetInt(ItemNo: Longint; const Data: Longint); + procedure SetUInt(ItemNo: Longint; const Data: Cardinal); +{$IFNDEF PS_NOINT64} + procedure SetInt64(ItemNo: Longint; const Data: Int64); +{$ENDIF} + procedure SetString(ItemNo: Longint; const Data: string); + procedure SetAnsiString(ItemNo: Longint; const Data: tbtstring); +{$IFNDEF PS_NOWIDESTRING} + procedure SetWideString(ItemNo: Longint; const Data: tbtWideString); + procedure SetUnicodeString(ItemNo: Longint; const Data: tbtunicodestring); +{$ENDIF} + procedure SetReal(ItemNo: Longint; const Data: Extended); + procedure SetCurrency(ItemNo: Longint; const Data: Currency); + procedure SetBool(ItemNo: Longint; const Data: Boolean); + procedure SetClass(ItemNo: Longint; const Data: TObject); + + property Items[I: Longint]: PPSVariant read GetItem; default; + end; + + +function PSErrorToString(x: TPSError; const Param: tbtstring): tbtstring; +function TIFErrorToString(x: TPSError; const Param: tbtstring): tbtstring; +function CreateHeapVariant(aType: TPSTypeRec): PPSVariant; +procedure DestroyHeapVariant(v: PPSVariant); + +procedure FreePIFVariantList(l: TPSList); +procedure FreePSVariantList(l: TPSList); + +const + ENoError = ERNoError; + + +function PIFVariantToVariant(Src: PIFVariant; var Dest: Variant): Boolean; +function VariantToPIFVariant(Exec: TPSExec; const Src: Variant; Dest: PIFVariant): Boolean; + +function PSGetRecField(const avar: TPSVariantIFC; Fieldno: Longint): TPSVariantIFC; +function PSGetArrayField(const avar: TPSVariantIFC; Fieldno: Longint): TPSVariantIFC; +function NewTPSVariantRecordIFC(avar: PPSVariant; Fieldno: Longint): TPSVariantIFC; + +function NewTPSVariantIFC(avar: PPSVariant; varparam: boolean): TPSVariantIFC; + +function NewPPSVariantIFC(avar: PPSVariant; varparam: boolean): PPSVariantIFC; + +procedure DisposePPSVariantIFC(aVar: PPSVariantIFC); + +procedure DisposePPSVariantIFCList(list: TPSList); + + +function PSGetObject(Src: Pointer; aType: TPSTypeRec): TObject; +function PSGetUInt(Src: Pointer; aType: TPSTypeRec): Cardinal; +{$IFNDEF PS_NOINT64} +function PSGetInt64(Src: Pointer; aType: TPSTypeRec): Int64; +{$ENDIF} +function PSGetReal(Src: Pointer; aType: TPSTypeRec): Extended; +function PSGetCurrency(Src: Pointer; aType: TPSTypeRec): Currency; +function PSGetInt(Src: Pointer; aType: TPSTypeRec): Longint; +function PSGetString(Src: Pointer; aType: TPSTypeRec): string; +function PSGetAnsiString(Src: Pointer; aType: TPSTypeRec): tbtString; +{$IFNDEF PS_NOWIDESTRING} +function PSGetWideString(Src: Pointer; aType: TPSTypeRec): tbtWideString; +function PSGetUnicodeString(Src: Pointer; aType: TPSTypeRec): tbtunicodestring; +{$ENDIF} + +procedure PSSetObject(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; Const val: TObject); +procedure PSSetUInt(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Cardinal); +{$IFNDEF PS_NOINT64} +procedure PSSetInt64(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Int64); +{$ENDIF} +procedure PSSetReal(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Extended); +procedure PSSetCurrency(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Currency); +procedure PSSetInt(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Longint); +procedure PSSetString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: String); +procedure PSSetAnsiString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: tbtString); +{$IFNDEF PS_NOWIDESTRING} +procedure PSSetWideString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: tbtWideString); +procedure PSSetUnicodeString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: tbtunicodestring); +{$ENDIF} + +procedure VNSetPointerTo(const Src: TPSVariantIFC; Data: Pointer; aType: TPSTypeRec); + +function VNGetUInt(const Src: TPSVariantIFC): Cardinal; +{$IFNDEF PS_NOINT64} +function VNGetInt64(const Src: TPSVariantIFC): Int64; +{$ENDIF} +function VNGetReal(const Src: TPSVariantIFC): Extended; +function VNGetCurrency(const Src: TPSVariantIFC): Currency; +function VNGetInt(const Src: TPSVariantIFC): Longint; +function VNGetString(const Src: TPSVariantIFC): String; +function VNGetAnsiString(const Src: TPSVariantIFC): tbtString; +{$IFNDEF PS_NOWIDESTRING} +function VNGetWideString(const Src: TPSVariantIFC): tbtWideString; +function VNGetUnicodeString(const Src: TPSVariantIFC): tbtunicodestring; +{$ENDIF} + +procedure VNSetUInt(const Src: TPSVariantIFC; const Val: Cardinal); +{$IFNDEF PS_NOINT64} +procedure VNSetInt64(const Src: TPSVariantIFC; const Val: Int64); +{$ENDIF} +procedure VNSetReal(const Src: TPSVariantIFC; const Val: Extended); +procedure VNSetCurrency(const Src: TPSVariantIFC; const Val: Currency); +procedure VNSetInt(const Src: TPSVariantIFC; const Val: Longint); +procedure VNSetString(const Src: TPSVariantIFC; const Val: String); +procedure VNSetAnsiString(const Src: TPSVariantIFC; const Val: tbtString); +{$IFNDEF PS_NOWIDESTRING} +procedure VNSetWideString(const Src: TPSVariantIFC; const Val: tbtWideString); +procedure VNSetUnicodeString(const Src: TPSVariantIFC; const Val: tbtunicodestring); +{$ENDIF} + +function VGetUInt(const Src: PIFVariant): Cardinal; +{$IFNDEF PS_NOINT64} +function VGetInt64(const Src: PIFVariant): Int64; +{$ENDIF} +function VGetReal(const Src: PIFVariant): Extended; +function VGetCurrency(const Src: PIFVariant): Currency; +function VGetInt(const Src: PIFVariant): Longint; +function VGetString(const Src: PIFVariant): String; +function VGetAnsiString(const Src: PIFVariant): tbtString; +{$IFNDEF PS_NOWIDESTRING} +function VGetWideString(const Src: PIFVariant): tbtWideString; +function VGetUnicodeString(const Src: PIFVariant): tbtunicodestring; +{$ENDIF} + +procedure VSetPointerTo(const Src: PIFVariant; Data: Pointer; aType: TPSTypeRec); +procedure VSetUInt(const Src: PIFVariant; const Val: Cardinal); +{$IFNDEF PS_NOINT64} +procedure VSetInt64(const Src: PIFVariant; const Val: Int64); +{$ENDIF} +procedure VSetReal(const Src: PIFVariant; const Val: Extended); +procedure VSetCurrency(const Src: PIFVariant; const Val: Currency); +procedure VSetInt(const Src: PIFVariant; const Val: Longint); +procedure VSetString(const Src: PIFVariant; const Val: string); +procedure VSetAnsiString(const Src: PIFVariant; const Val: tbtString); +{$IFNDEF PS_NOWIDESTRING} +procedure VSetWideString(const Src: PIFVariant; const Val: tbtWideString); +procedure VSetUnicodeString(const Src: PIFVariant; const Val: tbtunicodestring); +{$ENDIF} + +type + + EPSException = class(Exception) + private + FProcPos: Cardinal; + FProcNo: Cardinal; + FExec: TPSExec; + public + + constructor Create(const Error: tbtstring; Exec: TPSExec; Procno, ProcPos: Cardinal); + + property ProcNo: Cardinal read FProcNo; + + property ProcPos: Cardinal read FProcPos; + + property Exec: TPSExec read FExec; + end; + + TPSRuntimeClass = class + protected + FClassName: tbtstring; + FClassNameHash: Longint; + + FClassItems: TPSList; + FClass: TClass; + + FEndOfVmt: Longint; + public + + procedure RegisterConstructor(ProcPtr: Pointer; const Name: tbtstring); + + procedure RegisterVirtualConstructor(ProcPtr: Pointer; const Name: tbtstring); + + procedure RegisterMethod(ProcPtr: Pointer; const Name: tbtstring); + + procedure RegisterVirtualMethod(ProcPtr: Pointer; const Name: tbtstring); + + procedure RegisterVirtualAbstractMethod(ClassDef: TClass; ProcPtr: Pointer; const Name: tbtstring); + + procedure RegisterPropertyHelper(ReadFunc, WriteFunc: Pointer; const Name: tbtstring); + + procedure RegisterPropertyHelperName(ReadFunc, WriteFunc: Pointer; const Name: tbtstring); + + procedure RegisterEventPropertyHelper(ReadFunc, WriteFunc: Pointer; const Name: tbtstring); + + constructor Create(aClass: TClass; const AName: tbtstring); + + destructor Destroy; override; + end; + + TPSRuntimeClassImporter = class + private + FClasses: TPSList; + public + + constructor Create; + + constructor CreateAndRegister(Exec: TPSexec; AutoFree: Boolean); + + destructor Destroy; override; + + function Add(aClass: TClass): TPSRuntimeClass; + + function Add2(aClass: TClass; const Name: tbtstring): TPSRuntimeClass; + + procedure Clear; + + function FindClass(const Name: tbtstring): TPSRuntimeClass; + end; + TIFPSRuntimeClassImporter = TPSRuntimeClassImporter; + TPSResourceFreeProc = procedure (Sender: TPSExec; P: TPSRuntimeClassImporter); + + +procedure RegisterClassLibraryRuntime(SE: TPSExec; Importer: TPSRuntimeClassImporter); + +procedure SetVariantToClass(V: PIFVariant; Cl: TObject); +{$IFNDEF PS_NOINTERFACES} +procedure SetVariantToInterface(V: PIFVariant; Cl: IUnknown); +{$ENDIF} + +procedure MyAllMethodsHandler; + +function GetMethodInfoRec(SE: TPSExec; ProcNo: Cardinal): Pointer; + +function MkMethod(FSE: TPSExec; No: Cardinal): TMethod; + +type + TIFInternalProcRec = TPSInternalProcRec; + TIFError = TPSError; + TIFStatus = TPSStatus; + TIFPSExec = TPSExec; + TIFPSStack = TPSStack; + TIFTypeRec = TPSTypeRec; + + + TPSCallingConvention = uPSUtils.TPSCallingConvention; +const + + cdRegister = uPSUtils.cdRegister; + + cdPascal = uPSUtils.cdPascal; + + cdCdecl = uPSUtils.cdCdecl; + + cdStdCall = uPSUtils.cdStdCall; + + InvalidVal = Cardinal(-1); + +function PSDynArrayGetLength(arr: Pointer; aType: TPSTypeRec): Longint; +procedure PSDynArraySetLength(var arr: Pointer; aType: TPSTypeRec; NewLength: Longint); + +function GetPSArrayLength(Arr: PIFVariant): Longint; +procedure SetPSArrayLength(Arr: PIFVariant; NewLength: Longint); + +function PSVariantToString(const p: TPSVariantIFC; const ClassProperties: tbtstring): tbtstring; +function MakeString(const s: tbtstring): tbtstring; +{$IFNDEF PS_NOWIDESTRING} +function MakeWString(const s: tbtunicodestring): tbtstring; +{$ENDIF} + +{$IFNDEF PS_NOIDISPATCH} +function IDispatchInvoke(Self: IDispatch; PropertySet: Boolean; const Name: tbtString; const Par: array of Variant): Variant; +{$ENDIF} + + +implementation +uses + TypInfo {$IFDEF DELPHI3UP}{$IFNDEF FPC} , ComObj {$ENDIF}{$ENDIF}; + +{$IFDEF DELPHI3UP } +resourceString +{$ELSE } +const +{$ENDIF } + + RPS_UnknownIdentifier = 'Unknown Identifier'; + RPS_Exception = 'Exception: %s'; + RPS_Invalid = '[Invalid]'; + + //- PSErrorToString + RPS_NoError = 'No Error'; + RPS_CannotImport = 'Cannot Import %s'; + RPS_InvalidType = 'Invalid Type'; + RPS_InternalError = 'Internal error'; + RPS_InvalidHeader = 'Invalid Header'; + RPS_InvalidOpcode = 'Invalid Opcode'; + RPS_InvalidOpcodeParameter = 'Invalid Opcode Parameter'; + RPS_NoMainProc = 'no Main Proc'; + RPS_OutOfGlobalVarsRange = 'Out of Global Vars range'; + RPS_OutOfProcRange = 'Out of Proc Range'; + RPS_OutOfRange = 'Out Of Range'; + RPS_OutOfStackRange = 'Out Of Stack Range'; + RPS_TypeMismatch = 'Type Mismatch'; + RPS_UnexpectedEof = 'Unexpected End Of File'; + RPS_VersionError = 'Version error'; + RPS_DivideByZero = 'divide by Zero'; + RPS_MathError = 'Math error'; + RPS_CouldNotCallProc = 'Could not call proc'; + RPS_OutofRecordRange = 'Out of Record Fields Range'; + RPS_NullPointerException = 'Null Pointer Exception'; + RPS_NullVariantError = 'Null variant error'; + RPS_OutOfMemory = 'Out Of Memory'; + RPS_InterfaceNotSupported = 'Interface not supported'; + RPS_UnknownError = 'Unknown error'; + + + RPS_InvalidVariable = 'Invalid variable'; + RPS_InvalidArray = 'Invalid array'; + RPS_OLEError = 'OLE error %.8x'; + RPS_UnknownProcedure = 'Unknown procedure'; + RPS_NotEnoughParameters = 'Not enough parameters'; + RPS_InvalidParameter = 'Invalid parameter'; + RPS_TooManyParameters = 'Too many parameters'; + RPS_OutOfStringRange = 'Out of string range'; + RPS_CannotCastInterface = 'Cannot cast an interface'; + RPS_CannotCastObject = 'Cannot cast an object'; + RPS_CapacityLength = 'Capacity < Length'; + RPS_CanOnlySendLastItem = 'Can only remove last item from stack'; + RPS_NILInterfaceException = 'Nil interface'; + RPS_UnknownMethod = 'Unknown method'; + + + +type + PPSExportedVar = ^TPSExportedVar; + TPSExportedVar = record + FName: tbtstring; + FNameHash: Longint; + FVarNo: Cardinal; + end; + PRaiseFrame = ^TRaiseFrame; + TRaiseFrame = record + NextRaise: PRaiseFrame; + ExceptAddr: Pointer; + ExceptObject: TObject; + ExceptionRecord: Pointer; + end; + TPSExceptionHandler = class + CurrProc: TPSInternalProcRec; + BasePtr, StackSize: Cardinal; + FinallyOffset, ExceptOffset, Finally2Offset, EndOfBlock: Cardinal; + ExceptionData: TPSError; + ExceptionObject: TObject; + ExceptionParam: tbtString; + destructor Destroy; override; + end; + TPSHeader = packed record + HDR: Cardinal; + PSBuildNo: Cardinal; + TypeCount: Cardinal; + ProcCount: Cardinal; + VarCount: Cardinal; + MainProcNo: Cardinal; + ImportTableSize: Cardinal; + end; + + TPSExportItem = packed record + ProcNo: Cardinal; + NameLength: Cardinal; + DeclLength: Cardinal; + end; + + TPSType = packed record + BaseType: TPSBaseType; + end; + TPSProc = packed record + Flags: Byte; + end; + + TPSVar = packed record + TypeNo: Cardinal; + Flags: Byte; + end; + PSpecialProc = ^TSpecialProc; + TSpecialProc = record + P: TPSOnSpecialProcImport; + namehash: Longint; + Name: tbtstring; + tag: pointer; + end; + +destructor TPSExceptionHandler.Destroy; +begin + ExceptionObject.Free; + inherited; +end; + +procedure P_CM_A; begin end; +procedure P_CM_CA; begin end; +procedure P_CM_P; begin end; +procedure P_CM_PV; begin end; +procedure P_CM_PO; begin end; +procedure P_CM_C; begin end; +procedure P_CM_G; begin end; +procedure P_CM_CG; begin end; +procedure P_CM_CNG; begin end; +procedure P_CM_R; begin end; +procedure P_CM_ST; begin end; +procedure P_CM_PT; begin end; +procedure P_CM_CO; begin end; +procedure P_CM_CV; begin end; +procedure P_CM_SP; begin end; +procedure P_CM_BN; begin end; +procedure P_CM_VM; begin end; +procedure P_CM_SF; begin end; +procedure P_CM_FG; begin end; +procedure P_CM_PUEXH; begin end; +procedure P_CM_POEXH; begin end; +procedure P_CM_IN; begin end; +procedure P_CM_SPB; begin end; +procedure P_CM_INC; begin end; +procedure P_CM_DEC; begin end; + +function IntPIFVariantToVariant(Src: pointer; aType: TPSTypeRec; var Dest: Variant): Boolean; forward; + + +procedure Set_Union(Dest, Src: PByteArray; ByteSize: Integer); +var + i: Longint; +begin + for i := ByteSize -1 downto 0 do + Dest^[i] := Dest^[i] or Src^[i]; +end; + +procedure Set_Diff(Dest, Src: PByteArray; ByteSize: Integer); +var + i: Longint; +begin + for i := ByteSize -1 downto 0 do + Dest^[i] := Dest^[i] and not Src^[i]; +end; + +procedure Set_Intersect(Dest, Src: PByteArray; ByteSize: Integer); +var + i: Longint; +begin + for i := ByteSize -1 downto 0 do + Dest^[i] := Dest^[i] and Src^[i]; +end; + +procedure Set_Subset(Dest, Src: PByteArray; ByteSize: Integer; var Val: Boolean); +var + i: Integer; +begin + for i := ByteSize -1 downto 0 do + begin + if not (Src^[i] and Dest^[i] = Dest^[i]) then + begin + Val := False; + exit; + end; + end; + Val := True; +end; + +procedure Set_Equal(Dest, Src: PByteArray; ByteSize: Integer; var Val: Boolean); +var + i: Longint; +begin + for i := ByteSize -1 downto 0 do + begin + if Dest^[i] <> Src^[i] then + begin + Val := False; + exit; + end; + end; + val := True; +end; + +procedure Set_membership(Item: Longint; Src: PByteArray; var Val: Boolean); +begin + Val := (Src^[Item shr 3] and (1 shl (Item and 7))) <> 0; +end; + + +procedure RCIFreeProc(Sender: TPSExec; P: TPSRuntimeClassImporter); +begin + p.Free; +end; + +function Trim(const s: tbtstring): tbtstring; +begin + Result := s; + while (Length(result) > 0) and (Result[1] = #32) do Delete(Result, 1, 1); + while (Length(result) > 0) and (Result[Length(Result)] = #32) do Delete(Result, Length(Result), 1); +end; +(*function FloatToStr(E: Extended): tbtstring; +begin + Result := Sysutils.FloatToStr(e); +end;*) + +//------------------------------------------------------------------- + +function Padl(s: tbtstring; i: longInt): tbtstring; +begin + result := StringOfChar(tbtchar(' '), i - length(s)) + s; +end; +//------------------------------------------------------------------- + +function Padz(s: tbtString; i: longInt): tbtString; +begin + result := StringOfChar(tbtchar('0'), i - length(s)) + s; +end; +//------------------------------------------------------------------- + +function Padr(s: tbtString; i: longInt): tbtString; +begin + result := s + StringOfChar(tbtchar(' '), i - Length(s)); +end; +//------------------------------------------------------------------- + +{$IFNDEF PS_NOWIDESTRING} +function wPadl(s: tbtwidestring; i: longInt): tbtwidestring; +begin + result := StringOfChar(tbtwidechar(' '), i - length(s)) + s; +end; +//------------------------------------------------------------------- + +function wPadz(s: tbtwidestring; i: longInt): tbtwidestring; +begin + result := StringOfChar(tbtwidechar('0'), i - length(s)) + s; +end; +//------------------------------------------------------------------- + +function wPadr(s: tbtwidestring; i: longInt): tbtwidestring; +begin + result := s + StringOfChar(tbtwidechar(' '), i - Length(s)); +end; + +function uPadl(s: tbtunicodestring; i: longInt): tbtunicodestring; +begin + result := StringOfChar(tbtwidechar(' '), i - length(s)) + s; +end; +//------------------------------------------------------------------- + +function uPadz(s: tbtunicodestring; i: longInt): tbtunicodestring; +begin + result := StringOfChar(tbtwidechar('0'), i - length(s)) + s; +end; +//------------------------------------------------------------------- + +function uPadr(s: tbtunicodestring; i: longInt): tbtunicodestring; +begin + result := s + StringOfChar(tbtwidechar(' '), i - Length(s)); +end; + +{$ENDIF} +{$IFNDEF PS_NOWIDESTRING} +function MakeWString(const s: tbtunicodestring): tbtString; +var + i: Longint; + e: tbtString; + b: boolean; +begin + Result := tbtString(s); + i := 1; + b := false; + while i <= length(result) do + begin + if Result[i] = '''' then + begin + if not b then + begin + b := true; + Insert('''', Result, i); + inc(i); + end; + Insert('''', Result, i); + inc(i, 2); + end else if (Result[i] < #32) or (Result[i] > #255) then + begin + e := '#'+inttostr(ord(Result[i])); + Delete(Result, i, 1); + if b then + begin + b := false; + Insert('''', Result, i); + inc(i); + end; + Insert(e, Result, i); + inc(i, length(e)); + end else begin + if not b then + begin + b := true; + Insert('''', Result, i); + inc(i, 2); + end else + inc(i); + end; + end; + if b then + begin + Result := Result + ''''; + end; + if Result = '' then + Result := ''''''; +end; +{$ENDIF} +function MakeString(const s: tbtString): tbtString; +var + i: Longint; + e: tbtString; + b: boolean; +begin + Result := s; + i := 1; + b := false; + while i <= length(result) do + begin + if Result[i] = '''' then + begin + if not b then + begin + b := true; + Insert('''', Result, i); + inc(i); + end; + Insert('''', Result, i); + inc(i, 2); + end else if (Result[i] < #32) then + begin + e := '#'+inttostr(ord(Result[i])); + Delete(Result, i, 1); + if b then + begin + b := false; + Insert('''', Result, i); + inc(i); + end; + Insert(e, Result, i); + inc(i, length(e)); + end else begin + if not b then + begin + b := true; + Insert('''', Result, i); + inc(i, 2); + end else + inc(i); + end; + end; + if b then + begin + Result := Result + ''''; + end; + if Result = '' then + Result := ''''''; +end; + +function SafeStr(const s: tbtString): tbtString; +var + i : Longint; +begin + Result := s; + for i := 1 to length(s) do + begin + if s[i] in [#0..#31] then + begin + Result := Copy(s, 1, i-1); + exit; + end; + end; + +end; + +function PropertyToString(Instance: TObject; PName: tbtString): tbtString; +var + s: tbtString; + i: Longint; + PP: PPropInfo; +begin + if PName = '' then + begin + Result := tbtString(Instance.ClassName); + exit; + end; + while Length(PName) > 0 do + begin + i := pos(tbtChar('.'), pname); + if i = 0 then + begin + s := Trim(PNAme); + pname := ''; + end else begin + s := trim(Copy(PName, 1, i-1)); + Delete(PName, 1, i); + end; + pp := GetPropInfo(PTypeInfo(Instance.ClassInfo), string(s)); + if pp = nil then begin Result := tbtstring(RPS_UnknownIdentifier); exit; end; + + + case pp^.PropType^.Kind of + tkInteger: begin Result := IntToStr(GetOrdProp(Instance, pp)); exit; end; + tkChar: begin Result := '#'+IntToStr(GetOrdProp(Instance, pp)); exit; end; + tkEnumeration: begin Result := tbtstring(GetEnumName(pp^.PropType{$IFNDEF FPC}{$IFDEF DELPHI3UP}^{$ENDIF}{$ENDIF}, GetOrdProp(Instance, pp))); exit; end; + tkFloat: begin Result := FloatToStr(GetFloatProp(Instance, PP)); exit; end; + tkString, tkLString: begin Result := ''''+tbtString(GetStrProp(Instance, PP))+''''; exit; end; + tkSet: begin Result := '[Set]'; exit; end; + tkClass: begin Instance := TObject(GetOrdProp(Instance, pp)); end; + tkMethod: begin Result := '[Method]'; exit; end; + tkVariant: begin Result := '[Variant]'; exit; end; + {$IFDEF DELPHI6UP} + {$IFNDEF PS_NOWIDESTRING} + tkWString: begin Result := ''''+tbtString(GetWideStrProp(Instance, pp))+''; end; {$ENDIF} + {$ENDIF} + else begin Result := '[Unknown]'; exit; end; + end; + if Instance = nil then begin result := 'nil'; exit; end; + end; + Result := tbtstring(Instance.ClassName); +end; + +function ClassVariantInfo(const pvar: TPSVariantIFC; const PropertyName: tbtString): tbtString; +begin + if pvar.aType.BaseType = btClass then + begin + if TObject(pvar.Dta^) = nil then + Result := 'nil' + else + Result := PropertyToString(TObject(pvar.Dta^), PropertyName); + end else if pvar.atype.basetype = btInterface then + Result := 'Interface' + else Result := tbtstring(RPS_InvalidType); +end; + +function PSVariantToString(const p: TPSVariantIFC; const ClassProperties: tbtString): tbtString; +var + i, n: Longint; +begin + if p.Dta = nil then + begin + Result := 'nil'; + exit; + end; + if (p.aType.BaseType = btVariant) then + begin + try + if TVarData(p.Dta^).VType = varDispatch then + Result := 'Variant(IDispatch)' + else if TVarData(p.Dta^).VType = varNull then + REsult := 'Null' + else if (TVarData(p.Dta^).VType = varOleStr) then + {$IFDEF PS_NOWIDESTRING} + Result := MakeString(Variant(p.Dta^)) + {$ELSE} + Result := MakeWString(variant(p.dta^)) + {$ENDIF} + else if TVarData(p.Dta^).VType = varString then + Result := MakeString(tbtstring(variant(p.Dta^))) + else + Result := tbtstring(Variant(p.Dta^)); + except + on e: Exception do + Result := tbtstring(Format (RPS_Exception, [e.Message])); + end; + exit; + end; + case p.aType.BaseType of + btProcptr: begin Result := 'Proc: '+inttostr(tbtu32(p.Dta^)); end; + btU8: str(tbtu8(p.dta^), Result); + btS8: str(tbts8(p.dta^), Result); + btU16: str(tbtu16(p.dta^), Result); + btS16: str(tbts16(p.dta^), Result); + btU32: str(tbtu32(p.dta^), Result); + btS32: str(tbts32(p.dta^), Result); + btSingle: str(tbtsingle(p.dta^), Result); + btDouble: str(tbtdouble(p.dta^), Result); + btExtended: str(tbtextended(p.dta^), Result); + btString: Result := makestring(tbtString(p.dta^)); + btPChar: + begin + if PansiChar(p.dta^) = nil then + Result := 'nil' + else + Result := MakeString(PAnsiChar(p.dta^)); + end; + btchar: Result := MakeString(tbtchar(p.dta^)); + {$IFNDEF PS_NOWIDESTRING} + btwidechar: Result := MakeWString(tbtwidechar(p.dta^)); + btWideString: Result := MakeWString(tbtwidestring(p.dta^)); + btUnicodeString: Result := MakeWString(tbtUnicodeString(p.dta^)); + {$ENDIF} + {$IFNDEF PS_NOINT64}btS64: str(tbts64(p.dta^), Result);{$ENDIF} + btStaticArray, btArray: + begin + Result := ''; + if p.aType.BaseType = btStaticArray then + n := TPSTypeRec_StaticArray(p.aType).Size + else + n := PSDynArrayGetLength(Pointer(p.dta^), p.aType); + for i := 0 to n-1 do begin + if Result <> '' then + Result := Result + ', '; + Result := Result + PSVariantToString(PSGetArrayField(p, i), ''); + end; + Result := '[' + Result + ']'; + end; + btRecord: + begin + Result := ''; + n := TPSTypeRec_Record(p.aType).FFieldTypes.Count; + for i := 0 to n-1 do begin + if Result <> '' then + Result := Result + ', '; + Result := Result + PSVariantToString(PSGetRecField(p, i), ''); + end; + Result := '(' + Result + ')'; + end; + btPointer: Result := 'Nil'; + btClass, btInterface: + begin + Result := ClassVariantInfo(p, ClassProperties) + end; + else + Result := tbtString(RPS_Invalid); + end; +end; + + + +function TIFErrorToString(x: TPSError; const Param: tbtString): tbtString; +begin + Result := PSErrorToString(x,param); +end; + +function PSErrorToString(x: TPSError; const Param: tbtString): tbtString; +begin + case x of + ErNoError: Result := tbtString(RPS_NoError); + erCannotImport: Result := tbtString(Format (RPS_CannotImport, [Safestr(Param)])); + erInvalidType: Result := tbtString(RPS_InvalidType); + ErInternalError: Result := tbtString(RPS_InternalError); + erInvalidHeader: Result := tbtString(RPS_InvalidHeader); + erInvalidOpcode: Result := tbtString(RPS_InvalidOpcode); + erInvalidOpcodeParameter: Result := tbtString(RPS_InvalidOpcodeParameter); + erNoMainProc: Result := tbtString(RPS_NoMainProc); + erOutOfGlobalVarsRange: Result := tbtString(RPS_OutOfGlobalVarsRange); + erOutOfProcRange: Result := tbtString(RPS_OutOfProcRange); + ErOutOfRange: Result := tbtString(RPS_OutOfRange); + erOutOfStackRange: Result := tbtString(RPS_OutOfStackRange); + ErTypeMismatch: Result := tbtString(RPS_TypeMismatch); + erUnexpectedEof: Result := tbtString(RPS_UnexpectedEof); + erVersionError: Result := tbtString(RPS_VersionError); + ErDivideByZero: Result := tbtString(RPS_DivideByZero); + erMathError: Result := tbtString(RPS_MathError); + erCouldNotCallProc: begin Result := tbtString(RPS_CouldNotCallProc); if (Param <> '') then Result := result +' ('+Param+')'; end; + erOutofRecordRange: Result := tbtString(RPS_OutofRecordRange); + erNullPointerException: Result := tbtString(RPS_NullPointerException); + erNullVariantError: Result := tbtString(RPS_NullVariantError); + erOutOfMemory: Result := tbtString(RPS_OutOfMemory); + erException: Result := tbtString(Format (RPS_Exception, [Param])); + erInterfaceNotSupported: Result := tbtString(RPS_InterfaceNotSupported); + erCustomError: Result := Param; + else + Result := tbtString(RPS_UnknownError); + end; + // +end; + + +procedure TPSTypeRec.CalcSize; +begin + case BaseType of + btVariant: FRealSize := sizeof(Variant); + btChar, bts8, btU8: FrealSize := 1 ; + {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}bts16, btU16: FrealSize := 2; + {$IFNDEF PS_NOWIDESTRING}btWideString, + btUnicodeString, + {$ENDIF}{$IFNDEF PS_NOINTERFACES}btInterface, {$ENDIF}btSingle, bts32, btU32, + btclass, btPChar, btString: FrealSize := PointerSize; + btProcPtr: FRealSize := 2 * sizeof(Pointer) + sizeof(Cardinal); + btCurrency: FrealSize := Sizeof(Currency); + btPointer: FRealSize := 2 * sizeof(Pointer) + sizeof(LongBool); // ptr, type, freewhendone + btDouble{$IFNDEF PS_NOINT64}, bts64{$ENDIF}: FrealSize := 8; + btExtended: FrealSize := SizeOf(Extended); + btReturnAddress: FrealSize := Sizeof(TBTReturnAddress); + else + FrealSize := 0; + end; +end; + +constructor TPSTypeRec.Create(Owner: TPSExec); +begin + inherited Create; + FAttributes := TPSRuntimeAttributes.Create(Owner); +end; + +destructor TPSTypeRec.Destroy; +begin + FAttributes.Free; + inherited destroy; +end; + +{ TPSTypeRec_Record } + +procedure TPSTypeRec_Record.CalcSize; +begin + inherited; + FrealSize := TPSTypeRec(FFieldTypes[FFieldTypes.Count-1]).RealSize + + IPointer(RealFieldOffsets[RealFieldOffsets.Count -1]); +end; + +constructor TPSTypeRec_Record.Create(Owner: TPSExec); +begin + inherited Create(Owner); + FRealFieldOffsets := TPSList.Create; + FFieldTypes := TPSList.Create; +end; + +destructor TPSTypeRec_Record.Destroy; +begin + FFieldTypes.Free; + FRealFieldOffsets.Free; + inherited Destroy; +end; + + +const + RTTISize = sizeof(TPSVariant); + +procedure InitializeVariant(p: Pointer; aType: TPSTypeRec); +var + t: TPSTypeRec; + i: Longint; +begin + case aType.BaseType of + btChar, bts8, btU8: tbtu8(p^) := 0; + {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}bts16, btU16: tbtu16(p^) := 0; + btSingle, bts32, btU32, + btPChar, btString, {$IFNDEF PS_NOWIDESTRING}btUnicodeString, btWideString, {$ENDIF}btClass, + btInterface, btArray: Pointer(P^) := nil; + btPointer: + begin + Pointer(p^) := nil; + Pointer(Pointer(IPointer(p)+PointerSize)^) := nil; + Pointer(Pointer(IPointer(p)+(2*PointerSize))^) := nil; + end; + btProcPtr: + begin + Longint(p^) := 0; + Pointer(Pointer(IPointer(p)+PointerSize)^) := nil; + Pointer(Pointer(IPointer(p)+(2*PointerSize))^) := nil; + end; + btCurrency: tbtCurrency(P^) := 0; + btDouble{$IFNDEF PS_NOINT64}, bts64{$ENDIF}: {$IFNDEF PS_NOINT64}tbtS64(P^) := 0{$ELSE}tbtdouble(p^) := 0 {$ENDIF}; + btExtended: tbtExtended(p^) := 0; + btVariant: Initialize(Variant(p^)); + btReturnAddress:; // there is no point in initializing a return address + btRecord: + begin + for i := 0 to TPSTypeRec_Record(aType).FFieldTypes.Count -1 do + begin + t := TPSTypeRec_Record(aType).FieldTypes[i]; + InitializeVariant(P, t); + p := Pointer(IPointer(p) + t.FrealSize); + end; + end; + btStaticArray: + begin + t := TPSTypeRec_Array(aType).ArrayType; + for i := 0 to TPSTypeRec_StaticArray(aType).Size -1 do + begin + InitializeVariant(p, t); + p := Pointer(IPointer(p) + t.RealSize); + end; + end; + btSet: + begin + FillChar(p^, TPSTypeRec_Set(aType).RealSize, 0); + end; + end; +end; + +procedure DestroyHeapVariant2(v: Pointer; aType: TPSTypeRec); forward; + +const + NeedFinalization = [btStaticArray, btRecord, btArray, btPointer, btVariant {$IFNDEF PS_NOINTERFACES}, btInterface{$ENDIF}, btString {$IFNDEF PS_NOWIDESTRING}, btUnicodestring,btWideString{$ENDIF}]; + +procedure FinalizeVariant(p: Pointer; aType: TPSTypeRec); +var + t: TPSTypeRec; + elsize: Cardinal; + i, l: Longint; + darr: Pointer; +begin + case aType.BaseType of + btString: tbtString(p^) := ''; + {$IFNDEF PS_NOWIDESTRING} + btWideString: tbtwidestring(p^) := ''; + btUnicodeString: tbtunicodestring(p^) := ''; + {$ENDIF} + {$IFNDEF PS_NOINTERFACES}btInterface: + begin + {$IFNDEF DELPHI3UP} + if IUnknown(p^) <> nil then + IUnknown(p^).Release; + {$ENDIF} + IUnknown(p^) := nil; + end; {$ENDIF} + btVariant: + begin + try + Finalize(Variant(p^)); + except + end; + end; + btPointer: + if Pointer(Pointer(IPointer(p)+PointerSize2)^) <> nil then + begin + DestroyHeapVariant2(Pointer(p^), Pointer(Pointer(IPointer(p)+PointerSize)^)); + Pointer(p^) := nil; + end; + btArray: + begin + if IPointer(P^) = 0 then exit; + darr := Pointer(IPointer(p^) - PointerSize2); + if Longint(darr^) < 0 then exit;// refcount < 0 means don't free + Dec(Longint(darr^)); + if Longint(darr^) <> 0 then exit; + t := TPSTypeRec_Array(aType).ArrayType; + elsize := t.RealSize; + darr := Pointer(IPointer(darr) + PointerSize); + l := Longint(darr^); + darr := Pointer(IPointer(darr) + PointerSize); + case t.BaseType of + btString, {$IFNDEF PS_NOWIDESTRING} + btUnicodeString, btWideString, {$ENDIF}{$IFNDEF PS_NOINTERFACES}btInterface, {$ENDIF}btArray, btStaticArray, + btRecord, btPointer, btVariant: + begin + for i := 0 to l -1 do + begin + FinalizeVariant(darr, t); + darr := Pointer(IPointer(darr) + elsize); + end; + end; + end; + FreeMem(Pointer(IPointer(p^) - IPointer(PointerSize2)), IPointer(Cardinal(l) * elsize) + IPointer(PointerSize2)); + Pointer(P^) := nil; + end; + btRecord: + begin + for i := 0 to TPSTypeRec_Record(aType).FFieldTypes.Count -1 do + begin + t := TPSTypeRec_Record(aType).FieldTypes[i]; + case t.BaseType of + btString, {$IFNDEF PS_NOWIDESTRING}btUnicodeString, btWideString, {$ENDIF}{$IFNDEF PS_NOINTERFACES}btInterface, {$ENDIF}btArray, btStaticArray, + btRecord: FinalizeVariant(p, t); + end; + p := Pointer(IPointer(p) + t.FrealSize); + end; + end; + btStaticArray: + begin + t := TPSTypeRec_Array(aType).ArrayType; + case t.BaseType of + btString, {$IFNDEF PS_NOWIDESTRING}btUnicodeString, btWideString, {$ENDIF}{$IFNDEF PS_NOINTERFACES}btInterface, {$ENDIF}btArray, btStaticArray, + btRecord: ; + else Exit; + end; + for i := 0 to TPSTypeRec_StaticArray(aType).Size -1 do + begin + FinalizeVariant(p, t); + p := Pointer(IPointer(p) + t.RealSize); + end; + end; + end; +end; + +function CreateHeapVariant2(aType: TPSTypeRec): Pointer; +begin + GetMem(Result, aType.RealSize); + InitializeVariant(Result, aType); +end; + +procedure DestroyHeapVariant2(v: Pointer; aType: TPSTypeRec); +begin + if v = nil then exit; + if atype.BaseType in NeedFinalization then + FinalizeVariant(v, aType); + FreeMem(v, aType.RealSize); +end; + + +function CreateHeapVariant(aType: TPSTypeRec): PPSVariant; +var + aSize: Longint; +begin + aSize := aType.RealSize + RTTISize; + GetMem(Result, aSize); + Result.FType := aType; + InitializeVariant(Pointer(IPointer(Result)+PointerSize), aType); +end; + +procedure DestroyHeapVariant(v: PPSVariant); +begin + if v = nil then exit; + if v.FType.BaseType in NeedFinalization then + FinalizeVariant(Pointer(IPointer(v)+PointerSize), v.FType); + FreeMem(v, v.FType.RealSize + RTTISize); +end; + +procedure FreePSVariantList(l: TPSList); +var + i: Longint; +begin + for i:= l.count -1 downto 0 do + DestroyHeapVariant(l[i]); + l.free; +end; + +procedure FreePIFVariantList(l: TPSList); +begin + FreePsVariantList(l); +end; + +{ TPSExec } + +procedure TPSExec.ClearFunctionList; +var + x: PProcRec; + l: Longint; +begin + for l := FAttributeTypes.Count -1 downto 0 do + begin + TPSAttributeType(FAttributeTypes.Data^[l]).Free; + end; + FAttributeTypes.Clear; + + for l := 0 to FRegProcs.Count - 1 do + begin + x := FRegProcs.Data^[l]; + if @x^.FreeProc <> nil then x^.FreeProc(Self, x); + Dispose(x); + end; + FRegProcs.Clear; + RegisterStandardProcs; +end; + +class function TPSExec.About: tbtString; +begin + Result := 'RemObjects Pascal Script. Copyright (c) 2004-2009 by RemObjects Software'; +end; + +procedure TPSExec.Cleanup; +var + I: Longint; + p: Pointer; +begin + if FStatus <> isLoaded then + exit; + FStack.Clear; + FTempVars.Clear; + for I := Longint(FGlobalVars.Count) - 1 downto 0 do + begin + p := FGlobalVars.Items[i]; + if PIFTypeRec(P^).BaseType in NeedFinalization then + FinalizeVariant(Pointer(IPointer(p)+PointerSize), Pointer(P^)); + InitializeVariant(Pointer(IPointer(p)+PointerSize), Pointer(P^)); + end; +end; + +procedure TPSExec.Clear; +var + I: Longint; + temp: PPSResource; + Proc: TPSResourceFreeProc; + pp: TPSExceptionHandler; +begin + for i := Longint(FExceptionStack.Count) -1 downto 0 do + begin + pp := FExceptionStack.Data^[i]; + pp.Free; + end; + for i := Longint(FResources.Count) -1 downto 0 do + begin + Temp := FResources.Data^[i]; + Proc := Temp^.Proc; + Proc(Self, Temp^.P); + Dispose(Temp); + end; + for i := Longint(FExportedVars.Count) -1 downto 0 do + Dispose(PPSExportedVar(FExportedVars.Data^[I])); + for I := Longint(FProcs.Count) - 1downto 0 do + TPSProcRec(FProcs.Data^[i]).Destroy; + FProcs.Clear; + FGlobalVars.Clear; + FStack.Clear; + for I := Longint(FTypes.Count) - 1downto 0 do + TPSTypeRec(FTypes.Data^[i]).Free; + FTypes.Clear; + FStatus := isNotLoaded; + FResources.Clear; + FExportedVars.Clear; + FExceptionStack.Clear; + FCurrStackBase := InvalidVal; +end; + +constructor TPSExec.Create; +begin + inherited Create; + FAttributeTypes := TPSList.Create; + FExceptionStack := TPSList.Create; + FCallCleanup := False; + FResources := TPSList.Create; + FTypes := TPSList.Create; + FProcs := TPSList.Create; + FGlobalVars := TPSStack.Create; + FTempVars := TPSStack.Create; + FMainProc := 0; + FStatus := isNotLoaded; + FRegProcs := TPSList.Create; + FExportedVars := TPSList.create; + FSpecialProcList := TPSList.Create; + RegisterStandardProcs; + FReturnAddressType := TPSTypeRec.Create(self); + FReturnAddressType.BaseType := btReturnAddress; + FReturnAddressType.CalcSize; + FVariantType := TPSTypeRec.Create(self); + FVariantType.BaseType := btVariant; + FVariantType.CalcSize; + FVariantArrayType := TPSTypeRec_Array.Create(self); + FVariantArrayType.BaseType := btArray; + FVariantArrayType.CalcSize; + TPSTypeRec_Array(FVariantArrayType).ArrayType := FVariantType; + FStack := TPSStack.Create; +end; + +destructor TPSExec.Destroy; +var + I: Longint; + x: PProcRec; + P: PSpecialProc; +begin + Clear; + FReturnAddressType.Free; + FVariantType.Free; + FVariantArrayType.Free; + + if ExObject <> nil then ExObject.Free; + for I := FSpecialProcList.Count -1 downto 0 do + begin + P := FSpecialProcList.Data^[I]; + Dispose(p); + end; + FResources.Free; + FExportedVars.Free; + FTempVars.Free; + FStack.Free; + FGlobalVars.Free; + FProcs.Free; + FTypes.Free; + FSpecialProcList.Free; + for i := FRegProcs.Count - 1 downto 0 do + begin + x := FRegProcs.Data^[i]; + if @x^.FreeProc <> nil then x^.FreeProc(Self, x); + Dispose(x); + end; + FRegProcs.Free; + FExceptionStack.Free; + for i := FAttributeTypes.Count -1 downto 0 do + begin + TPSAttributeType(FAttributeTypes[i]).Free; + end; + FAttributeTypes.Free; + inherited Destroy; +end; + +procedure TPSExec.ExceptionProc(proc, Position: Cardinal; Ex: TPSError; const s: tbtString; NewObject: TObject); +var + d, l: Longint; + pp: TPSExceptionHandler; +begin + ExProc := proc; + ExPos := Position; + ExEx := Ex; + ExParam := s; + if ExObject <> nil then + ExObject.Free; + ExObject := NewObject; + if Ex = eNoError then Exit; + for d := FExceptionStack.Count -1 downto 0 do + begin + pp := FExceptionStack[d]; + if Cardinal(FStack.Count) > pp.StackSize then + begin + for l := Longint(FStack.count) -1 downto Longint(pp.StackSize) do + FStack.Pop; + end; + if pp.CurrProc = nil then // no point in continuing + begin + pp.Free; + FExceptionStack.DeleteLast; + + FCurrStackBase := InvalidVal; + FStatus := isPaused; + exit; + end; + FCurrProc := pp.CurrProc; + FData := FCurrProc.Data; + FDataLength := FCurrProc.Length; + + FCurrStackBase := pp.BasePtr; + if pp.FinallyOffset <> InvalidVal then + begin + FCurrentPosition := pp.FinallyOffset; + pp.FinallyOffset := InvalidVal; + Exit; + end else if (pp.ExceptOffset <> InvalidVal) and (pp.ExceptOffset <> Cardinal(InvalidVal -1)) then + begin + FCurrentPosition := pp.ExceptOffset; + pp.ExceptOffset := Cardinal(InvalidVal -1); + pp.ExceptionObject := ExObject; + pp.ExceptionData := ExEx; + pp.ExceptionParam := ExParam; + ExObject := nil; + ExEx := ENoError; + Exit; + end else if pp.Finally2Offset <> InvalidVal then + begin + FCurrentPosition := pp.Finally2Offset; + pp.Finally2Offset := InvalidVal; + Exit; + end; + pp.Free; + FExceptionStack.DeleteLast; + end; + if FStatus <> isNotLoaded then + FStatus := isPaused; +end; + +function LookupProc(List: TPSList; const Name: ShortString): PProcRec; +var + h, l: Longint; + p: PProcRec; +begin + h := MakeHash(Name); + for l := List.Count - 1 downto 0 do + begin + p := List.Data^[l]; + if (p^.Hash = h) and (p^.Name = Name) then + begin + Result := List[l]; + exit; + end; + end; + Result := nil; +end; + +function TPSExec.ImportProc(const Name: ShortString; proc: TPSExternalProcRec): Boolean; +var + u: PProcRec; + fname: tbtString; + I, fnh: Longint; + P: PSpecialProc; + +begin + if name = '' then + begin + fname := proc.Decl; + fname := copy(fname, 1, pos(tbtchar(':'), fname)-1); + fnh := MakeHash(fname); + for I := FSpecialProcList.Count -1 downto 0 do + begin + p := FSpecialProcList[I]; + IF (p^.name = '') or ((p^.namehash = fnh) and (p^.name = fname)) then + begin + if p^.P(Self, Proc, p^.tag) then + begin + Result := True; + exit; + end; + end; + end; + Result := FAlse; + exit; + end; + u := LookupProc(FRegProcs, Name); + if u = nil then begin + Result := False; + exit; + end; + proc.ProcPtr := u^.ProcPtr; + proc.Ext1 := u^.Ext1; + proc.Ext2 := u^.Ext2; + Result := True; +end; + +function TPSExec.RegisterFunctionName(const Name: tbtString; ProcPtr: TPSProcPtr; Ext1, Ext2: Pointer): PProcRec; +var + p: PProcRec; + s: tbtString; +begin + s := FastUppercase(Name); + New(p); + p^.Name := s; + p^.Hash := MakeHash(s); + p^.ProcPtr := ProcPtr; + p^.FreeProc := nil; + p.Ext1 := Ext1; + p^.Ext2 := Ext2; + FRegProcs.Add(p); + Result := P; +end; + +function TPSExec.LoadData(const s: tbtString): Boolean; +var + HDR: TPSHeader; + Pos: Cardinal; + + function read(var Data; Len: Cardinal): Boolean; + begin + if Longint(Pos + Len) <= Length(s) then begin + Move(s[Pos + 1], Data, Len); + Pos := Pos + Len; + read := True; + end + else + read := False; + end; + function ReadAttributes(Dest: TPSRuntimeAttributes): Boolean; + var + Count: Cardinal; + i: Integer; + + function ReadAttrib: Boolean; + var + NameLen: Longint; + Name: tbtString; + TypeNo: Cardinal; + i, h, FieldCount: Longint; + att: TPSRuntimeAttribute; + varp: PIFVariant; + + begin + if (not Read(NameLen, 4)) or (NameLen > Length(s) - Longint(Pos)) then + begin + CMD_Err(ErOutOfRange); + Result := false; + exit; + end; + SetLength(Name, NameLen); + if not Read(Name[1], NameLen) then + begin + CMD_Err(ErOutOfRange); + Result := false; + exit; + end; + if not Read(FieldCount, 4) then + begin + CMD_Err(ErOutOfRange); + Result := false; + exit; + end; + att := Dest.Add; + att.AttribType := Name; + att.AttribTypeHash := MakeHash(att.AttribType); + for i := 0 to FieldCount -1 do + begin + if (not Read(TypeNo, 4)) or (TypeNo >= Cardinal(FTypes.Count)) then + begin + CMD_Err(ErOutOfRange); + Result := false; + exit; + end; + + varp := att.AddValue(FTypes[TypeNo]); + case VarP^.FType.BaseType of + btSet: + begin + if not read(PPSVariantSet(varp).Data, TPSTypeRec_Set(varp.FType).aByteSize) then + begin + CMD_Err(erOutOfRange); + + DestroyHeapVariant(VarP); + Result := False; + exit; + end; + end; + bts8, btchar, btU8: if not read(PPSVariantU8(VarP)^.data, 1) then + begin + CMD_Err(erOutOfRange); + DestroyHeapVariant(VarP); + Result := False; + exit; + end; + bts16, {$IFNDEF PS_NOWIDESTRING}btwidechar,{$ENDIF} btU16: if not read(PPSVariantU16(Varp)^.Data, SizeOf(TbtU16)) then begin + CMD_Err(ErOutOfRange); + DestroyHeapVariant(VarP); + Result := False; + exit; + end; + bts32, btU32: + begin + if FCurrentPosition + 3 >= FDataLength then + begin + Cmd_Err(erOutOfRange); + DestroyHeapVariant(VarP); + Result := False; + exit;; + end; + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + PPSVariantU32(varp)^.Data := unaligned(Cardinal((@FData^[FCurrentPosition])^)); + {$else} + PPSVariantU32(varp)^.Data := Cardinal((@FData^[FCurrentPosition])^); + {$endif} + Inc(FCurrentPosition, 4); + end; + btProcPtr: + begin + if FCurrentPosition + 3 >= FDataLength then + begin + Cmd_Err(erOutOfRange); + DestroyHeapVariant(VarP); + Result := False; + exit;; + end; + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + PPSVariantU32(varp)^.Data := unaligned(Cardinal((@FData^[FCurrentPosition])^)); + {$else} + PPSVariantU32(varp)^.Data := Cardinal((@FData^[FCurrentPosition])^); + {$endif} + if PPSVariantU32(varp)^.Data = 0 then + begin + PPSVariantProcPtr(varp)^.Ptr := nil; + PPSVariantProcPtr(varp)^.Self := nil; + end; + Inc(FCurrentPosition, 4); + end; + {$IFNDEF PS_NOINT64} + bts64: if not read(PPSVariantS64(VarP)^.Data, sizeof(tbts64)) then + begin + CMD_Err(erOutOfRange); + DestroyHeapVariant(VarP); + Result := False; + exit; + end; + {$ENDIF} + btSingle: if not read(PPSVariantSingle(VarP)^.Data, SizeOf(TbtSingle)) + then begin + CMD_Err(erOutOfRange); + DestroyHeapVariant(VarP); + Result := False; + exit; + end; + btDouble: if not read(PPSVariantDouble(varp)^.Data, SizeOf(TbtDouble)) + then begin + CMD_Err(erOutOfRange); + DestroyHeapVariant(VarP); + Result := False; + exit; + end; + btExtended: if not read(PPSVariantExtended(varp)^.Data, SizeOf(TbtExtended)) + then begin + CMD_Err(erOutOfRange); + DestroyHeapVariant(VarP); + Result := False; + exit; + end; + btCurrency: if not read(PPSVariantExtended(varp)^.Data, SizeOf(tbtCurrency)) + then begin + CMD_Err(erOutOfRange); + DestroyHeapVariant(VarP); + Result := False; + exit; + end; + btPchar, btString: + begin + if not read(NameLen, 4) then + begin + Cmd_Err(erOutOfRange); + DestroyHeapVariant(VarP); + Result := False; + exit; + end; + Inc(FCurrentPosition, 4); + SetLength(PPSVariantAString(varp)^.Data, NameLen); + if not read(PPSVariantAString(varp)^.Data[1], NameLen) then begin + CMD_Err(erOutOfRange); + DestroyHeapVariant(VarP); + Result := False; + exit; + end; + end; + {$IFNDEF PS_NOWIDESTRING} + btWidestring: + begin + if not read(NameLen, 4) then + begin + Cmd_Err(erOutOfRange); + DestroyHeapVariant(VarP); + Result := False; + exit; + end; + Inc(FCurrentPosition, 4); + SetLength(PPSVariantWString(varp).Data, NameLen); + if not read(PPSVariantWString(varp).Data[1], NameLen*2) then begin + CMD_Err(erOutOfRange); + DestroyHeapVariant(VarP); + Result := False; + exit; + end; + end; + btUnicodeString: + begin + if not read(NameLen, 4) then + begin + Cmd_Err(erOutOfRange); + DestroyHeapVariant(VarP); + Result := False; + exit; + end; + Inc(FCurrentPosition, 4); + SetLength(PPSVariantUString(varp).Data, NameLen); + if not read(PPSVariantUString(varp).Data[1], NameLen*2) then begin + CMD_Err(erOutOfRange); + DestroyHeapVariant(VarP); + Result := False; + exit; + end; + end; + {$ENDIF} + else begin + CMD_Err(erInvalidType); + DestroyHeapVariant(VarP); + Result := False; + exit; + end; + end; + end; + h := MakeHash(att.AttribType); + for i := FAttributeTypes.Count -1 downto 0 do + begin + if (TPSAttributeType(FAttributeTypes.Data^[i]).TypeNameHash = h) and + (TPSAttributeType(FAttributeTypes.Data^[i]).TypeName = att.AttribType) then + begin + if not TPSAttributeType(FAttributeTypes.Data^[i]).UseProc(Self, att.AttribType, Att) then + begin + Result := False; + exit; + end; + end; + end; + Result := True; + end; + + + begin + if not Read(Count, 4) then + begin + CMD_Err(erOutofRange); + Result := false; + exit; + end; + for i := 0 to Count -1 do + begin + if not ReadAttrib then + begin + Result := false; + exit; + end; + end; + Result := True; + end; + +{$WARNINGS OFF} + + function LoadTypes: Boolean; + var + currf: TPSType; + Curr: PIFTypeRec; + fe: Boolean; + l2, l: Longint; + d: Cardinal; + + function resolve(Dta: TPSTypeRec_Record): Boolean; + var + offs, l: Longint; + begin + offs := 0; + for l := 0 to Dta.FieldTypes.Count -1 do + begin + Dta.RealFieldOffsets.Add(Pointer(offs)); + offs := offs + TPSTypeRec(Dta.FieldTypes[l]).RealSize; + end; + Result := True; + end; + begin + LoadTypes := True; + for l := 0 to HDR.TypeCount - 1 do begin + if not read(currf, SizeOf(currf)) then begin + cmd_err(erUnexpectedEof); + LoadTypes := False; + exit; + end; + if (currf.BaseType and 128) <> 0 then begin + fe := True; + currf.BaseType := currf.BaseType - 128; + end else + fe := False; + case currf.BaseType of + {$IFNDEF PS_NOINT64}bts64, {$ENDIF} + btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btCurrency, + btExtended, btString, btPointer, btPChar, + btVariant, btChar{$IFNDEF PS_NOWIDESTRING}, btUnicodeString, btWideString, btWideChar{$ENDIF}: begin + curr := TPSTypeRec.Create(self); + Curr.BaseType := currf.BaseType; + FTypes.Add(Curr); + end; + btClass: + begin + Curr := TPSTypeRec_Class.Create(self); + if (not Read(d, 4)) or (d > 255) then + begin + curr.Free; + cmd_err(erUnexpectedEof); + LoadTypes := False; + exit; + end; + setlength(TPSTypeRec_Class(Curr).FCN, d); + if not Read(TPSTypeRec_Class(Curr).FCN[1], d) then + begin + curr.Free; + cmd_err(erUnexpectedEof); + LoadTypes := False; + exit; + end; + Curr.BaseType := currf.BaseType; + FTypes.Add(Curr); + end; + btProcPtr: + begin + Curr := TPSTypeRec_ProcPtr.Create(self); + if (not Read(d, 4)) or (d > 255) then + begin + curr.Free; + cmd_err(erUnexpectedEof); + LoadTypes := False; + exit; + end; + setlength(TPSTypeRec_ProcPtr(Curr).FParamInfo, d); + if not Read(TPSTypeRec_ProcPtr(Curr).FParamInfo[1], d) then + begin + curr.Free; + cmd_err(erUnexpectedEof); + LoadTypes := False; + exit; + end; + Curr.BaseType := currf.BaseType; + FTypes.Add(Curr); + end; +{$IFNDEF PS_NOINTERFACES} + btInterface: + begin + Curr := TPSTypeRec_Interface.Create(self); + if not Read(TPSTypeRec_Interface(Curr).FGUID, Sizeof(TGuid)) then + begin + curr.Free; + cmd_err(erUnexpectedEof); + LoadTypes := False; + exit; + end; + Curr.BaseType := currf.BaseType; + FTypes.Add(Curr); + end; +{$ENDIF} + btSet: + begin + Curr := TPSTypeRec_Set.Create(self); + if not Read(d, 4) then + begin + curr.Free; + cmd_err(erUnexpectedEof); + LoadTypes := False; + exit; + end; + if (d > 256) then + begin + curr.Free; + cmd_err(erTypeMismatch); + LoadTypes := False; + exit; + end; + + TPSTypeRec_Set(curr).aBitSize := d; + TPSTypeRec_Set(curr).aByteSize := TPSTypeRec_Set(curr).aBitSize shr 3; + if (TPSTypeRec_Set(curr).aBitSize and 7) <> 0 then inc(TPSTypeRec_Set(curr).fbytesize); + Curr.BaseType := currf.BaseType; + FTypes.Add(Curr); + end; + btStaticArray: + begin + curr := TPSTypeRec_StaticArray.Create(self); + if not Read(d, 4) then + begin + curr.Free; + cmd_err(erUnexpectedEof); + LoadTypes := False; + exit; + end; + if (d >= FTypes.Count) then + begin + curr.Free; + cmd_err(erTypeMismatch); + LoadTypes := False; + exit; + end; + TPSTypeRec_StaticArray(curr).ArrayType := FTypes[d]; + if not Read(d, 4) then + begin + curr.Free; + cmd_err(erUnexpectedEof); + LoadTypes := False; + exit; + end; + if d > (MaxInt div 4) then + begin + curr.Free; + cmd_err(erUnexpectedEof); + LoadTypes := False; + exit; + end; + TPSTypeRec_StaticArray(curr).Size := d; + if not Read(d,4) then //<-additional StartOffset + begin + curr.Free; + cmd_err(erUnexpectedEof); + LoadTypes:=false; + Exit; + end; + TPSTypeRec_StaticArray(curr).StartOffset:=d; + + Curr.BaseType := currf.BaseType; + FTypes.Add(Curr); + end; + btArray: begin + Curr := TPSTypeRec_Array.Create(self); + if not read(d, 4) then + begin // Read type + curr.Free; + cmd_err(erUnexpectedEof); + LoadTypes := False; + exit; + end; + if (d >= FTypes.Count) then + begin + curr.Free; + cmd_err(erTypeMismatch); + LoadTypes := False; + exit; + end; + Curr.BaseType := currf.BaseType; + TPSTypeRec_Array(curr).ArrayType := FTypes[d]; + FTypes.Add(Curr); + end; + btRecord: + begin + curr := TPSTypeRec_Record.Create(self); + if not read(d, 4) or (d = 0) then + begin + curr.Free; + cmd_err(erUnexpectedEof); + LoadTypes := false; + exit; + end; + while d > 0 do + begin + if not Read(l2, 4) then + begin + curr.Free; + cmd_err(erUnexpectedEof); + LoadTypes := false; + exit; + end; + if Cardinal(l2) >= FTypes.Count then + begin + curr.Free; + cmd_err(ErOutOfRange); + LoadTypes := false; + exit; + end; + TPSTypeRec_Record(curR).FFieldTypes.Add(FTypes[l2]); + Dec(D); + end; + if not resolve(TPSTypeRec_Record(curr)) then + begin + curr.Free; + cmd_err(erInvalidType); + LoadTypes := False; + exit; + end; + Curr.BaseType := currf.BaseType; + FTypes.Add(Curr); + end; + else begin + LoadTypes := False; + CMD_Err(erInvalidType); + exit; + end; + end; + if fe then begin + if not read(d, 4) then begin + cmd_err(erUnexpectedEof); + LoadTypes := False; + exit; + end; + if d > PSAddrNegativeStackStart then + begin + cmd_err(erInvalidType); + LoadTypes := False; + exit; + end; + SetLength(Curr.FExportName, d); + if not read(Curr.fExportName[1], d) then + begin + cmd_err(erUnexpectedEof); + LoadTypes := False; + exit; + end; + Curr.ExportNameHash := MakeHash(Curr.ExportName); + end; + curr.CalcSize; + if HDR.PSBuildNo >= 21 then // since build 21 we support attributes + begin + if not ReadAttributes(Curr.Attributes) then + begin + LoadTypes := False; + exit; + end; + end; + end; + end; + + function LoadProcs: Boolean; + var + Rec: TPSProc; + n: tbtString; + b: Byte; + l, L2, L3: Longint; + Curr: TPSProcRec; + begin + LoadProcs := True; + for l := 0 to HDR.ProcCount - 1 do begin + if not read(Rec, SizeOf(Rec)) then begin + cmd_err(erUnexpectedEof); + LoadProcs := False; + exit; + end; + if (Rec.Flags and 1) <> 0 then + begin + Curr := TPSExternalProcRec.Create(Self); + if not read(b, 1) then begin + Curr.Free; + cmd_err(erUnexpectedEof); + LoadProcs := False; + exit; + end; + SetLength(n, b); + if not read(n[1], b) then begin + Curr.Free; + cmd_err(erUnexpectedEof); + LoadProcs := False; + exit; + end; + TPSExternalProcRec(Curr).Name := n; + if (Rec.Flags and 3 = 3) then + begin + if (not Read(L2, 4)) or (L2 > Length(s) - Pos) then + begin + Curr.Free; + cmd_err(erUnexpectedEof); + LoadProcs := False; + exit; + end; + SetLength(n, L2); + Read(n[1], L2); // no check is needed + TPSExternalProcRec(Curr).FDecl := n; + end; + if not ImportProc(TPSExternalProcRec(Curr).Name, TPSExternalProcRec(Curr)) then begin + if TPSExternalProcRec(Curr).Name <> '' then + CMD_Err2(erCannotImport, TPSExternalProcRec(Curr).Name) + else + CMD_Err2(erCannotImport, TPSExternalProcRec(curr).Decl); + Curr.Free; + LoadProcs := False; + exit; + end; + end else begin + Curr := TPSInternalProcRec.Create(Self); + if not read(L2, 4) then begin + Curr.Free; + cmd_err(erUnexpectedEof); + LoadProcs := False; + exit; + end; + if not read(L3, 4) then begin + Curr.Free; + cmd_err(erUnexpectedEof); + LoadProcs := False; + exit; + end; + if (L2 < 0) or (L2 >= Length(s)) or (L2 + L3 > Length(s)) or (L3 = 0) then begin + Curr.Free; + cmd_err(erUnexpectedEof); + LoadProcs := False; + exit; + end; + + GetMem(TPSInternalProcRec(Curr).FData, L3); + Move(s[L2 + 1], TPSInternalProcRec(Curr).FData^, L3); + TPSInternalProcRec(Curr).FLength := L3; + if (Rec.Flags and 2) <> 0 then begin // exported + if not read(L3, 4) then begin + Curr.Free; + cmd_err(erUnexpectedEof); + LoadProcs := False; + exit; + end; + if L3 > PSAddrNegativeStackStart then begin + Curr.Free; + cmd_err(erUnexpectedEof); + LoadProcs := False; + exit; + end; + SetLength(TPSInternalProcRec(Curr).FExportName, L3); + if not read(TPSInternalProcRec(Curr).FExportName[1], L3) then begin + Curr.Free; + cmd_err(erUnexpectedEof); + LoadProcs := False; + exit; + end; + if not read(L3, 4) then begin + Curr.Free; + cmd_err(erUnexpectedEof); + LoadProcs := False; + exit; + end; + if L3 > PSAddrNegativeStackStart then begin + Curr.Free; + cmd_err(erUnexpectedEof); + LoadProcs := False; + exit; + end; + SetLength(TPSInternalProcRec(Curr).FExportDecl, L3); + if not read(TPSInternalProcRec(Curr).FExportDecl[1], L3) then begin + Curr.Free; + cmd_err(erUnexpectedEof); + LoadProcs := False; + exit; + end; + TPSInternalProcRec(Curr).FExportNameHash := MakeHash(TPSInternalProcRec(Curr).ExportName); + end; + end; + if (Rec.Flags and 4) <> 0 then + begin + if not ReadAttributes(Curr.Attributes) then + begin + Curr.Free; + LoadProcs := False; + exit; + end; + end; + FProcs.Add(Curr); + end; + end; +{$WARNINGS ON} + + function LoadVars: Boolean; + var + l, n: Longint; + e: PPSExportedVar; + Rec: TPSVar; + Curr: PIfVariant; + begin + LoadVars := True; + for l := 0 to HDR.VarCount - 1 do begin + if not read(Rec, SizeOf(Rec)) then begin + cmd_err(erUnexpectedEof); + LoadVars := False; + exit; + end; + if Rec.TypeNo >= HDR.TypeCount then begin + cmd_err(erInvalidType); + LoadVars := False; + exit; + end; + Curr := FGlobalVars.PushType(FTypes.Data^[Rec.TypeNo]); + if Curr = nil then begin + cmd_err(erInvalidType); + LoadVars := False; + exit; + end; + if (Rec.Flags and 1) <> 0 then + begin + if not read(n, 4) then begin + cmd_err(erUnexpectedEof); + LoadVars := False; + exit; + end; + new(e); + try + SetLength(e^.FName, n); + if not Read(e^.FName[1], n) then + begin + dispose(e); + cmd_err(erUnexpectedEof); + LoadVars := False; + exit; + end; + e^.FNameHash := MakeHash(e^.FName); + e^.FVarNo := FGlobalVars.Count; + FExportedVars.Add(E); + except + dispose(e); + cmd_err(erInvalidType); + LoadVars := False; + exit; + end; + end; + end; + end; + +begin + Clear; + Pos := 0; + LoadData := False; + if not read(HDR, SizeOf(HDR)) then + begin + CMD_Err(erInvalidHeader); + exit; + end; + if HDR.HDR <> PSValidHeader then + begin + CMD_Err(erInvalidHeader); + exit; + end; + if (HDR.PSBuildNo > PSCurrentBuildNo) or (HDR.PSBuildNo < PSLowBuildSupport) then begin + CMD_Err(erInvalidHeader); + exit; + end; + if not LoadTypes then + begin + Clear; + exit; + end; + if not LoadProcs then + begin + Clear; + exit; + end; + if not LoadVars then + begin + Clear; + exit; + end; + if (HDR.MainProcNo >= FProcs.Count) and (HDR.MainProcNo <> InvalidVal)then begin + CMD_Err(erNoMainProc); + Clear; + exit; + end; + // Load Import Table + FMainProc := HDR.MainProcNo; + FStatus := isLoaded; + Result := True; +end; + + +procedure TPSExec.Pause; +begin + if FStatus = isRunning then + FStatus := isPaused; +end; + +function TPSExec.ReadData(var Data; Len: Cardinal): Boolean; +begin + if FCurrentPosition + Len <= FDataLength then begin + Move(FData^[FCurrentPosition], Data, Len); + FCurrentPosition := FCurrentPosition + Len; + Result := True; + end + else + Result := False; +end; + +procedure TPSExec.CMD_Err(EC: TPSError); // Error +begin + CMD_Err3(ec, '', nil); +end; + +procedure VNSetPointerTo(const Src: TPSVariantIFC; Data: Pointer; aType: TPSTypeRec); +begin + if Src.aType.BaseType = btPointer then + begin + if atype.BaseType in NeedFinalization then + FinalizeVariant(src.Dta, Src.aType); + Pointer(Src.Dta^) := Data; + Pointer(Pointer(IPointer(Src.Dta)+PointerSize)^) := aType; + Pointer(Pointer(IPointer(Src.Dta)+(2*PointerSize))^) := nil; + end; +end; + +function VNGetUInt(const Src: TPSVariantIFC): Cardinal; +begin + Result := PSGetUInt(Src.Dta, Src.aType); +end; + +{$IFNDEF PS_NOINT64} +function VNGetInt64(const Src: TPSVariantIFC): Int64; +begin + Result := PSGetInt64(Src.Dta, Src.aType); +end; +{$ENDIF} + +function VNGetReal(const Src: TPSVariantIFC): Extended; +begin + Result := PSGetReal(Src.Dta, Src.aType); +end; + +function VNGetCurrency(const Src: TPSVariantIFC): Currency; +begin + Result := PSGetCurrency(Src.Dta, Src.aType); +end; + +function VNGetInt(const Src: TPSVariantIFC): Longint; +begin + Result := PSGetInt(Src.Dta, Src.aType); +end; + +function VNGetAnsiString(const Src: TPSVariantIFC): tbtString; +begin + Result := PSGetAnsiString(Src.Dta, Src.aType); +end; + +{$IFNDEF PS_NOWIDESTRING} +function VNGetWideString(const Src: TPSVariantIFC): tbtWideString; +begin + Result := PSGetWideString(Src.Dta, Src.aType); +end; + +function VNGetUnicodeString(const Src: TPSVariantIFC): tbtunicodestring; +begin + Result := PSGetUnicodeString(Src.Dta, Src.aType); +end; +{$ENDIF} + +procedure VNSetUInt(const Src: TPSVariantIFC; const Val: Cardinal); +var + Dummy: Boolean; +begin + PSSetUInt(Src.Dta, Src.aType, Dummy, Val); +end; + +{$IFNDEF PS_NOINT64} +procedure VNSetInt64(const Src: TPSVariantIFC; const Val: Int64); +var + Dummy: Boolean; +begin + PSSetInt64(Src.Dta, Src.aType, Dummy, Val); +end; +{$ENDIF} + +procedure VNSetReal(const Src: TPSVariantIFC; const Val: Extended); +var + Dummy: Boolean; +begin + PSSetReal(Src.Dta, Src.aType, Dummy, Val); +end; + +procedure VNSetCurrency(const Src: TPSVariantIFC; const Val: Currency); +var + Dummy: Boolean; +begin + PSSetCurrency(Src.Dta, Src.aType, Dummy, Val); +end; + +procedure VNSetInt(const Src: TPSVariantIFC; const Val: Longint); +var + Dummy: Boolean; +begin + PSSetInt(Src.Dta, Src.aType, Dummy, Val); +end; + +procedure VNSetAnsiString(const Src: TPSVariantIFC; const Val: tbtString); +var + Dummy: Boolean; +begin + PSSetAnsiString(Src.Dta, Src.aType, Dummy, Val); +end; + +function VNGetString(const Src: TPSVariantIFC): String; +begin + {$IFDEF DELPHI2009UP} + Result := VNGetUnicodeString(Src); + {$ELSE} + Result := VNGetAnsiString(Src); + {$ENDIF} +end; + +procedure VNSetString(const Src: TPSVariantIFC; const Val: String); +begin + {$IFDEF DELPHI2009UP} + VNSetUnicodeString(Src, Val); + {$ELSE} + VNSetAnsiString(Src, Val); + {$ENDIF} +end; + +{$IFNDEF PS_NOWIDESTRING} +procedure VNSetWideString(const Src: TPSVariantIFC; const Val: tbtWideString); +var + Dummy: Boolean; +begin + PSSetWideString(Src.Dta, Src.aType, Dummy, Val); +end; + +procedure VNSetUnicodeString(const Src: TPSVariantIFC; const Val: tbtunicodestring); +var + Dummy: Boolean; +begin + PSSetUnicodeString(Src.Dta, Src.aType, Dummy, Val); +end; + +{$ENDIF} + +function VGetUInt(const Src: PIFVariant): Cardinal; +begin + Result := PSGetUInt(@PPSVariantData(src).Data, src.FType); +end; + +{$IFNDEF PS_NOINT64} +function VGetInt64(const Src: PIFVariant): Int64; +begin + Result := PSGetInt64(@PPSVariantData(src).Data, src.FType); +end; +{$ENDIF} + +function VGetReal(const Src: PIFVariant): Extended; +begin + Result := PSGetReal(@PPSVariantData(src).Data, src.FType); +end; + +function VGetCurrency(const Src: PIFVariant): Currency; +begin + Result := PSGetCurrency(@PPSVariantData(src).Data, src.FType); +end; + +function VGetInt(const Src: PIFVariant): Longint; +begin + Result := PSGetInt(@PPSVariantData(src).Data, src.FType); +end; + +function VGetAnsiString(const Src: PIFVariant): tbtString; +begin + Result := PSGetAnsiString(@PPSVariantData(src).Data, src.FType); +end; + +{$IFNDEF PS_NOWIDESTRING} +function VGetWideString(const Src: PIFVariant): tbtWideString; +begin + Result := PSGetWideString(@PPSVariantData(src).Data, src.FType); +end; + +function VGetUnicodeString(const Src: PIFVariant): tbtunicodestring; +begin + Result := PSGetUnicodeString(@PPSVariantData(src).Data, src.FType); +end; + +{$ENDIF} + + +procedure VSetPointerTo(const Src: PIFVariant; Data: Pointer; aType: TPSTypeRec); +var + temp: TPSVariantIFC; +begin + if (Atype = nil) or (Data = nil) or (Src = nil) then raise Exception.Create(RPS_InvalidVariable); + temp.Dta := @PPSVariantData(Src).Data; + temp.aType := Src.FType; + temp.VarParam := false; + VNSetPointerTo(temp, Data, AType); +end; + +procedure VSetUInt(const Src: PIFVariant; const Val: Cardinal); +var + Dummy: Boolean; +begin + PSSetUInt(@PPSVariantData(src).Data, src.FType, Dummy, Val); +end; + +{$IFNDEF PS_NOINT64} +procedure VSetInt64(const Src: PIFVariant; const Val: Int64); +var + Dummy: Boolean; +begin + PSSetInt64(@PPSVariantData(src).Data, src.FType, Dummy, Val); +end; +{$ENDIF} + +procedure VSetReal(const Src: PIFVariant; const Val: Extended); +var + Dummy: Boolean; +begin + PSSetReal(@PPSVariantData(src).Data, src.FType, Dummy, Val); +end; + +procedure VSetCurrency(const Src: PIFVariant; const Val: Currency); +var + Dummy: Boolean; +begin + PSSetCurrency(@PPSVariantData(src).Data, src.FType, Dummy, Val); +end; + +procedure VSetInt(const Src: PIFVariant; const Val: Longint); +var + Dummy: Boolean; +begin + PSSetInt(@PPSVariantData(src).Data, src.FType, Dummy, Val); +end; + +procedure VSetAnsiString(const Src: PIFVariant; const Val: tbtString); +var + Dummy: Boolean; +begin + PSSetAnsiString(@PPSVariantData(src).Data, src.FType, Dummy, Val); +end; + +function VGetString(const Src: PIFVariant): String; +begin + {$IFDEF DELPHI2009UP} + Result := PSGetUnicodeString(@PPSVariantData(src).Data, src.FType); + {$ELSE} + Result := PSGetAnsiString(@PPSVariantData(src).Data, src.FType); + {$ENDIF} +end; + +procedure VSetString(const Src: PIFVariant; const Val: string); +var + Dummy: Boolean; +begin + {$IFDEF DELPHI2009UP} + PSSetUnicodeString(@PPSVariantData(src).Data, src.FType, Dummy, Val); + {$ELSE} + PSSetAnsiString(@PPSVariantData(src).Data, src.FType, Dummy, Val); + {$ENDIF} +end; + + +{$IFNDEF PS_NOWIDESTRING} +procedure VSetWideString(const Src: PIFVariant; const Val: tbtWideString); +var + Dummy: Boolean; +begin + PSSetWideString(@PPSVariantData(src).Data, src.FType, Dummy, Val); +end; + +procedure VSetUnicodeString(const Src: PIFVariant; const Val: tbtunicodestring); +var + Dummy: Boolean; +begin + PSSetUnicodeString(@PPSVariantData(src).Data, src.FType, Dummy, Val); +end; + + +{$ENDIF} + +{$IFNDEF PS_NOWIDESTRING} +function VarToWideStr(const Data: Variant): tbtunicodestring; +begin + if not VarIsNull(Data) then + Result := Data + else + Result := ''; +end; +{$ENDIF} + +function PSGetUInt(Src: Pointer; aType: TPSTypeRec): Cardinal; +begin + if aType.BaseType = btPointer then + begin + atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^); + Src := Pointer(Src^); + if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case aType.BaseType of + btU8: Result := tbtu8(src^); + btS8: Result := tbts8(src^); + btU16: Result := tbtu16(src^); + btS16: Result := tbts16(src^); + btU32: Result := tbtu32(src^); + btS32: Result := tbts32(src^); +{$IFNDEF PS_NOINT64} btS64: Result := tbts64(src^); +{$ENDIF} + btChar: Result := Ord(tbtchar(Src^)); +{$IFNDEF PS_NOWIDESTRING} btWideChar: Result := Ord(tbtwidechar(Src^));{$ENDIF} + btVariant: + case VarType(Variant(Src^)) of + varString: + if Length(VarToStr(Variant(Src^))) = 1 then + Result := Ord(VarToStr(Variant(Src^))[1]) + else + raise Exception.Create(RPS_TypeMismatch); +{$IFNDEF PS_NOWIDESTRING} + varOleStr: + if Length(VarToWideStr(Variant(Src^))) = 1 then + Result := Ord(VarToWideStr(Variant(Src^))[1]) + else + raise Exception.Create(RPS_TypeMismatch); +{$ENDIF} + else + Result := Variant(src^); + end; + else raise Exception.Create(RPS_TypeMismatch); + end; +end; + +function PSGetObject(Src: Pointer; aType: TPSTypeRec): TObject; +begin + if aType.BaseType = btPointer then + begin + atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^); + Src := Pointer(Src^); + if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case aType.BaseType of + btClass: Result := TObject(Src^); + else raise Exception.Create(RPS_TypeMismatch); + end; +end; + +procedure PSSetObject(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; Const val: TObject); +begin + if aType.BaseType = btPointer then + begin + atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^); + Src := Pointer(Src^); + if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case aType.BaseType of + btClass: TObject(Src^) := Val; + else raise Exception.Create(RPS_TypeMismatch); + end; +end; + + +{$IFNDEF PS_NOINT64} +function PSGetInt64(Src: Pointer; aType: TPSTypeRec): Int64; +begin + if aType.BaseType = btPointer then + begin + atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^); + Src := Pointer(Src^); + if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case aType.BaseType of + btU8: Result := tbtu8(src^); + btS8: Result := tbts8(src^); + btU16: Result := tbtu16(src^); + btS16: Result := tbts16(src^); + btU32: Result := tbtu32(src^); + btS32: Result := tbts32(src^); + btS64: Result := tbts64(src^); + btChar: Result := Ord(tbtchar(Src^)); +{$IFNDEF PS_NOWIDESTRING} + btWideChar: Result := Ord(tbtwidechar(Src^)); +{$ENDIF} +{$IFDEF DELPHI6UP} + btVariant: Result := Variant(src^); +{$ENDIF} + else raise Exception.Create(RPS_TypeMismatch); + end; +end; +{$ENDIF} + +function PSGetReal(Src: Pointer; aType: TPSTypeRec): Extended; +begin + if aType.BaseType = btPointer then + begin + atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^); + Src := Pointer(Src^); + if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case aType.BaseType of + btU8: Result := tbtu8(src^); + btS8: Result := tbts8(src^); + btU16: Result := tbtu16(src^); + btS16: Result := tbts16(src^); + btU32: Result := tbtu32(src^); + btS32: Result := tbts32(src^); +{$IFNDEF PS_NOINT64} btS64: Result := tbts64(src^);{$ENDIF} + btSingle: Result := tbtsingle(Src^); + btDouble: Result := tbtdouble(Src^); + btExtended: Result := tbtextended(Src^); + btCurrency: Result := tbtcurrency(Src^); + btVariant: Result := Variant(src^); + else raise Exception.Create(RPS_TypeMismatch); + end; +end; + +function PSGetCurrency(Src: Pointer; aType: TPSTypeRec): Currency; +begin + if aType.BaseType = btPointer then + begin + atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^); + Src := Pointer(Src^); + if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case aType.BaseType of + btU8: Result := tbtu8(src^); + btS8: Result := tbts8(src^); + btU16: Result := tbtu16(src^); + btS16: Result := tbts16(src^); + btU32: Result := tbtu32(src^); + btS32: Result := tbts32(src^); +{$IFNDEF PS_NOINT64} btS64: Result := tbts64(src^);{$ENDIF} + btSingle: Result := tbtsingle(Src^); + btDouble: Result := tbtdouble(Src^); + btExtended: Result := tbtextended(Src^); + btCurrency: Result := tbtcurrency(Src^); + btVariant: Result := Variant(src^); + else raise Exception.Create(RPS_TypeMismatch); + end; +end; + + +function PSGetInt(Src: Pointer; aType: TPSTypeRec): Longint; +begin + if aType.BaseType = btPointer then + begin + atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^); + Src := Pointer(Src^); + if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case aType.BaseType of + btU8: Result := tbtu8(src^); + btS8: Result := tbts8(src^); + btU16: Result := tbtu16(src^); + btS16: Result := tbts16(src^); + btU32: Result := tbtu32(src^); + btS32: Result := tbts32(src^); +{$IFNDEF PS_NOINT64} btS64: Result := tbts64(src^);{$ENDIF} + btChar: Result := Ord(tbtchar(Src^)); +{$IFNDEF PS_NOWIDESTRING} btWideChar: Result := Ord(tbtwidechar(Src^));{$ENDIF} + btVariant: Result := Variant(src^); + else raise Exception.Create(RPS_TypeMismatch); + end; +end; + + +function PSGetAnsiString(Src: Pointer; aType: TPSTypeRec): tbtString; +begin + if aType.BaseType = btPointer then + begin + atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^); + Src := Pointer(Src^); + if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case aType.BaseType of + btU8: Result := tbtchar(tbtu8(src^)); + btChar: Result := tbtchar(Src^); + btPchar: Result := pansichar(src^); +{$IFNDEF PS_NOWIDESTRING} btWideChar: Result := tbtString(tbtwidechar(Src^));{$ENDIF} + btString: Result := tbtstring(src^); +{$IFNDEF PS_NOWIDESTRING} + btUnicodeString: result := tbtString(tbtUnicodestring(src^)); + btWideString: Result := tbtString(tbtwidestring(src^));{$ENDIF} + btVariant: Result := tbtString(Variant(src^)); + else raise Exception.Create(RPS_TypeMismatch); + end; +end; +{$IFNDEF PS_NOWIDESTRING} +function PSGetWideString(Src: Pointer; aType: TPSTypeRec): tbtWideString; +begin + if aType.BaseType = btPointer then + begin + atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^); + Src := Pointer(Src^); + if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case aType.BaseType of + btU8: Result := chr(tbtu8(src^)); + btU16: Result := widechar(src^); + btChar: Result := tbtwidestring(tbtchar(Src^)); + btPchar: Result := tbtwidestring(pansichar(src^)); + btWideChar: Result := tbtwidechar(Src^); + btString: Result := tbtwidestring(tbtstring(src^)); + btWideString: Result := tbtwidestring(src^); + btVariant: Result := Variant(src^); + btUnicodeString: result := tbtUnicodeString(src^); + else raise Exception.Create(RPS_TypeMismatch); + end; +end; + +function PSGetUnicodeString(Src: Pointer; aType: TPSTypeRec): tbtunicodestring; +begin + if aType.BaseType = btPointer then + begin + atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^); + Src := Pointer(Src^); + if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case aType.BaseType of + btU8: Result := chr(tbtu8(src^)); + btU16: Result := widechar(src^); + btChar: Result := tbtwidestring(tbtchar(Src^)); + btPchar: Result := tbtwidestring(pansichar(src^)); + btWideChar: Result := tbtwidechar(Src^); + btString: Result := tbtwidestring(tbtstring(src^)); + btWideString: Result := tbtwidestring(src^); + btVariant: Result := Variant(src^); + btUnicodeString: result := tbtUnicodeString(src^); + else raise Exception.Create(RPS_TypeMismatch); + end; +end; +{$ENDIF} + +procedure PSSetUInt(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Cardinal); +begin + if (Src = nil) or (aType = nil) then begin Ok := false; exit; end; + if aType.BaseType = btPointer then + begin + atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^); + Src := Pointer(Src^); + if (src = nil) or (aType = nil) then begin Ok := false; exit; end; + end; + case aType.BaseType of + btU8: tbtu8(src^) := Val; + btS8: tbts8(src^) := Val; + btU16: tbtu16(src^) := Val; + btS16: tbts16(src^) := Val; + btProcPtr: + begin + tbtu32(src^) := Val; + Pointer(Pointer(IPointer(Src)+PointerSize)^) := nil; + Pointer(Pointer(IPointer(Src)+PointerSize2)^) := nil; + end; + btU32: tbtu32(src^) := Val; + btS32: tbts32(src^) := Val; +{$IFNDEF PS_NOINT64} btS64: tbts64(src^) := Val;{$ENDIF} + btChar: tbtchar(Src^) := tbtChar(Val); +{$IFNDEF PS_NOWIDESTRING} btWideChar: tbtwidechar(Src^) := tbtwidechar(Val);{$ENDIF} + btSingle: tbtSingle(src^) := Val; + btDouble: tbtDouble(src^) := Val; + btCurrency: tbtCurrency(src^) := Val; + btExtended: tbtExtended(src^) := Val; + btVariant: + begin + try + Variant(src^) := {$IFDEF DELPHI6UP}val{$ELSE}tbts32(val){$ENDIF}; + except + Ok := false; + end; + end; + else ok := false; + end; +end; + +{$IFNDEF PS_NOINT64} +procedure PSSetInt64(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Int64); +begin + if (Src = nil) or (aType = nil) then begin Ok := false; exit; end; + if aType.BaseType = btPointer then + begin + atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^); + Src := Pointer(Src^); + if (src = nil) or (aType = nil) then begin Ok := false; exit; end; + end; + case aType.BaseType of + btU8: tbtu8(src^) := Val; + btS8: tbts8(src^) := Val; + btU16: tbtu16(src^) := Val; + btS16: tbts16(src^) := Val; + btU32: tbtu32(src^) := Val; + btS32: tbts32(src^) := Val; + btS64: tbts64(src^) := Val; + btChar: tbtchar(Src^) := tbtChar(Val); +{$IFNDEF PS_NOWIDESTRING} + btWideChar: tbtwidechar(Src^) := tbtwidechar(Val); +{$ENDIF} + btSingle: tbtSingle(src^) := Val; + btDouble: tbtDouble(src^) := Val; + btCurrency: tbtCurrency(src^) := Val; + btExtended: tbtExtended(src^) := Val; +{$IFDEF DELPHI6UP} + btVariant: + begin + try + Variant(src^) := Val; + except + Ok := false; + end; + end; +{$ENDIF} + else ok := false; + end; +end; +{$ENDIF} + +procedure PSSetReal(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Extended); +begin + if (Src = nil) or (aType = nil) then begin Ok := false; exit; end; + if aType.BaseType = btPointer then + begin + atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^); + Src := Pointer(Src^); + if (src = nil) or (aType = nil) then begin Ok := false; exit; end; + end; + case aType.BaseType of + btSingle: tbtSingle(src^) := Val; + btDouble: tbtDouble(src^) := Val; + btCurrency: tbtCurrency(src^) := Val; + btExtended: tbtExtended(src^) := Val; + btVariant: + begin + try + Variant(src^) := Val; + except + Ok := false; + end; + end; + else ok := false; + end; +end; + +procedure PSSetCurrency(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Currency); +begin + if (Src = nil) or (aType = nil) then begin Ok := false; exit; end; + if aType.BaseType = btPointer then + begin + atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^); + Src := Pointer(Src^); + if (src = nil) or (aType = nil) then begin Ok := false; exit; end; + end; + case aType.BaseType of + btSingle: tbtSingle(src^) := Val; + btDouble: tbtDouble(src^) := Val; + btCurrency: tbtCurrency(src^) := Val; + btExtended: tbtExtended(src^) := Val; + btVariant: + begin + try + Variant(src^) := Val; + except + Ok := false; + end; + end; + else ok := false; + end; +end; + +procedure PSSetInt(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Longint); +begin + if (Src = nil) or (aType = nil) then begin Ok := false; exit; end; + if aType.BaseType = btPointer then + begin + atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^); + Src := Pointer(Src^); + if (src = nil) or (aType = nil) then begin Ok := false; exit; end; + end; + case aType.BaseType of + btU8: tbtu8(src^) := Val; + btS8: tbts8(src^) := Val; + btU16: tbtu16(src^) := Val; + btS16: tbts16(src^) := Val; + btProcPtr: + begin + tbtu32(src^) := Val; + Pointer(Pointer(IPointer(Src)+PointerSize)^) := nil; + Pointer(Pointer(IPointer(Src)+PointerSize2)^) := nil; + end; + btU32: tbtu32(src^) := Val; + btS32: tbts32(src^) := Val; +{$IFNDEF PS_NOINT64} btS64: tbts64(src^) := Val;{$ENDIF} + btChar: tbtchar(Src^) := tbtChar(Val); +{$IFNDEF PS_NOWIDESTRING} btWideChar: tbtwidechar(Src^) := tbtwidechar(Val);{$ENDIF} + btSingle: tbtSingle(src^) := Val; + btDouble: tbtDouble(src^) := Val; + btCurrency: tbtCurrency(src^) := Val; + btExtended: tbtExtended(src^) := Val; + btVariant: + begin + try + Variant(src^) := Val; + except + Ok := false; + end; + end; + else ok := false; + end; +end; + +procedure PSSetAnsiString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: tbtString); +begin + if (Src = nil) or (aType = nil) then begin Ok := false; exit; end; + if aType.BaseType = btPointer then + begin + atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^); + Src := Pointer(Src^); + if (src = nil) or (aType = nil) then begin Ok := false; exit; end; + end; + case aType.BaseType of + btString: tbtstring(src^) := val; +{$IFNDEF PS_NOWIDESTRING} + btUnicodeString: tbtunicodestring(src^) := tbtUnicodeString(AnsiString(val)); + btWideString: tbtwidestring(src^) := tbtwidestring(AnsiString(val));{$ENDIF} + btVariant: + begin + try + Variant(src^) := Val; + except + Ok := false; + end; + end; + else ok := false; + end; +end; +{$IFNDEF PS_NOWIDESTRING} +procedure PSSetWideString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: tbtWideString); +begin + if (Src = nil) or (aType = nil) then begin Ok := false; exit; end; + if aType.BaseType = btPointer then + begin + atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^); + Src := Pointer(Src^); + if (src = nil) or (aType = nil) then begin Ok := false; exit; end; + end; + case aType.BaseType of + btString: tbtstring(src^) := tbtString(val); + btWideString: tbtwidestring(src^) := val; + btUnicodeString: tbtunicodestring(src^) := val; + btVariant: + begin + try + Variant(src^) := Val; + except + Ok := false; + end; + end; + else ok := false; + end; +end; +procedure PSSetUnicodeString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: tbtunicodestring); +begin + if (Src = nil) or (aType = nil) then begin Ok := false; exit; end; + if aType.BaseType = btPointer then + begin + atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^); + Src := Pointer(Src^); + if (src = nil) or (aType = nil) then begin Ok := false; exit; end; + end; + case aType.BaseType of + btString: tbtstring(src^) := tbtString(val); + btWideString: tbtwidestring(src^) := val; + btUnicodeString: tbtunicodestring(src^) := val; + btVariant: + begin + try + Variant(src^) := Val; + except + Ok := false; + end; + end; + else ok := false; + end; +end; +{$ENDIF} + +function PSGetString(Src: Pointer; aType: TPSTypeRec): string; +begin + {$IFDEF DELPHI2009UP} + result := PSGetUnicodeString(Src, aType); + {$ELSE} + result := PSGetAnsiString(Src, aType); + {$ENDIF} +end; + +procedure PSSetString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: String); +begin + {$IFDEF DELPHI2009UP} + PSSetUnicodeString(Src, aType, Ok, Val); + {$ELSE} + PSSetAnsiString(Src, aType, Ok, Val); + {$ENDIF} +end; + + +function CopyArrayContents(dest, src: Pointer; Len: Longint; aType: TPSTypeRec): Boolean; forward; + +function CopyRecordContents(dest, src: Pointer; aType: TPSTypeRec_Record): Boolean; +var + o, i: Longint; +begin + for i := 0 to aType.FieldTypes.Count -1 do + begin + o := Longint(atype.RealFieldOffsets[i]); + CopyArrayContents(Pointer(IPointer(Dest)+Cardinal(o)), Pointer(IPointer(Src)+Cardinal(o)), 1, aType.FieldTypes[i]); + end; + Result := true; +end; + +function CreateArrayFromVariant(Exec: TPSExec; dest: Pointer; src: Variant; DestType: TPSTypeRec): Boolean; +var + i: Integer; + r: Pointer; + lVarType: TPSTypeRec; + v: variant; +begin + lVarType := Exec.FindType2(btVariant); + if lVarType = nil then begin result := false; exit; end; + PSDynArraySetLength(Pointer(dest^), desttype, VarArrayHighBound(src, 1) - VarArrayLowBound(src, 1) + 1); + r := Pointer(Dest^); + DestType := TPSTypeRec_Array(DestType).ArrayType; + for i := 0 to VarArrayHighBound(src, 1) - VarArrayLowBound(src, 1) do begin + v := src[i + VarArrayLowBound(src, 1)]; + if not Exec.SetVariantValue(r, @v, desttype, lVarType) then begin result := false; exit; end; + r := Pointer(IPointer(r) + Longint(DestType.RealSize)); + end; + Result := true; +end; + +function CopyArrayContents(dest, src: Pointer; Len: Longint; aType: TPSTypeRec): Boolean; +var + elsize: Cardinal; + i: Longint; +begin + try + case aType.BaseType of + btU8, btS8, btChar: + for i := 0 to Len -1 do + begin + tbtU8(Dest^) := tbtU8(Src^); + Dest := Pointer(IPointer(Dest) + 1); + Src := Pointer(IPointer(Src) + 1); + end; + btU16, btS16{$IFNDEF PS_NOWIDESTRING}, btWideChar{$ENDIF}: + for i := 0 to Len -1 do + begin + tbtU16(Dest^) := tbtU16(Src^); + Dest := Pointer(IPointer(Dest) + 2); + Src := Pointer(IPointer(Src) + 2); + end; + btProcPtr: + for i := 0 to Len -1 do + begin + tbtU32(Dest^) := tbtU32(Src^); + Dest := Pointer(IPointer(Dest) + 4); + Src := Pointer(IPointer(Src) + 4); + Pointer(Dest^) := Pointer(Src^); + Dest := Pointer(IPointer(Dest) + PointerSize); + Src := Pointer(IPointer(Src) + PointerSize); + Pointer(Dest^) := Pointer(Src^); + Dest := Pointer(IPointer(Dest) + PointerSize); + Src := Pointer(IPointer(Src) + PointerSize); + end; + btClass, btpchar: + for i := 0 to Len -1 do + begin + Pointer(Dest^) := Pointer(Src^); + Dest := Pointer(IPointer(Dest) + PointerSize); + Src := Pointer(IPointer(Src) + PointerSize); + end; + btU32, btS32, btSingle: + for i := 0 to Len -1 do + begin + tbtU32(Dest^) := tbtU32(Src^); + Dest := Pointer(IPointer(Dest) + 4); + Src := Pointer(IPointer(Src) + 4); + end; + btDouble: + for i := 0 to Len -1 do + begin + tbtDouble(Dest^) := tbtDouble(Src^); + Dest := Pointer(IPointer(Dest) + 8); + Src := Pointer(IPointer(Src) + 8); + end; + {$IFNDEF PS_NOINT64}bts64: + for i := 0 to Len -1 do + begin + tbts64(Dest^) := tbts64(Src^); + Dest := Pointer(IPointer(Dest) + 8); + Src := Pointer(IPointer(Src) + 8); + end;{$ENDIF} + btExtended: + for i := 0 to Len -1 do + begin + tbtExtended(Dest^) := tbtExtended(Src^); + Dest := Pointer(IPointer(Dest) + SizeOf(Extended)); + Src := Pointer(IPointer(Src) + SizeOf(Extended)); + end; + btCurrency: + for i := 0 to Len -1 do + begin + tbtCurrency(Dest^) := tbtCurrency(Src^); + Dest := Pointer(IPointer(Dest) + SizeOf(Currency)); + Src := Pointer(IPointer(Src) + SizeOf(Currency)); + end; + btVariant: + for i := 0 to Len -1 do + begin + variant(Dest^) := variant(Src^); + Dest := Pointer(IPointer(Dest) + Sizeof(Variant)); + Src := Pointer(IPointer(Src) + Sizeof(Variant)); + end; + btString: + for i := 0 to Len -1 do + begin + tbtString(Dest^) := tbtString(Src^); + Dest := Pointer(IPointer(Dest) + PointerSize); + Src := Pointer(IPointer(Src) + PointerSize); + end; + {$IFNDEF PS_NOWIDESTRING} + btUnicodeString: + for i := 0 to Len -1 do + begin + tbtunicodestring(Dest^) := tbtunicodestring(Src^); + Dest := Pointer(IPointer(Dest) + PointerSize); + Src := Pointer(IPointer(Src) + PointerSize); + end; + btWideString: + for i := 0 to Len -1 do + begin + tbtWideString(Dest^) := tbtWideString(Src^); + Dest := Pointer(IPointer(Dest) + PointerSize); + Src := Pointer(IPointer(Src) + PointerSize); + end; + {$ENDIF} + btStaticArray: + begin + elSize := aType.RealSize; + for i := 0 to Len -1 do + begin + if not CopyArrayContents(Dest, Src, TPSTypeRec_StaticArray(aType).Size, TPSTypeRec_StaticArray(aType).ArrayType) then + begin + result := false; + exit; + end; + Dest := Pointer(IPointer(Dest) + elsize); + Src := Pointer(IPointer(Src) + elsize); + end; + end; + btArray: + begin + for i := 0 to Len -1 do + begin + Pointer(Dest^) := Pointer(Src^); + if Pointer(Dest^) <> nil then + begin + Inc(Longint(Pointer(IPointer(Dest^)-(2*PointerSize))^)); // RefCount + end; + Dest := Pointer(IPointer(Dest) + PointerSize); + Src := Pointer(IPointer(Src) + PointerSize); + end; + end; + btRecord: + begin + elSize := aType.RealSize; + for i := 0 to Len -1 do + begin + if not CopyRecordContents(Dest, Src, TPSTypeRec_Record(aType)) then + begin + result := false; + exit; + end; + Dest := Pointer(IPointer(Dest) + elsize); + Src := Pointer(IPointer(Src) + elsize); + end; + end; + btSet: + begin + elSize := aType.RealSize; + for i := 0 to Len -1 do + begin + Move(Src^, Dest^, elSize); + Dest := Pointer(IPointer(Dest) + elsize); + Src := Pointer(IPointer(Src) + elsize); + end; + end; +{$IFNDEF PS_NOINTERFACES} + btInterface: + begin + for i := 0 to Len -1 do + begin + {$IFNDEF DELPHI3UP} + if IUnknown(Dest^) <> nil then + begin + IUnknown(Dest^).Release; + IUnknown(Dest^) := nil; + end; + {$ENDIF} + IUnknown(Dest^) := IUnknown(Src^); + {$IFNDEF DELPHI3UP} + if IUnknown(Dest^) <> nil then + IUnknown(Dest^).AddRef; + {$ENDIF} + Dest := Pointer(IPointer(Dest) + PointerSize); + Src := Pointer(IPointer(Src) + PointerSize); + end; + end; +{$ENDIF} + btPointer: + begin + if (Pointer(Pointer(IPointer(Dest)+PointerSize2)^) = nil) and (Pointer(Pointer(IPointer(Src)+PointerSize2)^) = nil) then + begin + for i := 0 to Len -1 do + begin + Pointer(Dest^) := Pointer(Src^); + Dest := Pointer(IPointer(Dest) + PointerSize); + Src := Pointer(IPointer(Src) + PointerSize); + Pointer(Dest^) := Pointer(Src^); + Dest := Pointer(IPointer(Dest) + PointerSize); + Src := Pointer(IPointer(Src) + PointerSize); + LongBool(Dest^) := false; + Dest := Pointer(IPointer(Dest) + sizeof(LongBool)); + Src := Pointer(IPointer(Src) + sizeof(LongBool)); + end; + end else begin + for i := 0 to Len -1 do + begin + if Pointer(Pointer(IPointer(Dest)+PointerSize2)^) <> nil then + DestroyHeapVariant2(Pointer(Dest^), Pointer(Pointer(IPointer(Dest)+PointerSize)^)); + if Pointer(Src^) <> nil then + begin + if not LongBool(Pointer(IPointer(Src) + PointerSize2)^) then + begin + Pointer(Dest^) := Pointer(Src^); + Pointer(Pointer(IPointer(Dest) + PointerSize)^) := Pointer(Pointer(IPointer(Src) + PointerSize)^); + Pointer(Pointer(IPointer(Dest) + PointerSize2)^) := Pointer(Pointer(IPointer(Src) + PointerSize2)^); + end else + begin + Pointer(Dest^) := CreateHeapVariant2(Pointer(Pointer(IPointer(Src) + PointerSize)^)); + Pointer(Pointer(IPointer(Dest) + PointerSize)^) := Pointer(Pointer(IPointer(Src) + PointerSize)^); + LongBool(Pointer(IPointer(Dest) + PointerSize2)^) := true; + if not CopyArrayContents(Pointer(Dest^), Pointer(Src^), 1, Pointer(Pointer(IPointer(Dest) + PointerSize)^)) then + begin + Result := false; + exit; + end; + end; + end else + begin + Pointer(Dest^) := nil; + Pointer(Pointer(IPointer(Dest) + PointerSize)^) := nil; + Pointer(Pointer(IPointer(Dest) + PointerSize2)^) := nil; + end; + Dest := Pointer(IPointer(Dest) + PointerSize*2+sizeof(LongBool)); + Src := Pointer(IPointer(Src) + PointerSize*2+sizeof(LongBool)); + end; + end; + end; +// btResourcePointer = 15; +// btVariant = 16; + else + Result := False; + exit; + end; + except + Result := False; + exit; + end; + Result := true; +end; + +function GetPSArrayLength(Arr: PIFVariant): Longint; +begin + result := PSDynArrayGetLength(PPSVariantDynamicArray(arr).Data, arr.FType); +end; + +procedure SetPSArrayLength(Arr: PIFVariant; NewLength: Longint); +begin + PSDynArraySetLength(PPSVariantDynamicArray(arr).Data, arr.FType, NewLength); +end; + + +function PSDynArrayGetLength(arr: Pointer; aType: TPSTypeRec): Longint; +begin + if aType.BaseType <> btArray then raise Exception.Create(RPS_InvalidArray); + if arr = nil then Result := 0 else Result := Longint(Pointer(IPointer(arr)-PointerSize)^) + 1; +end; + +procedure PSDynArraySetLength(var arr: Pointer; aType: TPSTypeRec; NewLength: Longint); +var + elSize, i, OldLen: Longint; + p: Pointer; +begin + if aType.BaseType <> btArray then raise Exception.Create(RPS_InvalidArray); + OldLen := PSDynArrayGetLength(arr, aType); + elSize := TPSTypeRec_Array(aType).ArrayType.RealSize; + if (OldLen = 0) and (NewLength = 0) then exit; // already are both 0 + if (OldLen <> 0) and (Longint(Pointer(IPointer(Arr)-PointerSize2)^) = 1) then // unique copy of this dynamic array + begin + for i := NewLength to OldLen -1 do + begin + if TPSTypeRec_Array(aType).ArrayType.BaseType in NeedFinalization then + FinalizeVariant(Pointer(IPointer(arr) + Cardinal(elsize * i)), TPSTypeRec_Array(aType).ArrayType); + end; + arr := Pointer(IPointer(Arr)-PointerSize2); + if NewLength <= 0 then + begin + FreeMem(arr, NewLength * elsize + PointerSize2); + arr := nil; + exit; + end; + ReallocMem(arr, NewLength * elSize + PointerSize2); + arr := Pointer(IPointer(Arr)+PointerSize); + Longint(Arr^) := NewLength - 1; + arr := Pointer(IPointer(Arr)+PointerSize); + for i := OldLen to NewLength -1 do + begin + InitializeVariant(Pointer(IPointer(arr) + Cardinal(elsize * i)), TPSTypeRec_Array(aType).ArrayType); + end; + end else + begin + if NewLength = 0 then + begin + if Longint(Pointer(IPointer(Arr)-PointerSize2)^) = 1 then + FreeMem(Pointer(IPointer(Arr)-PointerSize2), OldLen * elSize + PointerSize2) + else if Longint(Pointer(IPointer(Arr)-PointerSize2)^) > 0 then + Dec(Longint(Pointer(IPointer(Arr)-PointerSize2)^)); + arr := nil; + exit; + end; + GetMem(p, NewLength * elSize + PointerSize2); + Longint(p^) := 1; + p:= Pointer(IPointer(p)+PointerSize); + Longint(p^) := NewLength - 1; + p := Pointer(IPointer(p)+PointerSize); + if OldLen <> 0 then + begin + if OldLen > NewLength then + CopyArrayContents(p, arr, NewLength, TPSTypeRec_Array(aType).ArrayType) + else + CopyArrayContents(p, arr, OldLen, TPSTypeRec_Array(aType).ArrayType); + FinalizeVariant(@arr, aType); + end; + arr := p; + for i := OldLen to NewLength -1 do + begin + InitializeVariant(Pointer(IPointer(arr) + Cardinal(elsize * i)), TPSTypeRec_Array(aType).ArrayType); + end; + end; +end; + + + +{$IFDEF FPC} +function OleErrorMessage(ErrorCode: HResult): tbtString; +begin + Result := SysErrorMessage(ErrorCode); + if Result = '' then + Result := Format(RPS_OLEError, [ErrorCode]); +end; + +procedure OleError(ErrorCode: HResult); +begin + raise Exception.Create(OleErrorMessage(ErrorCode)); +end; + +procedure OleCheck(Result: HResult); +begin + if Result < 0 then OleError(Result); +end; +{$ENDIF} + + +{$IFNDEF DELPHI3UP} +function OleErrorMessage(ErrorCode: HResult): tbtString; +begin + Result := SysErrorMessage(ErrorCode); + if Result = '' then + Result := Format(RPS_OLEError, [ErrorCode]); +end; + +procedure OleError(ErrorCode: HResult); +begin + raise Exception.Create(OleErrorMessage(ErrorCode)); +end; + +procedure OleCheck(Result: HResult); +begin + if Result < 0 then OleError(Result); +end; + +procedure AssignInterface(var Dest: IUnknown; const Src: IUnknown); +var + OldDest: IUnknown; +begin + { Like Delphi 3+'s _IntfCopy, reference source before releasing old dest. + so that self assignment (I := I) works right } + OldDest := Dest; + Dest := Src; + if Src <> nil then + Src.AddRef; + if OldDest <> nil then + OldDest.Release; +end; + +procedure AssignVariantFromIDispatch(var Dest: Variant; const Src: IDispatch); +begin + VarClear(Dest); + TVarData(Dest).VDispatch := Src; + TVarData(Dest).VType := varDispatch; + if Src <> nil then + Src.AddRef; +end; + +procedure AssignIDispatchFromVariant(var Dest: IDispatch; const Src: Variant); +const + RPS_InvalidVariantRef = 'Invalid variant ref'; +var + NewDest: IDispatch; +begin + case TVarData(Src).VType of + varEmpty: NewDest := nil; + varDispatch: NewDest := TVarData(Src).VDispatch; + varDispatch or varByRef: NewDest := Pointer(TVarData(Src).VPointer^); + else + raise Exception.Create(RPS_InvalidVariantRef); + end; + AssignInterface(IUnknown(Dest), NewDest); +end; +{$ENDIF} + +function TPSExec.SetVariantValue(dest, Src: Pointer; desttype, srctype: TPSTypeRec): Boolean; +var + Tmp: TObject; + tt: TPSVariantPointer; +begin + Result := True; + try + case desttype.BaseType of + btSet: + begin + if desttype = srctype then + Move(Src^, Dest^, TPSTypeRec_Set(desttype).aByteSize) + else + Result := False; + end; + btU8: tbtu8(Dest^) := PSGetUInt(Src, srctype); + btS8: tbts8(Dest^) := PSGetInt(Src, srctype); + btU16: tbtu16(Dest^) := PSGetUInt(Src, srctype); + btS16: tbts16(Dest^) := PSGetInt(Src, srctype); + btProcPtr: + begin + if srctype.BaseType = btPointer then + begin + srctype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^); + Src := Pointer(Src^); + if (src = nil) or (srctype = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case srctype.BaseType of + btu32: + begin + Pointer(Dest^) := Pointer(Src^); + end; + btProcPtr: + begin + Pointer(Dest^) := Pointer(Src^); + Pointer(Pointer(IPointer(Dest)+PointerSize)^) := Pointer(Pointer(IPointer(Src)+PointerSize)^); + Pointer(Pointer(IPointer(Dest)+PointerSize2)^) := Pointer(Pointer(IPointer(Src)+PointerSize2)^); + end; + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + btU32: + begin + if srctype.BaseType = btPointer then + begin + srctype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^); + Src := Pointer(Src^); + if (src = nil) or (srctype = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case srctype.BaseType of + btU8: tbtu32(Dest^) := tbtu8(src^); + btS8: tbtu32(Dest^) := tbts8(src^); + btU16: tbtu32(Dest^) := tbtu16(src^); + btS16: tbtu32(Dest^) := tbts16(src^); + btU32: tbtu32(Dest^) := tbtu32(src^); + btS32: tbtu32(Dest^) := tbts32(src^); + {$IFNDEF PS_NOINT64} btS64: tbtu32(Dest^) := tbts64(src^);{$ENDIF} + btChar: tbtu32(Dest^) := Ord(tbtchar(Src^)); + {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtu32(Dest^) := Ord(tbtwidechar(Src^));{$ENDIF} + btVariant: tbtu32(Dest^) := Variant(src^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + btS32: + begin + if srctype.BaseType = btPointer then + begin + srctype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^); + Src := Pointer(Src^); + if (src = nil) or (srctype = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case srctype.BaseType of + btU8: tbts32(Dest^) := tbtu8(src^); + btS8: tbts32(Dest^) := tbts8(src^); + btU16: tbts32(Dest^) := tbtu16(src^); + btS16: tbts32(Dest^) := tbts16(src^); + btU32: tbts32(Dest^) := tbtu32(src^); + btS32: tbts32(Dest^) := tbts32(src^); + {$IFNDEF PS_NOINT64} btS64: tbts32(Dest^) := tbts64(src^);{$ENDIF} + btChar: tbts32(Dest^) := Ord(tbtchar(Src^)); + {$IFNDEF PS_NOWIDESTRING} btWideChar: tbts32(Dest^) := Ord(tbtwidechar(Src^));{$ENDIF} + btVariant: tbts32(Dest^) := Variant(src^); + // nx change start - allow assignment of class + btClass: tbtu32(Dest^) := tbtu32(src^); + // nx change start + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + {$IFNDEF PS_NOINT64} + btS64: tbts64(Dest^) := PSGetInt64(Src, srctype); + {$ENDIF} + btSingle: + begin + if srctype.BaseType = btPointer then + begin + srctype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^); + Src := Pointer(Src^); + if (src = nil) or (srctype = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case srctype.BaseType of + btU8: tbtsingle(Dest^) := tbtu8(src^); + btS8: tbtsingle(Dest^) := tbts8(src^); + btU16: tbtsingle(Dest^) := tbtu16(src^); + btS16: tbtsingle(Dest^) := tbts16(src^); + btU32: tbtsingle(Dest^) := tbtu32(src^); + btS32: tbtsingle(Dest^) := tbts32(src^); + {$IFNDEF PS_NOINT64} btS64: tbtsingle(Dest^) := tbts64(src^);{$ENDIF} + btSingle: tbtsingle(Dest^) := tbtsingle(Src^); + btDouble: tbtsingle(Dest^) := tbtdouble(Src^); + btExtended: tbtsingle(Dest^) := tbtextended(Src^); + btCurrency: tbtsingle(Dest^) := tbtcurrency(Src^); + btVariant: tbtsingle(Dest^) := Variant(src^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + btDouble: + begin + if srctype.BaseType = btPointer then + begin + srctype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^); + Src := Pointer(Src^); + if (src = nil) or (srctype = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case srctype.BaseType of + btU8: tbtdouble(Dest^) := tbtu8(src^); + btS8: tbtdouble(Dest^) := tbts8(src^); + btU16: tbtdouble(Dest^) := tbtu16(src^); + btS16: tbtdouble(Dest^) := tbts16(src^); + btU32: tbtdouble(Dest^) := tbtu32(src^); + btS32: tbtdouble(Dest^) := tbts32(src^); + {$IFNDEF PS_NOINT64} btS64: tbtdouble(Dest^) := tbts64(src^);{$ENDIF} + btSingle: tbtdouble(Dest^) := tbtsingle(Src^); + btDouble: tbtdouble(Dest^) := tbtdouble(Src^); + btExtended: tbtdouble(Dest^) := tbtextended(Src^); + btCurrency: tbtdouble(Dest^) := tbtcurrency(Src^); + btVariant: tbtdouble(Dest^) := Variant(src^); + else raise Exception.Create(RPS_TypeMismatch); + end; + + end; + btExtended: + begin + if srctype.BaseType = btPointer then + begin + srctype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^); + Src := Pointer(Src^); + if (src = nil) or (srctype = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case srctype.BaseType of + btU8: tbtextended(Dest^) := tbtu8(src^); + btS8: tbtextended(Dest^) := tbts8(src^); + btU16: tbtextended(Dest^) := tbtu16(src^); + btS16: tbtextended(Dest^) := tbts16(src^); + btU32: tbtextended(Dest^) := tbtu32(src^); + btS32: tbtextended(Dest^) := tbts32(src^); + {$IFNDEF PS_NOINT64} btS64: tbtextended(Dest^) := tbts64(src^);{$ENDIF} + btSingle: tbtextended(Dest^) := tbtsingle(Src^); + btDouble: tbtextended(Dest^) := tbtdouble(Src^); + btExtended: tbtextended(Dest^) := tbtextended(Src^); + btCurrency: tbtextended(Dest^) := tbtcurrency(Src^); + btVariant: tbtextended(Dest^) := Variant(src^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + btCurrency: tbtcurrency(Dest^) := PSGetCurrency(Src, srctype); + btPChar: pansichar(dest^) := pansichar(PSGetAnsiString(Src, srctype)); + btString: + tbtstring(dest^) := PSGetAnsiString(Src, srctype); + btChar: tbtchar(dest^) := tbtchar(PSGetUInt(Src, srctype)); + {$IFNDEF PS_NOWIDESTRING} + btWideString: tbtwidestring(dest^) := PSGetWideString(Src, srctype); + btUnicodeString: tbtUnicodeString(dest^) := PSGetUnicodeString(Src, srctype); + btWideChar: tbtwidechar(dest^) := widechar(PSGetUInt(Src, srctype)); + {$ENDIF} + btStaticArray: + begin + if desttype <> srctype then + Result := False + else + CopyArrayContents(dest, Src, TPSTypeRec_StaticArray(desttype).Size, TPSTypeRec_StaticArray(desttype).ArrayType); + end; + btArray: + begin + if (srctype.BaseType = btStaticArray) and (TPSTypeRec_Array(desttype).ArrayType = TPSTypeRec_Array(srctype).ArrayType) then + begin + PSDynArraySetLength(Pointer(Dest^), desttype, TPSTypeRec_StaticArray(srctype).Size); + CopyArrayContents(Pointer(dest^), Src, TPSTypeRec_StaticArray(srctype).Size, TPSTypeRec_StaticArray(srctype).ArrayType); + end else if (srctype.BaseType = btvariant) and VarIsArray(Variant(src^)) then + Result := CreateArrayFromVariant(Self, dest, Variant(src^), desttype) + else if (desttype <> srctype) and not ((desttype.BaseType = btarray) and (srctype.BaseType = btArray) + and (TPSTypeRec_Array(desttype).ArrayType = TPSTypeRec_Array(srctype).ArrayType)) then + Result := False + else + CopyArrayContents(dest, src, 1, desttype); + end; + btRecord: + begin + if desttype <> srctype then + Result := False + else + CopyArrayContents(dest, Src, 1, desttype); + end; + btVariant: + begin +{$IFNDEF PS_NOINTERFACES} + if srctype.ExportName = 'IDISPATCH' then + begin + {$IFDEF DELPHI3UP} + Variant(Dest^) := IDispatch(Src^); + {$ELSE} + AssignVariantFromIDispatch(Variant(Dest^), IDispatch(Src^)); + {$ENDIF} + end else +{$ENDIF} + if srctype.BaseType = btVariant then + variant(Dest^) := variant(src^) + else + begin + tt.VI.FType := FindType2(btPointer); + tt.DestType := srctype; + tt.DataDest := src; + tt.FreeIt := False; + Result := PIFVariantToVariant(@tt, variant(dest^)); + end; + end; + btClass: + begin + if srctype.BaseType = btClass then + TObject(Dest^) := TObject(Src^) + else + // nx change start + if (srctype.BaseType in [btS32, btU32]) then + TbtU32(Dest^) := TbtU32(Src^) + else + // nx change end + Result := False; + end; +{$IFNDEF PS_NOINTERFACES} + btInterface: + begin + if Srctype.BaseType = btVariant then + begin + if desttype.ExportName = 'IDISPATCH' then + begin + {$IFDEF Delphi3UP} + IDispatch(Dest^) := IDispatch(Variant(Src^)); + {$ELSE} + AssignIDispatchFromVariant(IDispatch(Dest^), Variant(Src^)); + {$ENDIF} + end else + Result := False; +{$IFDEF Delphi3UP} + end else + if srctype.BaseType = btClass then + begin + if (TObject(Src^) = nil) or not TObject(Src^).GetInterface(TPSTypeRec_Interface(desttype).Guid, IUnknown(Dest^)) then + begin + Result := false; + Cmd_Err(erInterfaceNotSupported); + exit; + end; +{$ENDIF} + end else if srctype.BaseType = btInterface then + begin + {$IFNDEF Delphi3UP} + if IUnknown(Dest^) <> nil then + begin + IUnknown(Dest^).Release; + IUnknown(Dest^) := nil; + end; + {$ENDIF} + IUnknown(Dest^) := IUnknown(Src^); + {$IFNDEF Delphi3UP} + if IUnknown(Dest^) <> nil then + IUnknown(Dest^).AddRef; + {$ENDIF} + end else + Result := False; + end; +{$ENDIF} + else begin + Result := False; + end; + end; + if Result = False then + CMD_Err(ErTypeMismatch); + except + {$IFDEF DELPHI6UP} + Tmp := AcquireExceptionObject; + {$ELSE} + if RaiseList <> nil then + begin + Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject); + PRaiseFrame(RaiseList)^.ExceptObject := nil; + end else + Tmp := nil; + {$ENDIF} + if Tmp <> nil then + begin + if Tmp is EPSException then + begin + Result := False; + ExceptionProc(EPSException(tmp).ProcNo, EPSException(tmp).ProcPos, erCustomError, tbtString(EPSException(tmp).Message), nil); + exit; + end else + if Tmp is EDivByZero then + begin + Result := False; + CMD_Err3(erDivideByZero, '', Tmp); + Exit; + end; + if Tmp is EZeroDivide then + begin + Result := False; + CMD_Err3(erDivideByZero, '', Tmp); + Exit; + end; + if Tmp is EMathError then + begin + Result := False; + CMD_Err3(erMathError, '', Tmp); + Exit; + end; + end; + if (tmp <> nil) and (Tmp is Exception) then + CMD_Err3(erException, tbtString(Exception(Tmp).Message), Tmp) + else + CMD_Err3(erException, '', Tmp); + Result := False; + end; +end; + +function SpecImport(Sender: TPSExec; p: TPSExternalProcRec; Tag: Pointer): Boolean; forward; + + +function Class_IS(Self: TPSExec; Obj: TObject; var2type: TPSTypeRec): Boolean; +var + R: TPSRuntimeClassImporter; + cc: TPSRuntimeClass; +begin + if Obj = nil then + begin + Result := false; + exit; + end; + r := Self.FindSpecialProcImport(SpecImport); + if R = nil then + begin + Result := false; + exit; + end; + cc := r.FindClass(var2type.ExportName); + if cc = nil then + begin + result := false; + exit; + end; + try + Result := Obj is cc.FClass; + except + Result := false; + end; +end; + +type + TVariantArray = array of Variant; + PVariantArray = ^TVariantArray; +function VariantInArray(var1: Pointer; var1Type: TPSTypeRec; var2: PVariantArray): Boolean; +var + lDest: Variant; + i: Integer; +begin + IntPIFVariantToVariant(var1, var1Type, lDest); + result := false; + for i := 0 to Length(var2^) -1 do begin + if var2^[i] = lDest then begin + result := true; + break; + end; + end; +end; + + +function TPSExec.DoBooleanCalc(var1, Var2, into: Pointer; var1Type, var2type, intotype: TPSTypeRec; Cmd: Cardinal): Boolean; +var + b: Boolean; + Tmp: TObject; + tvar: Variant; + + + procedure SetBoolean(b: Boolean; var Ok: Boolean); + begin + Ok := True; + case IntoType.BaseType of + btU8: tbtu8(Into^):= Cardinal(b); + btS8: tbts8(Into^) := Longint(b); + btU16: tbtu16(Into^) := Cardinal(b); + btS16: tbts16(Into^) := Longint(b); + btU32: tbtu32(Into^) := Cardinal(b); + btS32: tbts32(Into^) := Longint(b); + btVariant: Variant(Into^) := b; + else begin + CMD_Err(ErTypeMismatch); + Ok := False; + end; + end; + end; +begin + Result := true; + try + case Cmd of + 0: begin { >= } + case var1Type.BaseType of + btU8: + if (var2Type.BaseType = btString) or (Var2Type.BaseType = btPChar) then + b := tbtchar(tbtu8(var1^)) >= PSGetAnsiString(Var2, var2type) + else + b := tbtu8(var1^) >= PSGetUInt(Var2, var2type); + btS8: b := tbts8(var1^) >= PSGetInt(Var2, var2type); + btU16: b := tbtu16(var1^) >= PSGetUInt(Var2, var2type); + btS16: b := tbts16(var1^) >= PSGetInt(Var2, var2type); + btU32: b := tbtu32(var1^) >= PSGetUInt(Var2, var2type); + btS32: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: b := tbts32(var1^) >= tbtu8(Var2^); + btS8: b := tbts32(var1^) >= tbts8(Var2^); + btU16: b := tbts32(var1^) >= tbtu16(Var2^); + btS16: b := tbts32(var1^) >= tbts16(Var2^); + btU32: b := tbts32(var1^) >= Longint(tbtu32(Var2^)); + btS32: b := tbts32(var1^) >= tbts32(Var2^); + btDouble: b := PSGetReal(Var1, var1type) >= tbtdouble(var2^); + btSingle: B := psGetReal(Var1, var1Type) >= tbtsingle(var2^); + btExtended: B := psGetReal(Var1, var1Type) >= tbtExtended(var2^); + {$IFNDEF PS_NOINT64} btS64: b := tbts32(var1^) >= tbts64(Var2^);{$ENDIF} + btChar: b := tbts32(var1^) >= Ord(tbtchar(Var2^)); + {$IFNDEF PS_NOWIDESTRING} btWideChar: b := tbts32(var1^) >= Ord(tbtwidechar(Var2^));{$ENDIF} + btVariant: b := tbts32(var1^) >= Variant(Var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + btSingle: b := tbtsingle(var1^) >= PSGetReal(Var2, var2type); + btDouble: b := tbtdouble(var1^) >= PSGetReal(Var2, var2type); + btCurrency: b := tbtcurrency(var1^) >= PSGetCurrency(Var2, var2type); + btExtended: b := tbtextended(var1^) >= PSGetReal(Var2, var2type); + {$IFNDEF PS_NOINT64} + btS64: b := tbts64(var1^) >= PSGetInt64(Var2, var2type); + {$ENDIF} + btPChar,btString: b := tbtstring(var1^) >= PSGetAnsiString(Var2, var2type); + btChar: b := tbtchar(var1^) >= PSGetAnsiString(Var2, var2type); + {$IFNDEF PS_NOWIDESTRING} + btWideChar: b := tbtwidechar(var1^) >= PSGetWideString(Var2, var2type); + btWideString: b := tbtwidestring(var1^) >= PSGetWideString(Var2, var2type); + btUnicodeString: b := tbtUnicodestring(var1^) >= PSGetUnicodeString(Var2, var2type); + {$ENDIF} + btVariant: + begin + if not IntPIFVariantToVariant(var2, var2type, tvar) then + begin + Result := false; + end else + b := Variant(var1^) >= tvar; + end; + btSet: + begin + if var1Type = var2Type then + begin + Set_Subset(var2, var1, TPSTypeRec_Set(var1Type).aByteSize, b); + end else result := False; + end; + else begin + CMD_Err(ErTypeMismatch); + exit; + end; + end; + if not Result then begin + CMD_Err(ErTypeMismatch); + exit; + end; + SetBoolean(b, Result); + end; + 1: begin { <= } + case var1Type.BaseType of + btU8: + if (var2Type.BaseType = btString) or (Var2Type.BaseType = btPChar) then + b := tbtchar(tbtu8(var1^)) <= PSGetAnsiString(Var2, var2type) + else + b := tbtu8(var1^) <= PSGetUInt(Var2, var2type); + btS8: b := tbts8(var1^) <= PSGetInt(Var2, var2type); + btU16: b := tbtu16(var1^) <= PSGetUInt(Var2, var2type); + btS16: b := tbts16(var1^) <= PSGetInt(Var2, var2type); + btU32: b := tbtu32(var1^) <= PSGetUInt(Var2, var2type); + btS32: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: b := tbts32(var1^) <= tbtu8(Var2^); + btS8: b := tbts32(var1^) <= tbts8(Var2^); + btU16: b := tbts32(var1^) <= tbtu16(Var2^); + btS16: b := tbts32(var1^) <= tbts16(Var2^); + btU32: b := tbts32(var1^) <= Longint(tbtu32(Var2^)); + btS32: b := tbts32(var1^) <= tbts32(Var2^); + btDouble: b := PSGetReal(Var1, var1type) <= tbtdouble(var2^); + btSingle: B := psGetReal(Var1, var1Type) <= tbtsingle(var2^); + btExtended: B := psGetReal(Var1, var1Type) <= tbtExtended(var2^); + {$IFNDEF PS_NOINT64} btS64: b := tbts32(var1^) <= tbts64(Var2^);{$ENDIF} + btChar: b := tbts32(var1^) <= Ord(tbtchar(Var2^)); + {$IFNDEF PS_NOWIDESTRING} btWideChar: b := tbts32(var1^) <= Ord(tbtwidechar(Var2^));{$ENDIF} + btVariant: b := tbts32(var1^) <= Variant(Var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; btSingle: b := tbtsingle(var1^) <= PSGetReal(Var2, var2type); + btCurrency: b := tbtcurrency(var1^) <= PSGetCurrency(Var2, var2type); + btDouble: b := tbtdouble(var1^) <= PSGetReal(Var2, var2type); + btExtended: b := tbtextended(var1^) <= PSGetReal(Var2, var2type); + {$IFNDEF PS_NOINT64} + btS64: b := tbts64(var1^) <= PSGetInt64(Var2, var2type); + {$ENDIF} + btPChar,btString: b := tbtstring(var1^) <= PSGetAnsiString(Var2, var2type); + btChar: b := tbtchar(var1^) <= PSGetAnsiString(Var2, var2type); + {$IFNDEF PS_NOWIDESTRING} + btWideChar: b := tbtwidechar(var1^) <= PSGetWideString(Var2, var2type); + btWideString: b := tbtwidestring(var1^) <= PSGetWideString(Var2, var2type); + btUnicodeString: b := tbtUnicodestring(var1^) <= PSGetUnicodeString(Var2, var2type); + {$ENDIF} + btVariant: + begin + if not IntPIFVariantToVariant(var2, var2type, tvar) then + begin + Result := false; + end else + b := Variant(var1^) <= tvar; + end; + btSet: + begin + if var1Type = var2Type then + begin + Set_Subset(var1, var2, TPSTypeRec_Set(var1Type).aByteSize, b); + end else result := False; + end; + else begin + CMD_Err(ErTypeMismatch); + exit; + end; + end; + if not Result then begin + CMD_Err(erTypeMismatch); + exit; + end; + SetBoolean(b, Result); + end; + 2: begin { > } + case var1Type.BaseType of + btU8: + if (var2Type.BaseType = btString) or (Var2Type.BaseType = btPChar) then + b := tbtchar(tbtu8(var1^)) > PSGetAnsiString(Var2, var2type) + else + b := tbtu8(var1^) > PSGetUInt(Var2, var2type); + btS8: b := tbts8(var1^) > PSGetInt(Var2, var2type); + btU16: b := tbtu16(var1^) > PSGetUInt(Var2, var2type); + btS16: b := tbts16(var1^) > PSGetInt(Var2, var2type); + btU32: b := tbtu32(var1^) > PSGetUInt(Var2, var2type); + btS32: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: b := tbts32(var1^) > tbtu8(Var2^); + btS8: b := tbts32(var1^) > tbts8(Var2^); + btU16: b := tbts32(var1^) > tbtu16(Var2^); + btS16: b := tbts32(var1^) > tbts16(Var2^); + btU32: b := tbts32(var1^) > Longint(tbtu32(Var2^)); + btS32: b := tbts32(var1^) > tbts32(Var2^); + btDouble: b := PSGetReal(Var1, var1type) > tbtdouble(var2^); + btSingle: B := psGetReal(Var1, var1Type) > tbtsingle(var2^); + btExtended: B := psGetReal(Var1, var1Type) > tbtExtended(var2^); + {$IFNDEF PS_NOINT64} btS64: b := tbts32(var1^) > tbts64(Var2^);{$ENDIF} + btChar: b := tbts32(var1^) > Ord(tbtchar(Var2^)); + {$IFNDEF PS_NOWIDESTRING} btWideChar: b := tbts32(var1^) = Ord(tbtwidechar(Var2^));{$ENDIF} + btVariant: b := tbts32(var1^) > Variant(Var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; btSingle: b := tbtsingle(var1^) > PSGetReal(Var2, var2type); + btDouble: b := tbtdouble(var1^) > PSGetReal(Var2, var2type); + btExtended: b := tbtextended(var1^) > PSGetReal(Var2, var2type); + btCurrency: b := tbtcurrency(var1^) > PSGetCurrency(Var2, var2type); + {$IFNDEF PS_NOINT64} + btS64: b := tbts64(var1^) > PSGetInt64(Var2, var2type); + {$ENDIF} + btPChar,btString: b := tbtstring(var1^) > PSGetAnsiString(Var2, var2type); + btChar: b := tbtchar(var1^) > PSGetAnsiString(Var2, var2type); + {$IFNDEF PS_NOWIDESTRING} + btWideChar: b := tbtwidechar(var1^) > PSGetWideString(Var2, var2type); + btWideString: b := tbtwidestring(var1^) > PSGetWideString(Var2, var2type); + btUnicodeString: b := tbtUnicodestring(var1^) > PSGetUnicodeString(Var2, var2type); + {$ENDIF} + btVariant: + begin + if not IntPIFVariantToVariant(var2, var2type, tvar) then + begin + Result := false; + end else + b := Variant(var1^) > tvar; + end; + else begin + CMD_Err(erTypeMismatch); + exit; + end; + end; + if not Result then begin + CMD_Err(erTypeMismatch); + exit; + end; + SetBoolean(b, Result); + end; + 3: begin { < } + case var1Type.BaseType of + btU8: + if (var2Type.BaseType = btString) or (Var2Type.BaseType = btPChar) then + b := tbtchar(tbtu8(var1^)) < PSGetAnsiString(Var2, var2type) + else + b := tbtu8(var1^) < PSGetUInt(Var2, var2type); + btS8: b := tbts8(var1^) < PSGetInt(Var2, var2type); + btU16: b := tbtu16(var1^) < PSGetUInt(Var2, var2type); + btS16: b := tbts16(var1^) < PSGetInt(Var2, var2type); + btU32: b := tbtu32(var1^) < PSGetUInt(Var2, var2type); + btS32: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: b := tbts32(var1^) < tbtu8(Var2^); + btS8: b := tbts32(var1^) < tbts8(Var2^); + btU16: b := tbts32(var1^) < tbtu16(Var2^); + btS16: b := tbts32(var1^) < tbts16(Var2^); + btU32: b := tbts32(var1^) < Longint(tbtu32(Var2^)); + btS32: b := tbts32(var1^) < tbts32(Var2^); + btDouble: b := PSGetReal(Var1, var1type) < tbtdouble(var2^); + btSingle: B := psGetReal(Var1, var1Type) < tbtsingle(var2^); + btExtended: B := psGetReal(Var1, var1Type) < tbtExtended(var2^); + {$IFNDEF PS_NOINT64} btS64: b := tbts32(var1^) < tbts64(Var2^);{$ENDIF} + btChar: b := tbts32(var1^) < Ord(tbtchar(Var2^)); + {$IFNDEF PS_NOWIDESTRING} btWideChar: b := tbts32(var1^) < Ord(tbtwidechar(Var2^));{$ENDIF} + btVariant: b := tbts32(var1^) < Variant(Var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; btSingle: b := tbtsingle(var1^) < PSGetReal(Var2, var2type); + btDouble: b := tbtdouble(var1^) < PSGetReal(Var2, var2type); + btCurrency: b := tbtcurrency(var1^) < PSGetCurrency(Var2, var2type); + btExtended: b := tbtextended(var1^) < PSGetReal(Var2, var2type); + {$IFNDEF PS_NOINT64} + btS64: b := tbts64(var1^) < PSGetInt64(Var2, var2type); + {$ENDIF} + btPChar,btString: b := tbtstring(var1^) < PSGetAnsiString(Var2, var2type); + btChar: b := tbtchar(var1^) < PSGetAnsiString(Var2, var2type); + {$IFNDEF PS_NOWIDESTRING} + btWideChar: b := tbtwidechar(var1^) < PSGetWideString(Var2, var2type); + btWideString: b := tbtwidestring(var1^) < PSGetWideString(Var2, var2type); + btUnicodeString: b := tbtUnicodestring(var1^) < PSGetUnicodeString(Var2, var2type); + {$ENDIF} + btVariant: + begin + if not IntPIFVariantToVariant(var2, var2type, tvar) then + begin + Result := false; + end else + b := Variant(var1^) < tvar; + end; + else begin + CMD_Err(erTypeMismatch); + exit; + end; + end; + if not Result then begin + CMD_Err(erTypeMismatch); + exit; + end; + SetBoolean(b, Result); + end; + 4: begin { <> } + case var1Type.BaseType of + btInterface: + begin + if var2Type.BaseType = btInterface then + b := Pointer(var1^) <> Pointer(var2^) // no need to cast it to IUnknown + else + Result := false; + end; + btClass: + begin + if var2Type.BaseType = btclass then + b := TObject(var1^) <> TObject(var2^) + else + Result := false; + end; + btU8: + if (var2Type.BaseType = btString) or (Var2Type.BaseType = btPChar) then + b := tbtchar(tbtu8(var1^)) <> PSGetAnsiString(Var2, var2type) + else + b := tbtu8(var1^) <> PSGetUInt(Var2, var2type); + btS8: b := tbts8(var1^) <> PSGetInt(Var2, var2type); + btU16: b := tbtu16(var1^) <> PSGetUInt(Var2, var2type); + btS16: b := tbts16(var1^) <> PSGetInt(Var2, var2type); + btProcPtr: + begin + if Pointer(Var1^) = Pointer(Var2^) then + begin + if Longint(Var1^) = 0 then + b := ((Pointer(Pointer(IPointer(Var1)+PointerSize2)^) <> Pointer(Pointer(IPointer(Var2)+PointerSize2)^)) or + (Pointer(Pointer(IPointer(Var1)+PointerSize2)^) <> Pointer(Pointer(IPointer(Var2)+PointerSize2)^))) + else + b := False; + end else b := True; + end; + btU32: b := tbtu32(var1^) <> PSGetUInt(Var2, var2type); + btS32: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: b := tbts32(var1^) <> tbtu8(Var2^); + btS8: b := tbts32(var1^) <> tbts8(Var2^); + btU16: b := tbts32(var1^) <> tbtu16(Var2^); + btS16: b := tbts32(var1^) <> tbts16(Var2^); + btProcPtr, btU32: b := tbts32(var1^)<> Longint(tbtu32(Var2^)); + btS32: b := tbts32(var1^) <> tbts32(Var2^); + btDouble: b := PSGetReal(Var1, var1type) <> tbtdouble(var2^); + btSingle: B := psGetReal(Var1, var1Type) <> tbtsingle(var2^); + btExtended: B := psGetReal(Var1, var1Type) <> tbtExtended(var2^); + {$IFNDEF PS_NOINT64} btS64: b := tbts32(var1^) <> tbts64(Var2^);{$ENDIF} + btChar: b := tbts32(var1^) <> Ord(tbtchar(Var2^)); + {$IFNDEF PS_NOWIDESTRING} btWideChar: b := tbts32(var1^) <> Ord(tbtwidechar(Var2^));{$ENDIF} + btVariant: b := tbts32(var1^) <> Variant(Var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; btSingle: b := tbtsingle(var1^) <> PSGetReal(Var2, var2type); + btDouble: b := tbtdouble(var1^) <> PSGetReal(Var2, var2type); + btExtended: b := tbtextended(var1^) <> PSGetReal(Var2, var2type); + btCurrency: b := tbtcurrency(var1^) <> PSGetCurrency(Var2, var2type); + btPChar,btString: b := tbtstring(var1^) <> PSGetAnsiString(Var2, var2type); + {$IFNDEF PS_NOINT64} + btS64: b := tbts64(var1^) <> PSGetInt64(Var2, var2type); + {$ENDIF} + btChar: b := tbtchar(var1^) <> PSGetAnsiString(Var2, var2type); + {$IFNDEF PS_NOWIDESTRING} + btWideChar: b := tbtwidechar(var1^) <> PSGetWideString(Var2, var2type); + btWideString: b := tbtwidestring(var1^) <> PSGetWideString(Var2, var2type); + btUnicodeString: b := tbtUnicodeString(var1^) <> PSGetUnicodeString(Var2, var2type); + {$ENDIF} + btVariant: + begin + if not IntPIFVariantToVariant(var2, var2type, tvar) then + begin + Result := false; + end else + b := Variant(var1^) <> tvar; + end; + btSet: + begin + if var1Type = var2Type then + begin + Set_Equal(var1, var2, TPSTypeRec_Set(var1Type).aByteSize, b); + b := not b; + end else result := False; + end; + else begin + CMD_Err(erTypeMismatch); + exit; + end; + end; + if not Result then begin + CMD_Err(erTypeMismatch); + exit; + end; + SetBoolean(b, Result); + end; + 5: begin { = } + case var1Type.BaseType of + btInterface: + begin + if var2Type.BaseType = btInterface then + b := Pointer(var1^) = Pointer(var2^) // no need to cast it to IUnknown + else + Result := false; + end; + btClass: + begin + if var2Type.BaseType = btclass then + b := TObject(var1^) = TObject(var2^) + else + Result := false; + end; + btU8: + if (var2Type.BaseType = btString) or (Var2Type.BaseType = btPChar) then + b := tbtchar(tbtu8(var1^)) = PSGetAnsiString(Var2, var2type) + else + b := tbtu8(var1^) = PSGetUInt(Var2, var2type); + btS8: b := tbts8(var1^) = PSGetInt(Var2, var2type); + btU16: b := tbtu16(var1^) = PSGetUInt(Var2, var2type); + btS16: b := tbts16(var1^) = PSGetInt(Var2, var2type); + btU32: b := tbtu32(var1^) = PSGetUInt(Var2, var2type); + btProcPtr: + begin + if Pointer(Var1^) = Pointer(Var2^) then + begin + if Longint(Var1^) = 0 then + b := ((Pointer(Pointer(IPointer(Var1)+PointerSize2)^) = Pointer(Pointer(IPointer(Var2)+PointerSize2)^)) and + (Pointer(Pointer(IPointer(Var1)+PointerSize2)^) = Pointer(Pointer(IPointer(Var2)+PointerSize2)^))) + else + b := True; + end else b := False; + end; + btS32: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: b := tbts32(var1^) = tbtu8(Var2^); + btS8: b := tbts32(var1^) = tbts8(Var2^); + btU16: b := tbts32(var1^) = tbtu16(Var2^); + btS16: b := tbts32(var1^) = tbts16(Var2^); + btProcPtr, btU32: b := tbts32(var1^) = Longint(tbtu32(Var2^)); + btS32: b := tbts32(var1^) = tbts32(Var2^); + btDouble: b := PSGetReal(Var1, var1type) = tbtdouble(var2^); + btSingle: B := psGetReal(Var1, var1Type) = tbtsingle(var2^); + btExtended: B := psGetReal(Var1, var1Type) = tbtExtended(var2^); + {$IFNDEF PS_NOINT64} btS64: b := tbts32(var1^) = tbts64(Var2^);{$ENDIF} + btChar: b := tbts32(var1^) = Ord(tbtchar(Var2^)); + {$IFNDEF PS_NOWIDESTRING} btWideChar: b := tbts32(var1^) = Ord(tbtwidechar(Var2^));{$ENDIF} + btVariant: b := tbts32(var1^) = Variant(Var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; btSingle: b := tbtsingle(var1^) = PSGetReal(Var2, var2type); + btDouble: b := tbtdouble(var1^) = PSGetReal(Var2, var2type); + btExtended: b := tbtextended(var1^) = PSGetReal(Var2, var2type); + btCurrency: b := tbtcurrency(var1^) = PSGetCurrency(Var2, var2type); + btPchar, btString: b := tbtstring(var1^) = PSGetAnsiString(Var2, var2type); + {$IFNDEF PS_NOINT64} + btS64: b := tbts64(var1^) = PSGetInt64(Var2, var2type); + {$ENDIF} + btChar: b := tbtchar(var1^) = PSGetAnsiString(Var2, var2type); + {$IFNDEF PS_NOWIDESTRING} + btWideChar: b := tbtwidechar(var1^) = PSGetWideString(Var2, var2type); + btWideString: b := tbtwidestring(var1^) = PSGetWideString(Var2, var2type); + btUnicodeString: b := tbtUnicodestring(var1^) = PSGetUnicodeString(Var2, var2type); + {$ENDIF} + btVariant: + begin + if not IntPIFVariantToVariant(var2, var2type, tvar) then + begin + Result := false; + end else + b := Variant(var1^) = tvar; + end; + btSet: + begin + if var1Type = var2Type then + begin + Set_Equal(var1, var2, TPSTypeRec_Set(var1Type).aByteSize, b); + end else result := False; + end; + else begin + CMD_Err(erTypeMismatch); + exit; + end; + end; + if not Result then begin + CMD_Err(erTypeMismatch); + exit; + end; + SetBoolean(b, Result); + end; + 6: begin { in } + if (var2Type.BaseType = btArray) and (TPSTypeRec_Array(var2type).ArrayType.BaseType = btVariant) then + begin + b := VariantInArray(var1, var1Type, var2); + SetBoolean(b, Result); + end else + if var2Type.BaseType = btSet then + begin + Cmd := PSGetUInt(var1, var1type); + if not Result then + begin + CMD_Err(erTypeMismatch); + exit; + end; + if Cmd >= Cardinal(TPSTypeRec_Set(var2Type).aBitSize) then + begin + cmd_Err(erOutofRecordRange); + Result := False; + Exit; + end; + Set_membership(Cmd, var2, b); + SetBoolean(b, Result); + end else + begin + CMD_Err(erTypeMismatch); + exit; + end; + end; + 7: + begin // is + case var1Type.BaseType of + btClass: + begin + if var2type.BaseType <> btU32 then + Result := False + else + begin + var2type := FTypes[tbtu32(var2^)]; + if (var2type = nil) or (var2type.BaseType <> btClass) then + Result := false + else + begin + Setboolean(Class_IS(Self, TObject(var1^), var2type), Result); + end; + end; + end; + else begin + CMD_Err(erTypeMismatch); + exit; + end; + end; + if not Result then begin + CMD_Err(erTypeMismatch); + exit; + end; + end; + else begin + Result := False; + CMD_Err(erInvalidOpcodeParameter); + exit; + end; + end; + except + {$IFDEF DELPHI6UP} + Tmp := AcquireExceptionObject; + {$ELSE} + if RaiseList <> nil then + begin + Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject); + PRaiseFrame(RaiseList)^.ExceptObject := nil; + end else + Tmp := nil; + {$ENDIF} + if Tmp <> nil then + begin + if Tmp is EPSException then + begin + Result := False; + ExceptionProc(EPSException(tmp).ProcNo, EPSException(tmp).ProcPos, erCustomError, tbtString(EPSException(tmp).Message), nil); + exit; + end else + if Tmp is EDivByZero then + begin + Result := False; + CMD_Err3(erDivideByZero, '', Tmp); + Exit; + end; + if Tmp is EZeroDivide then + begin + Result := False; + CMD_Err3(erDivideByZero, '', Tmp); + Exit; + end; + if Tmp is EMathError then + begin + Result := False; + CMD_Err3(erMathError, '', Tmp); + Exit; + end; + end; + if (tmp <> nil) and (Tmp is Exception) then + CMD_Err3(erException, tbtString(Exception(Tmp).Message), Tmp) + else + CMD_Err3(erException, '', Tmp); + Result := False; + end; +end; + +function VarIsFloat(const V: Variant): Boolean; +begin + Result := VarType(V) in [varSingle, varDouble, varCurrency]; +end; + +function TPSExec.DoCalc(var1, Var2: Pointer; var1Type, var2type: TPSTypeRec; CalcType: Cardinal): Boolean; + { var1=dest, var2=src } +var + Tmp: TObject; + tvar: Variant; +begin + try + Result := True; + case CalcType of + 0: begin { + } + case var1Type.BaseType of + btU8: tbtU8(var1^) := tbtU8(var1^) + PSGetUInt(Var2, var2type); + btS8: tbts8(var1^) := tbts8(var1^) + PSGetInt(Var2, var2type); + btU16: tbtU16(var1^) := tbtU16(var1^) + PSGetUInt(Var2, var2type); + btS16: tbts16(var1^) := tbts16(var1^) + PSGetInt(Var2, var2type); + btU32: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: tbtU32(var1^) := tbtU32(var1^) + tbtu8(var2^); + btS8: tbtU32(var1^) := tbtU32(var1^) + cardinal(longint(tbts8(var2^))); + btU16: tbtU32(var1^) := tbtU32(var1^) + tbtu16(var2^); + btS16: tbtU32(var1^) := tbtU32(var1^) + cardinal(longint(tbts16(var2^))); + btU32: tbtU32(var1^) := tbtU32(var1^) + tbtu32(var2^); + btS32: tbtU32(var1^) := tbtU32(var1^) + cardinal(tbts32(var2^)); + {$IFNDEF PS_NOINT64} btS64: tbtU32(var1^) := tbtU32(var1^) + tbts64(var2^);{$ENDIF} + btChar: tbtU32(var1^) := tbtU32(var1^) + Ord(tbtchar(var2^)); + {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtU32(var1^) := tbtU32(var1^) + Ord(tbtwidechar(var2^));{$ENDIF} + btVariant: tbtU32(var1^) := tbtU32(var1^) + Variant(var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + btS32: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: tbts32(var1^) := tbts32(var1^) + tbtu8(var2^); + btS8: tbts32(var1^) := tbts32(var1^) + tbts8(var2^); + btU16: tbts32(var1^) := tbts32(var1^) + tbtu16(var2^); + btS16: tbts32(var1^) := tbts32(var1^) + tbts16(var2^); + btU32: tbts32(var1^) := tbts32(var1^) + Longint(tbtu32(var2^)); + btS32: tbts32(var1^) := tbts32(var1^) + tbts32(var2^); + {$IFNDEF PS_NOINT64} btS64: tbts32(var1^) := tbts32(var1^) + tbts64(var2^);{$ENDIF} + btChar: tbts32(var1^) := tbts32(var1^) + Ord(tbtchar(var2^)); + {$IFNDEF PS_NOWIDESTRING} btWideChar: tbts32(var1^) := tbts32(var1^) + Ord(tbtwidechar(var2^));{$ENDIF} + btVariant: tbts32(var1^) := tbts32(var1^) + Variant(var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + {$IFNDEF PS_NOINT64} + btS64: tbts64(var1^) := tbts64(var1^) + PSGetInt64(var2, var2type); + {$ENDIF} + btSingle: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: tbtsingle(var1^) := tbtsingle(var1^) + tbtu8(var2^); + btS8: tbtsingle(var1^) := tbtsingle(var1^) + tbts8(var2^); + btU16: tbtsingle(var1^) := tbtsingle(var1^) + tbtu16(var2^); + btS16: tbtsingle(var1^) := tbtsingle(var1^) + tbts16(var2^); + btU32: tbtsingle(var1^) := tbtsingle(var1^) + tbtu32(var2^); + btS32: tbtsingle(var1^) := tbtsingle(var1^) + tbts32(var2^); + {$IFNDEF PS_NOINT64} btS64: tbtsingle(var1^) := tbtsingle(var1^) + tbts64(var2^);{$ENDIF} + btSingle: tbtsingle(var1^) := tbtsingle(var1^) + tbtsingle(var2^); + btDouble: tbtsingle(var1^) := tbtsingle(var1^) + tbtdouble(var2^); + btExtended: tbtsingle(var1^) := tbtsingle(var1^) + tbtextended(var2^); + btCurrency: tbtsingle(var1^) := tbtsingle(var1^) + tbtcurrency(var2^); + btVariant: tbtsingle(var1^) := tbtsingle(var1^) + Variant(var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + btDouble: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: tbtdouble(var1^) := tbtdouble(var1^) + tbtu8(var2^); + btS8: tbtdouble(var1^) := tbtdouble(var1^) + tbts8(var2^); + btU16: tbtdouble(var1^) := tbtdouble(var1^) + tbtu16(var2^); + btS16: tbtdouble(var1^) := tbtdouble(var1^) + tbts16(var2^); + btU32: tbtdouble(var1^) := tbtdouble(var1^) + tbtu32(var2^); + btS32: tbtdouble(var1^) := tbtdouble(var1^) + tbts32(var2^); + {$IFNDEF PS_NOINT64} btS64: tbtdouble(var1^) := tbtdouble(var1^) + tbts64(var2^);{$ENDIF} + btSingle: tbtdouble(var1^) := tbtdouble(var1^) + tbtsingle(var2^); + btDouble: tbtdouble(var1^) := tbtdouble(var1^) + tbtdouble(var2^); + btExtended: tbtdouble(var1^) := tbtdouble(var1^) + tbtextended(var2^); + btCurrency: tbtdouble(var1^) := tbtdouble(var1^) + tbtcurrency(var2^); + btVariant: tbtdouble(var1^) := tbtdouble(var1^) + Variant(var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + btCurrency: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: tbtcurrency(var1^) := tbtcurrency(var1^) + tbtu8(var2^); + btS8: tbtcurrency(var1^) := tbtcurrency(var1^) + tbts8(var2^); + btU16: tbtcurrency(var1^) := tbtcurrency(var1^) + tbtu16(var2^); + btS16: tbtcurrency(var1^) := tbtcurrency(var1^) + tbts16(var2^); + btU32: tbtcurrency(var1^) := tbtdouble(var1^) + tbtu32(var2^); + btS32: tbtcurrency(var1^) := tbtcurrency(var1^) + tbts32(var2^); + {$IFNDEF PS_NOINT64} btS64: tbtcurrency(var1^) := tbtdouble(var1^) + tbts64(var2^);{$ENDIF} + btSingle: tbtcurrency(var1^) := tbtcurrency(var1^) + tbtsingle(var2^); + btDouble: tbtcurrency(var1^) := tbtcurrency(var1^) + tbtdouble(var2^); + btExtended: tbtcurrency(var1^) := tbtcurrency(var1^) + tbtextended(var2^); + btCurrency: tbtcurrency(var1^) := tbtcurrency(var1^) + tbtcurrency(var2^); + btVariant: tbtcurrency(var1^) := tbtcurrency(var1^) + Variant(var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + btExtended: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: tbtextended(var1^) := tbtextended(var1^) + tbtu8(var2^); + btS8: tbtextended(var1^) := tbtextended(var1^) + tbts8(var2^); + btU16: tbtextended(var1^) := tbtextended(var1^) + tbtu16(var2^); + btS16: tbtextended(var1^) := tbtextended(var1^) + tbts16(var2^); + btU32: tbtextended(var1^) := tbtextended(var1^) + tbtu32(var2^); + btS32: tbtextended(var1^) := tbtextended(var1^) + tbts32(var2^); + {$IFNDEF PS_NOINT64} btS64: tbtextended(var1^) := tbtextended(var1^) + tbts64(var2^);{$ENDIF} + btSingle: tbtextended(var1^) := tbtextended(var1^) + tbtsingle(var2^); + btDouble: tbtextended(var1^) := tbtextended(var1^) + tbtdouble(var2^); + btExtended: tbtextended(var1^) := tbtextended(var1^) + tbtextended(var2^); + btCurrency: tbtextended(var1^) := tbtextended(var1^) + tbtcurrency(var2^); + btVariant: tbtextended(var1^) := tbtextended(var1^) + Variant(var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + btPchar, btString: tbtstring(var1^) := tbtstring(var1^) + PSGetAnsiString(Var2, var2type); + btChar: tbtchar(var1^) := tbtchar(ord(tbtchar(var1^)) + PSGetUInt(Var2, var2type)); + {$IFNDEF PS_NOWIDESTRING} + btWideChar: tbtwidechar(var1^) := widechar(ord(tbtwidechar(var1^)) + PSGetUInt(Var2, var2type)); + btWideString: tbtwidestring(var1^) := tbtwidestring(var1^) + PSGetWideString(Var2, var2type); + btUnicodeString: tbtUnicodestring(var1^) := tbtUnicodestring(var1^) + PSGetUnicodeString(Var2, var2type); + {$ENDIF} + btVariant: + begin + tvar := null; + if not IntPIFVariantToVariant(var2, var2type, tvar) then + begin + Result := false; + end else + Variant(var1^) := Variant(var1^) + tvar; + end; + btSet: + begin + if var1Type = var2Type then + begin + Set_Union(var1, var2, TPSTypeRec_Set(var1Type).aByteSize); + end else result := False; + end; + + else begin + CMD_Err(erTypeMismatch); + exit; + end; + end; + if not Result then begin + CMD_Err(erTypeMismatch); + exit; + end; + end; + 1: begin { - } + case var1Type.BaseType of + btU8: tbtU8(var1^) := tbtU8(var1^) - PSGetUInt(Var2, var2type); + btS8: tbts8(var1^) := tbts8(var1^) - PSGetInt(Var2, var2type); + btU16: tbtU16(var1^) := tbtU16(var1^) - PSGetUInt(Var2, var2type); + btS16: tbts16(var1^) := tbts16(var1^) - PSGetInt(Var2, var2type); + btU32: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: tbtU32(var1^) := tbtU32(var1^) - tbtu8(var2^); + btS8: tbtU32(var1^) := tbtU32(var1^) - cardinal(longint(tbts8(var2^))); + btU16: tbtU32(var1^) := tbtU32(var1^) - tbtu16(var2^); + btS16: tbtU32(var1^) := tbtU32(var1^) - cardinal(longint(tbts16(var2^))); + btU32: tbtU32(var1^) := tbtU32(var1^) - tbtu32(var2^); + btS32: tbtU32(var1^) := tbtU32(var1^) - cardinal(tbts32(var2^)); + {$IFNDEF PS_NOINT64} btS64: tbtU32(var1^) := tbtU32(var1^) - tbts64(var2^);{$ENDIF} + btChar: tbtU32(var1^) := tbtU32(var1^) - Ord(tbtchar(var2^)); + {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtU32(var1^) := tbtU32(var1^) - Ord(tbtwidechar(var2^));{$ENDIF} + btVariant: tbtU32(var1^) := tbtU32(var1^) - Variant(var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + btS32: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: tbts32(var1^) := tbts32(var1^) - tbtu8(var2^); + btS8: tbts32(var1^) := tbts32(var1^) - tbts8(var2^); + btU16: tbts32(var1^) := tbts32(var1^) - tbtu16(var2^); + btS16: tbts32(var1^) := tbts32(var1^) - tbts16(var2^); + btU32: tbts32(var1^) := tbts32(var1^) - Longint(tbtu32(var2^)); + btS32: tbts32(var1^) := tbts32(var1^) - tbts32(var2^); + {$IFNDEF PS_NOINT64} btS64: tbts32(var1^) := tbts32(var1^) - tbts64(var2^);{$ENDIF} + btChar: tbts32(var1^) := tbts32(var1^) - Ord(tbtchar(var2^)); + {$IFNDEF PS_NOWIDESTRING} btWideChar: tbts32(var1^) := tbts32(var1^) - Ord(tbtwidechar(var2^));{$ENDIF} + btVariant: tbts32(var1^) := tbts32(var1^) - Variant(var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + {$IFNDEF PS_NOINT64} + btS64: tbts64(var1^) := tbts64(var1^) - PSGetInt64(var2, var2type); + {$ENDIF} + btSingle: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: tbtsingle(var1^) := tbtsingle(var1^) - tbtu8(var2^); + btS8: tbtsingle(var1^) := tbtsingle(var1^) - tbts8(var2^); + btU16: tbtsingle(var1^) := tbtsingle(var1^) - tbtu16(var2^); + btS16: tbtsingle(var1^) := tbtsingle(var1^) - tbts16(var2^); + btU32: tbtsingle(var1^) := tbtsingle(var1^) - tbtu32(var2^); + btS32: tbtsingle(var1^) := tbtsingle(var1^) - tbts32(var2^); + {$IFNDEF PS_NOINT64} btS64: tbtsingle(var1^) := tbtsingle(var1^) - tbts64(var2^);{$ENDIF} + btSingle: tbtsingle(var1^) := tbtsingle(var1^) - tbtsingle(var2^); + btDouble: tbtsingle(var1^) := tbtsingle(var1^) - tbtdouble(var2^); + btExtended: tbtsingle(var1^) := tbtsingle(var1^) - tbtextended(var2^); + btCurrency: tbtsingle(var1^) := tbtsingle(var1^) - tbtcurrency(var2^); + btVariant: tbtsingle(var1^) := tbtsingle(var1^) - Variant(var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + btCurrency: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: tbtcurrency(var1^) := tbtcurrency(var1^) - tbtu8(var2^); + btS8: tbtcurrency(var1^) := tbtcurrency(var1^) - tbts8(var2^); + btU16: tbtcurrency(var1^) := tbtcurrency(var1^) - tbtu16(var2^); + btS16: tbtcurrency(var1^) := tbtcurrency(var1^) - tbts16(var2^); + btU32: tbtcurrency(var1^) := tbtdouble(var1^) - tbtu32(var2^); + btS32: tbtcurrency(var1^) := tbtcurrency(var1^) - tbts32(var2^); + {$IFNDEF PS_NOINT64} btS64: tbtcurrency(var1^) := tbtdouble(var1^) - tbts64(var2^);{$ENDIF} + btSingle: tbtcurrency(var1^) := tbtcurrency(var1^) - tbtsingle(var2^); + btDouble: tbtcurrency(var1^) := tbtcurrency(var1^) - tbtdouble(var2^); + btExtended: tbtcurrency(var1^) := tbtcurrency(var1^) - tbtextended(var2^); + btCurrency: tbtcurrency(var1^) := tbtcurrency(var1^) - tbtcurrency(var2^); + btVariant: tbtcurrency(var1^) := tbtcurrency(var1^) - Variant(var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + btDouble: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: tbtdouble(var1^) := tbtdouble(var1^) - tbtu8(var2^); + btS8: tbtdouble(var1^) := tbtdouble(var1^) - tbts8(var2^); + btU16: tbtdouble(var1^) := tbtdouble(var1^) - tbtu16(var2^); + btS16: tbtdouble(var1^) := tbtdouble(var1^) - tbts16(var2^); + btU32: tbtdouble(var1^) := tbtdouble(var1^) - tbtu32(var2^); + btS32: tbtdouble(var1^) := tbtdouble(var1^) - tbts32(var2^); + {$IFNDEF PS_NOINT64} btS64: tbtdouble(var1^) := tbtdouble(var1^) - tbts64(var2^);{$ENDIF} + btSingle: tbtdouble(var1^) := tbtdouble(var1^) - tbtsingle(var2^); + btDouble: tbtdouble(var1^) := tbtdouble(var1^) - tbtdouble(var2^); + btExtended: tbtdouble(var1^) := tbtdouble(var1^) - tbtextended(var2^); + btCurrency: tbtdouble(var1^) := tbtdouble(var1^) - tbtcurrency(var2^); + btVariant: tbtdouble(var1^) := tbtdouble(var1^) - Variant(var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + btExtended: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: tbtextended(var1^) := tbtextended(var1^) - tbtu8(var2^); + btS8: tbtextended(var1^) := tbtextended(var1^) - tbts8(var2^); + btU16: tbtextended(var1^) := tbtextended(var1^) - tbtu16(var2^); + btS16: tbtextended(var1^) := tbtextended(var1^) - tbts16(var2^); + btU32: tbtextended(var1^) := tbtextended(var1^) - tbtu32(var2^); + btS32: tbtextended(var1^) := tbtextended(var1^) - tbts32(var2^); + {$IFNDEF PS_NOINT64} btS64: tbtextended(var1^) := tbtextended(var1^) -+tbts64(var2^);{$ENDIF} + btSingle: tbtextended(var1^) := tbtextended(var1^) - tbtsingle(var2^); + btDouble: tbtextended(var1^) := tbtextended(var1^) - tbtdouble(var2^); + btExtended: tbtextended(var1^) := tbtextended(var1^) - tbtextended(var2^); + btCurrency: tbtextended(var1^) := tbtextended(var1^) - tbtcurrency(var2^); + btVariant: tbtextended(var1^) := tbtextended(var1^) - Variant(var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + btChar: tbtchar(var1^):= tbtchar(ord(tbtchar(var1^)) - PSGetUInt(Var2, var2type)); + {$IFNDEF PS_NOWIDESTRING} + btWideChar: tbtwidechar(var1^) := widechar(ord(tbtwidechar(var1^)) - PSGetUInt(Var2, var2type)); + {$ENDIF} + btVariant: + begin + if not IntPIFVariantToVariant(var2, var2type, tvar) then + begin + Result := false; + end else + Variant(var1^) := Variant(var1^) - tvar; + end; + btSet: + begin + if var1Type = var2Type then + begin + Set_Diff(var1, var2, TPSTypeRec_Set(var1Type).aByteSize); + end else result := False; + end; + else begin + CMD_Err(erTypeMismatch); + exit; + end; + end; + if not Result then begin + CMD_Err(erTypeMismatch); + exit; + end; + end; + 2: begin { * } + case var1Type.BaseType of + btU8: tbtU8(var1^) := tbtU8(var1^) * PSGetUInt(Var2, var2type); + btS8: tbts8(var1^) := tbts8(var1^) * PSGetInt(Var2, var2type); + btU16: tbtU16(var1^) := tbtU16(var1^) * PSGetUInt(Var2, var2type); + btS16: tbts16(var1^) := tbts16(var1^) * PSGetInt(Var2, var2type); + btU32: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: tbtU32(var1^) := tbtU32(var1^) * tbtu8(var2^); + btS8: tbtU32(var1^) := tbtU32(var1^) * cardinal(longint(tbts8(var2^))); + btU16: tbtU32(var1^) := tbtU32(var1^) * tbtu16(var2^); + btS16: tbtU32(var1^) := tbtU32(var1^) * cardinal(longint(tbts16(var2^))); + btU32: tbtU32(var1^) := tbtU32(var1^) * tbtu32(var2^); + btS32: tbtU32(var1^) := tbtU32(var1^) * cardinal(tbts32(var2^)); + {$IFNDEF PS_NOINT64} btS64: tbtU32(var1^) := tbtU32(var1^) * tbts64(var2^);{$ENDIF} + btChar: tbtU32(var1^) := tbtU32(var1^) * Ord(tbtchar(var2^)); + {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtU32(var1^) := tbtU32(var1^) * Ord(tbtwidechar(var2^));{$ENDIF} + btVariant: tbtU32(var1^) := tbtU32(var1^) * Variant(var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + btS32: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: tbts32(var1^) := tbts32(var1^) * tbtu8(var2^); + btS8: tbts32(var1^) := tbts32(var1^) * tbts8(var2^); + btU16: tbts32(var1^) := tbts32(var1^) * tbtu16(var2^); + btS16: tbts32(var1^) := tbts32(var1^) * tbts16(var2^); + btU32: tbts32(var1^) := tbts32(var1^) * Longint(tbtu32(var2^)); + btS32: tbts32(var1^) := tbts32(var1^) * tbts32(var2^); + {$IFNDEF PS_NOINT64} btS64: tbts32(var1^) := tbts32(var1^) * tbts64(var2^);{$ENDIF} + btChar: tbts32(var1^) := tbts32(var1^) * Ord(tbtchar(var2^)); + {$IFNDEF PS_NOWIDESTRING} btWideChar: tbts32(var1^) := tbts32(var1^) * Ord(tbtwidechar(var2^));{$ENDIF} + btVariant: tbts32(var1^) := tbts32(var1^) * Variant(var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + {$IFNDEF PS_NOINT64} + btS64: tbts64(var1^) := tbts64(var1^) * PSGetInt64(var2, var2type); + {$ENDIF} + btCurrency: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: tbtcurrency(var1^) := tbtcurrency(var1^) * tbtu8(var2^); + btS8: tbtcurrency(var1^) := tbtcurrency(var1^) * tbts8(var2^); + btU16: tbtcurrency(var1^) := tbtcurrency(var1^) * tbtu16(var2^); + btS16: tbtcurrency(var1^) := tbtcurrency(var1^) * tbts16(var2^); + btU32: tbtcurrency(var1^) := tbtdouble(var1^) * tbtu32(var2^); + btS32: tbtcurrency(var1^) := tbtcurrency(var1^) * tbts32(var2^); + {$IFNDEF PS_NOINT64} btS64: tbtcurrency(var1^) := tbtdouble(var1^) * tbts64(var2^);{$ENDIF} + btSingle: tbtcurrency(var1^) := tbtcurrency(var1^) * tbtsingle(var2^); + btDouble: tbtcurrency(var1^) := tbtcurrency(var1^) * tbtdouble(var2^); + btExtended: tbtcurrency(var1^) := tbtcurrency(var1^) * tbtextended(var2^); + btCurrency: tbtcurrency(var1^) := tbtcurrency(var1^) * tbtcurrency(var2^); + btVariant: tbtcurrency(var1^) := tbtcurrency(var1^) * Variant(var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + btSingle: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: tbtsingle(var1^) := tbtsingle(var1^) *tbtu8(var2^); + btS8: tbtsingle(var1^) := tbtsingle(var1^) *tbts8(var2^); + btU16: tbtsingle(var1^) := tbtsingle(var1^) *tbtu16(var2^); + btS16: tbtsingle(var1^) := tbtsingle(var1^) *tbts16(var2^); + btU32: tbtsingle(var1^) := tbtsingle(var1^) *tbtu32(var2^); + btS32: tbtsingle(var1^) := tbtsingle(var1^) *tbts32(var2^); + {$IFNDEF PS_NOINT64} btS64: tbtsingle(var1^) := tbtsingle(var1^) *tbts64(var2^);{$ENDIF} + btSingle: tbtsingle(var1^) := tbtsingle(var1^) *tbtsingle(var2^); + btDouble: tbtsingle(var1^) := tbtsingle(var1^) *tbtdouble(var2^); + btExtended: tbtsingle(var1^) := tbtsingle(var1^) *tbtextended(var2^); + btCurrency: tbtsingle(var1^) := tbtsingle(var1^) *tbtcurrency(var2^); + btVariant: tbtsingle(var1^) := tbtsingle(var1^) * Variant(var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + btDouble: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: tbtdouble(var1^) := tbtdouble(var1^) *tbtu8(var2^); + btS8: tbtdouble(var1^) := tbtdouble(var1^) *tbts8(var2^); + btU16: tbtdouble(var1^) := tbtdouble(var1^) *tbtu16(var2^); + btS16: tbtdouble(var1^) := tbtdouble(var1^) *tbts16(var2^); + btU32: tbtdouble(var1^) := tbtdouble(var1^) *tbtu32(var2^); + btS32: tbtdouble(var1^) := tbtdouble(var1^) *tbts32(var2^); + {$IFNDEF PS_NOINT64} btS64: tbtdouble(var1^) := tbtdouble(var1^) *tbts64(var2^);{$ENDIF} + btSingle: tbtdouble(var1^) := tbtdouble(var1^) *tbtsingle(var2^); + btDouble: tbtdouble(var1^) := tbtdouble(var1^) *tbtdouble(var2^); + btExtended: tbtdouble(var1^) := tbtdouble(var1^) *tbtextended(var2^); + btCurrency: tbtdouble(var1^) := tbtdouble(var1^) *tbtcurrency(var2^); + btVariant: tbtdouble(var1^) := tbtdouble(var1^) * Variant(var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + btExtended: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: tbtextended(var1^) := tbtextended(var1^) *tbtu8(var2^); + btS8: tbtextended(var1^) := tbtextended(var1^) *tbts8(var2^); + btU16: tbtextended(var1^) := tbtextended(var1^) *tbtu16(var2^); + btS16: tbtextended(var1^) := tbtextended(var1^) *tbts16(var2^); + btU32: tbtextended(var1^) := tbtextended(var1^) *tbtu32(var2^); + btS32: tbtextended(var1^) := tbtextended(var1^) *tbts32(var2^); + {$IFNDEF PS_NOINT64} btS64: tbtextended(var1^) := tbtextended(var1^) *tbts64(var2^);{$ENDIF} + btSingle: tbtextended(var1^) := tbtextended(var1^) *tbtsingle(var2^); + btDouble: tbtextended(var1^) := tbtextended(var1^) *tbtdouble(var2^); + btExtended: tbtextended(var1^) := tbtextended(var1^) *tbtextended(var2^); + btCurrency: tbtextended(var1^) := tbtextended(var1^) *tbtcurrency(var2^); + btVariant: tbtextended(var1^) := tbtextended(var1^) * Variant(var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + btVariant: + begin + if not IntPIFVariantToVariant(var2, var2type, tvar) then + begin + Result := false; + end else + Variant(var1^) := Variant(var1^) * tvar; + end; + btSet: + begin + if var1Type = var2Type then + begin + Set_Intersect(var1, var2, TPSTypeRec_Set(var1Type).aByteSize); + end else result := False; + end; + else begin + CMD_Err(erTypeMismatch); + exit; + end; + end; + if not Result then begin + CMD_Err(erTypeMismatch); + exit; + end; + end; + 3: begin { / } + case var1Type.BaseType of + btU8: tbtU8(var1^) := tbtU8(var1^) div PSGetUInt(Var2, var2type); + btS8: tbts8(var1^) := tbts8(var1^) div PSGetInt(Var2, var2type); + btU16: tbtU16(var1^) := tbtU16(var1^) div PSGetUInt(Var2, var2type); + btS16: tbts16(var1^) := tbts16(var1^) div PSGetInt(Var2, var2type); + btU32: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: tbtU32(var1^) := tbtU32(var1^) div tbtu8(var2^); + btS8: tbtU32(var1^) := tbtU32(var1^) div cardinal(longint(tbts8(var2^))); + btU16: tbtU32(var1^) := tbtU32(var1^) div tbtu16(var2^); + btS16: tbtU32(var1^) := tbtU32(var1^) div cardinal(longint(tbts16(var2^))); + btU32: tbtU32(var1^) := tbtU32(var1^) div tbtu32(var2^); + btS32: tbtU32(var1^) := tbtU32(var1^) div cardinal(tbts32(var2^)); + {$IFNDEF PS_NOINT64} btS64: tbtU32(var1^) := tbtU32(var1^) div tbts64(var2^);{$ENDIF} + btChar: tbtU32(var1^) := tbtU32(var1^) div Ord(tbtchar(var2^)); + {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtU32(var1^) := tbtU32(var1^) div Ord(tbtwidechar(var2^));{$ENDIF} + btVariant: tbtU32(var1^) := tbtU32(var1^) div Variant(var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + btS32: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: tbts32(var1^) := tbts32(var1^) div tbtu8(var2^); + btS8: tbts32(var1^) := tbts32(var1^) div tbts8(var2^); + btU16: tbts32(var1^) := tbts32(var1^) div tbtu16(var2^); + btS16: tbts32(var1^) := tbts32(var1^) div tbts16(var2^); + btU32: tbts32(var1^) := tbts32(var1^) div Longint(tbtu32(var2^)); + btS32: tbts32(var1^) := tbts32(var1^) div tbts32(var2^); + {$IFNDEF PS_NOINT64} btS64: tbts32(var1^) := tbts32(var1^) div tbts64(var2^);{$ENDIF} + btChar: tbts32(var1^) := tbts32(var1^) div Ord(tbtchar(var2^)); + {$IFNDEF PS_NOWIDESTRING} btWideChar: tbts32(var1^) := tbts32(var1^) div Ord(tbtwidechar(var2^));{$ENDIF} + btVariant: tbts32(var1^) := tbts32(var1^) div Variant(var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + {$IFNDEF PS_NOINT64} + btS64: tbts64(var1^) := tbts64(var1^) div PSGetInt64(var2, var2type); + {$ENDIF} + btSingle: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: tbtsingle(var1^) := tbtsingle(var1^) / tbtu8(var2^); + btS8: tbtsingle(var1^) := tbtsingle(var1^) / tbts8(var2^); + btU16: tbtsingle(var1^) := tbtsingle(var1^) / tbtu16(var2^); + btS16: tbtsingle(var1^) := tbtsingle(var1^) / tbts16(var2^); + btU32: tbtsingle(var1^) := tbtsingle(var1^) / tbtu32(var2^); + btS32: tbtsingle(var1^) := tbtsingle(var1^) / tbts32(var2^); + {$IFNDEF PS_NOINT64} btS64: tbtsingle(var1^) := tbtsingle(var1^) / tbts64(var2^);{$ENDIF} + btSingle: tbtsingle(var1^) := tbtsingle(var1^) / tbtsingle(var2^); + btDouble: tbtsingle(var1^) := tbtsingle(var1^) / tbtdouble(var2^); + btExtended: tbtsingle(var1^) := tbtsingle(var1^) / tbtextended(var2^); + btCurrency: tbtsingle(var1^) := tbtsingle(var1^) / tbtcurrency(var2^); + btVariant: tbtsingle(var1^) := tbtsingle(var1^) / Variant(var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + btCurrency: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: tbtcurrency(var1^) := tbtcurrency(var1^) / tbtu8(var2^); + btS8: tbtcurrency(var1^) := tbtcurrency(var1^) / tbts8(var2^); + btU16: tbtcurrency(var1^) := tbtcurrency(var1^) / tbtu16(var2^); + btS16: tbtcurrency(var1^) := tbtcurrency(var1^) / tbts16(var2^); + btU32: tbtcurrency(var1^) := tbtdouble(var1^) / tbtu32(var2^); + btS32: tbtcurrency(var1^) := tbtcurrency(var1^) / tbts32(var2^); + {$IFNDEF PS_NOINT64} btS64: tbtcurrency(var1^) := tbtdouble(var1^) / tbts64(var2^);{$ENDIF} + btSingle: tbtcurrency(var1^) := tbtcurrency(var1^) / tbtsingle(var2^); + btDouble: tbtcurrency(var1^) := tbtcurrency(var1^) / tbtdouble(var2^); + btExtended: tbtcurrency(var1^) := tbtcurrency(var1^) / tbtextended(var2^); + btCurrency: tbtcurrency(var1^) := tbtcurrency(var1^) / tbtcurrency(var2^); + btVariant: tbtcurrency(var1^) := tbtcurrency(var1^) / Variant(var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + btDouble: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: tbtdouble(var1^) := tbtdouble(var1^) / tbtu8(var2^); + btS8: tbtdouble(var1^) := tbtdouble(var1^) / tbts8(var2^); + btU16: tbtdouble(var1^) := tbtdouble(var1^) / tbtu16(var2^); + btS16: tbtdouble(var1^) := tbtdouble(var1^) / tbts16(var2^); + btU32: tbtdouble(var1^) := tbtdouble(var1^) / tbtu32(var2^); + btS32: tbtdouble(var1^) := tbtdouble(var1^) / tbts32(var2^); + {$IFNDEF PS_NOINT64} btS64: tbtdouble(var1^) := tbtdouble(var1^) / tbts64(var2^);{$ENDIF} + btSingle: tbtdouble(var1^) := tbtdouble(var1^) / tbtsingle(var2^); + btDouble: tbtdouble(var1^) := tbtdouble(var1^) / tbtdouble(var2^); + btExtended: tbtdouble(var1^) := tbtdouble(var1^) / tbtextended(var2^); + btCurrency: tbtdouble(var1^) := tbtdouble(var1^) / tbtcurrency(var2^); + btVariant: tbtdouble(var1^) := tbtdouble(var1^) / Variant(var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + btExtended: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: tbtextended(var1^) := tbtextended(var1^) / tbtu8(var2^); + btS8: tbtextended(var1^) := tbtextended(var1^) / tbts8(var2^); + btU16: tbtextended(var1^) := tbtextended(var1^) / tbtu16(var2^); + btS16: tbtextended(var1^) := tbtextended(var1^) / tbts16(var2^); + btU32: tbtextended(var1^) := tbtextended(var1^) / tbtu32(var2^); + btS32: tbtextended(var1^) := tbtextended(var1^) / tbts32(var2^); + {$IFNDEF PS_NOINT64} btS64: tbtextended(var1^) := tbtextended(var1^) / tbts64(var2^);{$ENDIF} + btSingle: tbtextended(var1^) := tbtextended(var1^) / tbtsingle(var2^); + btDouble: tbtextended(var1^) := tbtextended(var1^) / tbtdouble(var2^); + btExtended: tbtextended(var1^) := tbtextended(var1^) / tbtextended(var2^); + btCurrency: tbtextended(var1^) := tbtextended(var1^) / tbtcurrency(var2^); + btVariant: tbtextended(var1^) := tbtextended(var1^) / Variant(var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + btVariant: + begin + if not IntPIFVariantToVariant(var2, var2type, tvar) then + begin + Result := false; + end else + begin + if VarIsFloat(variant(var1^)) then + Variant(var1^) := Variant(var1^) / tvar + else + Variant(var1^) := Variant(var1^) div tvar; + end; + end; + else begin + CMD_Err(erTypeMismatch); + exit; + end; + end; + if not Result then begin + CMD_Err(erTypeMismatch); + exit; + end; + end; + 4: begin { MOD } + case var1Type.BaseType of + btU8: tbtU8(var1^) := tbtU8(var1^) mod PSGetUInt(Var2, var2type); + btS8: tbts8(var1^) := tbts8(var1^) mod PSGetInt(Var2, var2type); + btU16: tbtU16(var1^) := tbtU16(var1^) mod PSGetUInt(Var2, var2type); + btS16: tbts16(var1^) := tbts16(var1^) mod PSGetInt(Var2, var2type); + btU32: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: tbtU32(var1^) := tbtU32(var1^) mod tbtu8(var2^); + btS8: tbtU32(var1^) := tbtU32(var1^) mod cardinal(longint(tbts8(var2^))); + btU16: tbtU32(var1^) := tbtU32(var1^) mod tbtu16(var2^); + btS16: tbtU32(var1^) := tbtU32(var1^) mod cardinal(longint(tbts16(var2^))); + btU32: tbtU32(var1^) := tbtU32(var1^) mod tbtu32(var2^); + btS32: tbtU32(var1^) := tbtU32(var1^) mod cardinal(tbts32(var2^)); + {$IFNDEF PS_NOINT64} btS64: tbtU32(var1^) := tbtU32(var1^) mod tbts64(var2^);{$ENDIF} + btChar: tbtU32(var1^) := tbtU32(var1^) mod Ord(tbtchar(var2^)); + {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtU32(var1^) := tbtU32(var1^) mod Ord(tbtwidechar(var2^));{$ENDIF} + btVariant: tbtU32(var1^) := tbtU32(var1^) mod Variant(var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + btS32: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^); + var2 := Pointer(var2^); + if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case var2type.BaseType of + btU8: tbts32(var1^) := tbts32(var1^) mod tbtu8(var2^); + btS8: tbts32(var1^) := tbts32(var1^) mod tbts8(var2^); + btU16: tbts32(var1^) := tbts32(var1^) mod tbtu16(var2^); + btS16: tbts32(var1^) := tbts32(var1^) mod tbts16(var2^); + btU32: tbts32(var1^) := tbts32(var1^) mod Longint(tbtu32(var2^)); + btS32: tbts32(var1^) := tbts32(var1^) mod tbts32(var2^); + {$IFNDEF PS_NOINT64} btS64: tbts32(var1^) := tbts32(var1^) mod tbts64(var2^);{$ENDIF} + btChar: tbts32(var1^) := tbts32(var1^) mod Ord(tbtchar(var2^)); + {$IFNDEF PS_NOWIDESTRING} btWideChar: tbts32(var1^) := tbts32(var1^) mod Ord(tbtwidechar(var2^));{$ENDIF} + btVariant: tbts32(var1^) := tbts32(var1^) mod Variant(var2^); + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + {$IFNDEF PS_NOINT64} + btS64: tbts64(var1^) := tbts64(var1^) mod PSGetInt64(var2, var2type); + {$ENDIF} + btVariant: + begin + if not IntPIFVariantToVariant(var2, var2type, tvar) then + begin + Result := false; + end else + Variant(var1^) := Variant(var1^) mod tvar; + end; + else begin + CMD_Err(erTypeMismatch); + exit; + end; + end; + if not Result then begin + CMD_Err(erTypeMismatch); + exit; + end; + end; + 5: begin { SHL } + case var1Type.BaseType of + btU8: tbtU8(var1^) := tbtU8(var1^) shl PSGetUInt(Var2, var2type); + btS8: tbts8(var1^) := tbts8(var1^) shl PSGetInt(Var2, var2type); + btU16: tbtU16(var1^) := tbtU16(var1^) shl PSGetUInt(Var2, var2type); + btS16: tbts16(var1^) := tbts16(var1^) shl PSGetInt(Var2, var2type); + btU32: tbtU32(var1^) := tbtU32(var1^) shl PSGetUInt(Var2, var2type); + btS32: tbts32(var1^) := tbts32(var1^) shl PSGetInt(Var2, var2type); + {$IFNDEF PS_NOINT64} + btS64: tbts64(var1^) := tbts64(var1^) shl PSGetInt64(var2, var2type); + {$ENDIF} + btVariant: + begin + if not IntPIFVariantToVariant(var2, var2type, tvar) then + begin + Result := false; + end else + Variant(var1^) := Variant(var1^) shl tvar; + end; + else begin + CMD_Err(erTypeMismatch); + exit; + end; + end; + if not Result then begin + CMD_Err(erTypeMismatch); + exit; + end; + end; + 6: begin { SHR } + case var1Type.BaseType of + btU8: tbtU8(var1^) := tbtU8(var1^) shr PSGetUInt(Var2, var2type); + btS8: tbts8(var1^) := tbts8(var1^) shr PSGetInt(Var2, var2type); + btU16: tbtU16(var1^) := tbtU16(var1^) shr PSGetUInt(Var2, var2type); + btS16: tbts16(var1^) := tbts16(var1^) shr PSGetInt(Var2, var2type); + btU32: tbtU32(var1^) := tbtU32(var1^) shr PSGetUInt(Var2, var2type); + btS32: tbts32(var1^) := tbts32(var1^) shr PSGetInt(Var2, var2type); + {$IFNDEF PS_NOINT64} + btS64: tbts64(var1^) := tbts64(var1^) shr PSGetInt64(var2, var2type); + {$ENDIF} + btVariant: + begin + if not IntPIFVariantToVariant(var2, var2type, tvar) then + begin + Result := false; + end else + Variant(var1^) := Variant(var1^) shr tvar; + end; + else begin + CMD_Err(erTypeMismatch); + exit; + end; + end; + if not Result then begin + CMD_Err(erTypeMismatch); + exit; + end; + end; + 7: begin { AND } + case var1Type.BaseType of + btU8: tbtU8(var1^) := tbtU8(var1^) and PSGetUInt(Var2, var2type); + btS8: tbts8(var1^) := tbts8(var1^) and PSGetInt(Var2, var2type); + btU16: tbtU16(var1^) := tbtU16(var1^) and PSGetUInt(Var2, var2type); + btS16: tbts16(var1^) := tbts16(var1^) and PSGetInt(Var2, var2type); + btU32: tbtU32(var1^) := tbtU32(var1^) and PSGetUInt(Var2, var2type); + btS32: tbts32(var1^) := tbts32(var1^) and PSGetInt(Var2, var2type); + {$IFNDEF PS_NOINT64} + btS64: tbts64(var1^) := tbts64(var1^) and PSGetInt64(var2, var2type); + {$ENDIF} + btVariant: + begin + if not IntPIFVariantToVariant(var2, var2type, tvar) then + begin + Result := false; + end else + Variant(var1^) := Variant(var1^) and tvar; + end; + else begin + CMD_Err(erTypeMismatch); + exit; + end; + end; + if not Result then begin + CMD_Err(erTypeMismatch); + exit; + end; + end; + 8: begin { OR } + case var1Type.BaseType of + btU8: tbtU8(var1^) := tbtU8(var1^) or PSGetUInt(Var2, var2type); + btS8: tbts8(var1^) := tbts8(var1^) or PSGetInt(Var2, var2type); + btU16: tbtU16(var1^) := tbtU16(var1^) or PSGetUInt(Var2, var2type); + btS16: tbts16(var1^) := tbts16(var1^) or PSGetInt(Var2, var2type); + btU32: tbtU32(var1^) := tbtU32(var1^) or PSGetUInt(Var2, var2type); + btS32: tbts32(var1^) := tbts32(var1^) or PSGetInt(Var2, var2type); + {$IFNDEF PS_NOINT64} + btS64: tbts64(var1^) := tbts64(var1^) or PSGetInt64(var2, var2type); + {$ENDIF} + btVariant: + begin + if not IntPIFVariantToVariant(var2, var2type, tvar) then + begin + Result := false; + end else + Variant(var1^) := Variant(var1^) or tvar; + end; + else begin + CMD_Err(erTypeMismatch); + exit; + end; + end; + if not Result then begin + CMD_Err(erTypeMismatch); + exit; + end; + end; + 9: begin { XOR } + case var1Type.BaseType of + btU8: tbtU8(var1^) := tbtU8(var1^) xor PSGetUInt(Var2, var2type); + btS8: tbts8(var1^) := tbts8(var1^) xor PSGetInt(Var2, var2type); + btU16: tbtU16(var1^) := tbtU16(var1^) xor PSGetUInt(Var2, var2type); + btS16: tbts16(var1^) := tbts16(var1^) xor PSGetInt(Var2, var2type); + btU32: tbtU32(var1^) := tbtU32(var1^) xor PSGetUInt(Var2, var2type); + btS32: tbts32(var1^) := tbts32(var1^) xor PSGetInt(Var2, var2type); + {$IFNDEF PS_NOINT64} + btS64: tbts64(var1^) := tbts64(var1^) xor PSGetInt64(var2, var2type); + {$ENDIF} + btVariant: + begin + if not IntPIFVariantToVariant(var2, var2type, tvar) then + begin + Result := false; + end else + Variant(var1^) := Variant(var1^) xor tvar; + end; + else begin + CMD_Err(erTypeMismatch); + exit; + end; + end; + if not Result then begin + CMD_Err(erTypeMismatch); + exit; + end; + end; + 10: + begin // as + case var1Type.BaseType of + btClass: + begin + if var2type.BaseType <> btU32 then + Result := False + else + begin + var2type := FTypes[tbtu32(var2^)]; + if (var2type = nil) or (var2type.BaseType <> btClass) then + Result := false + else + begin + if not Class_IS(Self, TObject(var1^), var2type) then + Result := false + end; + end; + end; + else begin + CMD_Err(erTypeMismatch); + exit; + end; + end; + if not Result then begin + CMD_Err(erTypeMismatch); + exit; + end; + end; + else begin + Result := False; + CMD_Err(erInvalidOpcodeParameter); + exit; + end; + end; + except + {$IFDEF DELPHI6UP} + Tmp := AcquireExceptionObject; + {$ELSE} + if RaiseList <> nil then + begin + Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject); + PRaiseFrame(RaiseList)^.ExceptObject := nil; + end else + Tmp := nil; + {$ENDIF} + if Tmp <> nil then + begin + if Tmp is EPSException then + begin + Result := False; + ExceptionProc(EPSException(tmp).ProcNo, EPSException(tmp).ProcPos, erCustomError, tbtString(EPSException(tmp).Message), nil); + exit; + end else + if Tmp is EDivByZero then + begin + Result := False; + CMD_Err3(erDivideByZero, '', Tmp); + Exit; + end; + if Tmp is EZeroDivide then + begin + Result := False; + CMD_Err3(erDivideByZero, '', Tmp); + Exit; + end; + if Tmp is EMathError then + begin + Result := False; + CMD_Err3(erMathError, '', Tmp); + Exit; + end; + end; + if (tmp <> nil) and (Tmp is Exception) then + CMD_Err3(erException, tbtString(Exception(Tmp).Message), Tmp) + else + CMD_Err3(erException, '', Tmp); + Result := False; + end; +end; + +function TPSExec.ReadVariable(var Dest: TPSResultData; UsePointer: Boolean): Boolean; +var + VarType: Cardinal; + Param: Cardinal; + Tmp: PIfVariant; + at: TPSTypeRec; + +begin + if FCurrentPosition + 4 >= FDataLength then + begin + CMD_Err(erOutOfRange); // Error + Result := False; + exit; + end; + VarType := FData^[FCurrentPosition]; + Inc(FCurrentPosition); + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + Param := unaligned(Cardinal((@FData^[FCurrentPosition])^)); + {$else} + Param := Cardinal((@FData^[FCurrentPosition])^); + {$endif} + Inc(FCurrentPosition, 4); + case VarType of + 0: + begin + Dest.FreeType := vtNone; + if Param < PSAddrNegativeStackStart then + begin + if Param >= Cardinal(FGlobalVars.Count) then + begin + CMD_Err(erOutOfGlobalVarsRange); + Result := False; + exit; + end; + Tmp := FGlobalVars.Data[param]; + end else + begin + Param := Cardinal(Longint(-PSAddrStackStart) + + Longint(FCurrStackBase) + Longint(Param)); + if Param >= Cardinal(FStack.Count) then + begin + CMD_Err(erOutOfGlobalVarsRange); + Result := False; + exit; + end; + Tmp := FStack.Data[param]; + end; + if (UsePointer) and (Tmp.FType.BaseType = btPointer) then + begin + Dest.aType := PPSVariantPointer(Tmp).DestType; + Dest.P := PPSVariantPointer(Tmp).DataDest; + if Dest.P = nil then + begin + Cmd_Err(erNullPointerException); + Result := False; + exit; + end; + end else + begin + Dest.aType := PPSVariantData(Tmp).vi.FType; + Dest.P := @PPSVariantData(Tmp).Data; + end; + end; + 1: begin + if Param >= FTypes.Count then + begin + CMD_Err(erInvalidType); + Result := False; + exit; + end; + at := FTypes.Data^[Param]; + Param := FTempVars.FLength; + FTempVars.FLength := Cardinal(Longint(Param) + Longint(at.RealSize) + Longint(RTTISize + 3)) and not 3; + if FTempVars.FLength > FTempVars.FCapacity then FtempVars.AdjustLength; + Tmp := Pointer(IPointer(FtempVars.FDataPtr) + IPointer(Param)); + + if Cardinal(FTempVars.FCount) >= Cardinal(FTempVars.FCapacity) then + begin + Inc(FTempVars.FCapacity, FCapacityInc);// := FCount + 1; + ReAllocMem(FTempVars.FData, FTempVars.FCapacity shl 2); + end; + FTempVars.FData[FTempVars.FCount] := Tmp; // Instead of SetItem + Inc(FTempVars.FCount); + {$IFNDEF PS_NOSMARTLIST} + Inc(FTempVars.FCheckCount); + if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate; + {$ENDIF} + + + Tmp.FType := at; + Dest.P := @PPSVariantData(Tmp).Data; + Dest.aType := tmp.FType; + dest.FreeType := vtTempVar; + case Dest.aType.BaseType of + btSet: + begin + if not ReadData(Dest.P^, TPSTypeRec_Set(Dest.aType).aByteSize) then + begin + CMD_Err(erOutOfRange); + FTempVars.Pop; + Result := False; + exit; + end; + end; + bts8, btchar, btU8: + begin + if FCurrentPosition >= FDataLength then + begin + CMD_Err(erOutOfRange); + FTempVars.Pop; + Result := False; + exit; + end; + tbtu8(dest.p^) := FData^[FCurrentPosition]; + Inc(FCurrentPosition); + end; + bts16, {$IFNDEF PS_NOWIDESTRING}btwidechar,{$ENDIF} btU16: + begin + if FCurrentPosition + 1>= FDataLength then + begin + CMD_Err(erOutOfRange); + FTempVars.Pop; + Result := False; + exit; + end; + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + tbtu16(dest.p^) := unaligned(tbtu16((@FData^[FCurrentPosition])^)); + {$else} + tbtu16(dest.p^) := tbtu16((@FData^[FCurrentPosition])^); + {$endif} + Inc(FCurrentPosition, 2); + end; + bts32, btU32: + begin + if FCurrentPosition + 3>= FDataLength then + begin + CMD_Err(erOutOfRange); + FTempVars.Pop; + Result := False; + exit; + end; + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + tbtu32(dest.p^) := unaligned(tbtu32((@FData^[FCurrentPosition])^)); + {$else} + tbtu32(dest.p^) := tbtu32((@FData^[FCurrentPosition])^); + {$endif} + Inc(FCurrentPosition, 4); + end; + btProcPtr: + begin + if FCurrentPosition + 3>= FDataLength then + begin + CMD_Err(erOutOfRange); + FTempVars.Pop; + Result := False; + exit; + end; + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + tbtu32(dest.p^) := unaligned(tbtu32((@FData^[FCurrentPosition])^)); + {$else} + tbtu32(dest.p^) := tbtu32((@FData^[FCurrentPosition])^); + {$endif} + tbtu32(Pointer(IPointer(dest.p)+PointerSize)^) := 0; + tbtu32(Pointer(IPointer(dest.p)+PointerSize)^) := 0; + Inc(FCurrentPosition, 4); + end; + {$IFNDEF PS_NOINT64} + bts64: + begin + if FCurrentPosition + 7>= FDataLength then + begin + CMD_Err(erOutOfRange); + FTempVars.Pop; + Result := False; + exit; + end; + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + tbts64(dest.p^) := unaligned(tbts64((@FData^[FCurrentPosition])^)); + {$else} + tbts64(dest.p^) := tbts64((@FData^[FCurrentPosition])^); + {$endif} + Inc(FCurrentPosition, 8); + end; + {$ENDIF} + btSingle: + begin + if FCurrentPosition + (Sizeof(Single)-1)>= FDataLength then + begin + CMD_Err(erOutOfRange); + FTempVars.Pop; + Result := False; + exit; + end; + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + tbtsingle(dest.p^) := unaligned(tbtsingle((@FData^[FCurrentPosition])^)); + {$else} + tbtsingle(dest.p^) := tbtsingle((@FData^[FCurrentPosition])^); + {$endif} + Inc(FCurrentPosition, Sizeof(Single)); + end; + btDouble: + begin + if FCurrentPosition + (Sizeof(Double)-1)>= FDataLength then + begin + CMD_Err(erOutOfRange); + FTempVars.Pop; + Result := False; + exit; + end; + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + tbtdouble(dest.p^) := unaligned(tbtdouble((@FData^[FCurrentPosition])^)); + {$else} + tbtdouble(dest.p^) := tbtdouble((@FData^[FCurrentPosition])^); + {$endif} + Inc(FCurrentPosition, Sizeof(double)); + end; + + btExtended: + begin + if FCurrentPosition + (sizeof(Extended)-1)>= FDataLength then + begin + CMD_Err(erOutOfRange); + FTempVars.Pop; + Result := False; + exit; + end; + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + tbtextended(dest.p^) := unaligned(tbtextended((@FData^[FCurrentPosition])^)); + {$else} + tbtextended(dest.p^) := tbtextended((@FData^[FCurrentPosition])^); + {$endif} + Inc(FCurrentPosition, sizeof(Extended)); + end; + btPchar, btString: + begin + if FCurrentPosition + 3 >= FDataLength then + begin + Cmd_Err(erOutOfRange); + FTempVars.Pop; + Result := False; + exit; + end; + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + Param := unaligned(Cardinal((@FData^[FCurrentPosition])^)); + {$else} + Param := Cardinal((@FData^[FCurrentPosition])^); + {$endif} + Inc(FCurrentPosition, 4); + Pointer(Dest.P^) := nil; + SetLength(tbtstring(Dest.P^), Param); + if not ReadData(tbtstring(Dest.P^)[1], Param) then + begin + CMD_Err(erOutOfRange); + FTempVars.Pop; + Result := False; + exit; + end; + end; + {$IFNDEF PS_NOWIDESTRING} + btWidestring: + begin + if FCurrentPosition + 3 >= FDataLength then + begin + Cmd_Err(erOutOfRange); + FTempVars.Pop; + Result := False; + exit; + end; + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + Param := unaligned(Cardinal((@FData^[FCurrentPosition])^)); + {$else} + Param := Cardinal((@FData^[FCurrentPosition])^); + {$endif} + Inc(FCurrentPosition, 4); + Pointer(Dest.P^) := nil; + SetLength(tbtwidestring(Dest.P^), Param); + if not ReadData(tbtwidestring(Dest.P^)[1], Param*2) then + begin + CMD_Err(erOutOfRange); + FTempVars.Pop; + Result := False; + exit; + end; + end; + btUnicodeString: + begin + if FCurrentPosition + 3 >= FDataLength then + begin + Cmd_Err(erOutOfRange); + FTempVars.Pop; + Result := False; + exit; + end; + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + Param := unaligned(Cardinal((@FData^[FCurrentPosition])^)); + {$else} + Param := Cardinal((@FData^[FCurrentPosition])^); + {$endif} + Inc(FCurrentPosition, 4); + Pointer(Dest.P^) := nil; + SetLength(tbtUnicodestring(Dest.P^), Param); + if not ReadData(tbtUnicodestring(Dest.P^)[1], Param*2) then + begin + CMD_Err(erOutOfRange); + FTempVars.Pop; + Result := False; + exit; + end; + end; + {$ENDIF} + else begin + CMD_Err(erInvalidType); + FTempVars.Pop; + Result := False; + exit; + end; + end; + end; + 2: + begin + Dest.FreeType := vtNone; + if Param < PSAddrNegativeStackStart then begin + if Param >= Cardinal(FGlobalVars.Count) then + begin + CMD_Err(erOutOfGlobalVarsRange); + Result := False; + exit; + end; + Tmp := FGlobalVars.Data[param]; + end + else begin + Param := Cardinal(Longint(-PSAddrStackStart) + Longint(FCurrStackBase) + Longint(Param)); + if Param >= Cardinal(FStack.Count) then + begin + CMD_Err(erOutOfStackRange); + Result := False; + exit; + end; + Tmp := FStack.Data[param]; + end; + if Tmp.FType.BaseType = btPointer then + begin + Dest.aType := PPSVariantPointer(Tmp).DestType; + Dest.P := PPSVariantPointer(Tmp).DataDest; + if Dest.P = nil then + begin + Cmd_Err(erNullPointerException); + Result := False; + exit; + end; + end else + begin + Dest.aType := PPSVariantData(Tmp).vi.FType; + Dest.P := @PPSVariantData(Tmp).Data; + end; + if FCurrentPosition + 3 >= FDataLength then + begin + CMD_Err(erOutOfRange); + Result := False; + exit; + end; + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + Param := unaligned(Cardinal((@FData^[FCurrentPosition])^)); + {$else} + Param := Cardinal((@FData^[FCurrentPosition])^); + {$endif} + Inc(FCurrentPosition, 4); + case Dest.aType.BaseType of + btRecord: + begin + if Param > Cardinal(TPSTypeRec_Record(Dest.aType).FFieldTypes.Count) then + begin + CMD_Err(erOutOfRange); + Result := False; + exit; + end; + Dest.P := Pointer(IPointer(Dest.P) + IPointer(TPSTypeRec_Record(Dest.aType).RealFieldOffsets[Param])); + Dest.aType := TPSTypeRec_Record(Dest.aType).FieldTypes[Param]; + end; + btArray: + begin + if Param >= Cardinal(PSDynArrayGetLength(Pointer(Dest.P^), dest.aType)) then + begin + CMD_Err(erOutOfRange); + Result := False; + exit; + end; + Dest.P := Pointer(IPointer(Dest.P^) + (Param * TPSTypeRec_Array(Dest.aType).FArrayType.RealSize)); + Dest.aType := TPSTypeRec_Array(dest.aType).ArrayType; + end; + btStaticArray: + begin + if Param >= Cardinal(TPSTypeRec_StaticArray(Dest.aType).Size) then + begin + CMD_Err(erOutOfRange); + Result := False; + exit; + end; + Dest.P := Pointer(IPointer(Dest.P) + (Param * TPSTypeRec_Array(Dest.aType).FArrayType.RealSize)); + Dest.aType := TPSTypeRec_Array(dest.aType).ArrayType; + end; + else + CMD_Err(erInvalidType); + Result := False; + exit; + end; + + if UsePointer and (Dest.aType.BaseType = btPointer) then + begin + Dest.aType := TPSTypeRec(Pointer(IPointer(Dest.p)+PointerSize)^); + Dest.P := Pointer(Dest.p^); + if Dest.P = nil then + begin + Cmd_Err(erNullPointerException); + Result := False; + exit; + end; + end; + end; + 3: + begin + Dest.FreeType := vtNone; + if Param < PSAddrNegativeStackStart then begin + if Param >= Cardinal(FGlobalVars.Count) then + begin + CMD_Err(erOutOfGlobalVarsRange); + Result := False; + exit; + end; + Tmp := FGlobalVars.Data[param]; + end + else begin + Param := Cardinal(Longint(-PSAddrStackStart) + Longint(FCurrStackBase) + Longint(Param)); + if Param >= Cardinal(FStack.Count) then + begin + CMD_Err(erOutOfStackRange); + Result := False; + exit; + end; + Tmp := FStack.Data[param]; + end; + if (Tmp.FType.BaseType = btPointer) then + begin + Dest.aType := PPSVariantPointer(Tmp).DestType; + Dest.P := PPSVariantPointer(Tmp).DataDest; + if Dest.P = nil then + begin + Cmd_Err(erNullPointerException); + Result := False; + exit; + end; + end else + begin + Dest.aType := PPSVariantData(Tmp).vi.FType; + Dest.P := @PPSVariantData(Tmp).Data; + end; + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + Param := unaligned(Cardinal((@FData^[FCurrentPosition])^)); + {$else} + Param := Cardinal((@FData^[FCurrentPosition])^); + {$endif} + Inc(FCurrentPosition, 4); + if Param < PSAddrNegativeStackStart then + begin + if Param >= Cardinal(FGlobalVars.Count) then + begin + CMD_Err(erOutOfGlobalVarsRange); + Result := false; + exit; + end; + Tmp := FGlobalVars[Param]; + end + else begin + Param := Cardinal(Longint(-PSAddrStackStart) + Longint(FCurrStackBase) + Longint(Param)); + if Cardinal(Param) >= Cardinal(FStack.Count) then + begin + CMD_Err(erOutOfStackRange); + Result := false; + exit; + end; + Tmp := FStack[Param]; + end; + case Tmp.FType.BaseType of + btu8: Param := PPSVariantU8(Tmp).Data; + bts8: Param := PPSVariants8(Tmp).Data; + btu16: Param := PPSVariantU16(Tmp).Data; + bts16: Param := PPSVariants16(Tmp).Data; + btu32: Param := PPSVariantU32(Tmp).Data; + bts32: Param := PPSVariants32(Tmp).Data; + btPointer: + begin + if PPSVariantPointer(tmp).DestType <> nil then + begin + case PPSVariantPointer(tmp).DestType.BaseType of + btu8: Param := tbtu8(PPSVariantPointer(tmp).DataDest^); + bts8: Param := tbts8(PPSVariantPointer(tmp).DataDest^); + btu16: Param := tbtu16(PPSVariantPointer(tmp).DataDest^); + bts16: Param := tbts16(PPSVariantPointer(tmp).DataDest^); + btu32, btProcPtr: Param := tbtu32(PPSVariantPointer(tmp).DataDest^); + bts32: Param := tbts32(PPSVariantPointer(tmp).DataDest^); + else + begin + CMD_Err(ErTypeMismatch); + Result := false; + exit; + end; + end; + end else + begin + CMD_Err(ErTypeMismatch); + Result := false; + exit; + end; + end; + else + CMD_Err(ErTypeMismatch); + Result := false; + exit; + end; + case Dest.aType.BaseType of + btRecord: + begin + if Param > Cardinal(TPSTypeRec_Record(Dest.aType).FFieldTypes.Count) then + begin + CMD_Err(erOutOfRange); + Result := False; + exit; + end; + Dest.P := Pointer(IPointer(Dest.P) + IPointer(TPSTypeRec_Record(Dest.aType).RealFieldOffsets[Param])); + Dest.aType := TPSTypeRec_Record(Dest.aType).FieldTypes[Param]; + end; + btArray: + begin + if Cardinal(Param) >= Cardinal(PSDynArrayGetLength(Pointer(Dest.P^), dest.aType)) then + begin + CMD_Err(erOutOfRange); + Result := False; + exit; + end; + Dest.P := Pointer(IPointer(Dest.P^) + (Param * TPSTypeRec_Array(Dest.aType).FArrayType.RealSize)); + Dest.aType := TPSTypeRec_Array(dest.aType).ArrayType; + end; + btStaticArray: + begin + if Param >= Cardinal(TPSTypeRec_StaticArray(Dest.aType).Size) then + begin + CMD_Err(erOutOfRange); + Result := False; + exit; + end; + Dest.P := Pointer(IPointer(Dest.P) + (Param * TPSTypeRec_Array(Dest.aType).FArrayType.RealSize)); + Dest.aType := TPSTypeRec_Array(dest.aType).ArrayType; + end; + else + CMD_Err(erInvalidType); + Result := False; + exit; + end; + if UsePointer and (Dest.aType.BaseType = btPointer) then + begin + Dest.aType := TPSTypeRec(Pointer(IPointer(Dest.p)+PointerSize)^); + Dest.P := Pointer(Dest.p^); + if Dest.P = nil then + begin + Cmd_Err(erNullPointerException); + Result := False; + exit; + end; + end; + end; + else + begin + Result := False; + exit; + end; + end; + Result := true; +end; + +function TPSExec.DoMinus(Dta: Pointer; aType: TPSTypeRec): Boolean; +begin + case atype.BaseType of + btU8: tbtu8(dta^) := -tbtu8(dta^); + btU16: tbtu16(dta^) := -tbtu16(dta^); + btU32: tbtu32(dta^) := -tbtu32(dta^); + btS8: tbts8(dta^) := -tbts8(dta^); + btS16: tbts16(dta^) := -tbts16(dta^); + btS32: tbts32(dta^) := -tbts32(dta^); + {$IFNDEF PS_NOINT64} + bts64: tbts64(dta^) := -tbts64(dta^); + {$ENDIF} + btSingle: tbtsingle(dta^) := -tbtsingle(dta^); + btDouble: tbtdouble(dta^) := -tbtdouble(dta^); + btExtended: tbtextended(dta^) := -tbtextended(dta^); + btCurrency: tbtcurrency(dta^) := -tbtcurrency(dta^); + btVariant: + begin + try + Variant(dta^) := - Variant(dta^); + except + CMD_Err(erTypeMismatch); + Result := False; + exit; + end; + end; + else + begin + CMD_Err(erTypeMismatch); + Result := False; + exit; + end; + end; + Result := True; +end; + +function TPSExec.DoBooleanNot(Dta: Pointer; aType: TPSTypeRec): Boolean; +begin + case aType.BaseType of + btU8: tbtu8(dta^) := tbtu8(tbtu8(dta^) = 0); + btU16: tbtu16(dta^) := tbtu16(tbtu16(dta^) = 0); + btU32: tbtu32(dta^) := tbtu32(tbtu32(dta^) = 0); + btS8: tbts8(dta^) := tbts8(tbts8(dta^) = 0); + btS16: tbts16(dta^) := tbts16(tbts16(dta^) = 0); + btS32: tbts32(dta^) := tbts32(tbts32(dta^) = 0); + {$IFNDEF PS_NOINT64} + bts64: tbts64(dta^) := tbts64(tbts64(dta^) = 0); + {$ENDIF} + btVariant: + begin + try + Variant(dta^) := Variant(dta^) = 0; + except + CMD_Err(erTypeMismatch); + Result := False; + exit; + end; + end; + else + begin + CMD_Err(erTypeMismatch); + Result := False; + exit; + end; + end; + Result := True; +end; + + +procedure TPSExec.Stop; +begin + if FStatus = isRunning then + FStatus := isLoaded + else if FStatus = isPaused then begin + FStatus := isLoaded; + FStack.Clear; + FTempVars.Clear; + end; +end; + + +function TPSExec.ReadLong(var b: Cardinal): Boolean; +begin + if FCurrentPosition + 3 < FDataLength then begin + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + b := unaligned(Cardinal((@FData^[FCurrentPosition])^)); + {$else} + b := Cardinal((@FData^[FCurrentPosition])^); + {$endif} + Inc(FCurrentPosition, 4); + Result := True; + end + else + Result := False; +end; + +function TPSExec.RunProcP(const Params: array of Variant; const Procno: Cardinal): Variant; +var + ParamList: TPSList; + ct: PIFTypeRec; + pvar: PPSVariant; + res, s: tbtString; + Proc: TPSInternalProcRec; + i: Longint; +begin + if ProcNo >= FProcs.Count then raise Exception.Create(RPS_UnknownProcedure); + Proc := GetProcNo(ProcNo) as TPSInternalProcRec; + ParamList := TPSList.Create; + try + s := Proc.ExportDecl; + res := grfw(s); + i := High(Params); + while s <> '' do + begin + if i < 0 then raise Exception.Create(RPS_NotEnoughParameters); + ct := FTypes[StrToInt(copy(GRLW(s), 2, MaxInt))]; + if ct = nil then raise Exception.Create(RPS_InvalidParameter); + pvar := CreateHeapVariant(ct); + ParamList.Add(pvar); + + if not VariantToPIFVariant(Self, Params[i], pvar) then raise Exception.Create(RPS_InvalidParameter); + + Dec(i); + end; + if I > -1 then raise Exception.Create(RPS_TooManyParameters); + if res <> '-1' then + begin + pvar := CreateHeapVariant(FTypes[StrToInt(res)]); + ParamList.Add(pvar); + end else + pvar := nil; + + RunProc(ParamList, ProcNo); + + RaiseCurrentException; + + if pvar <> nil then + begin + PIFVariantToVariant(PVar, Result); + end else + Result := Null; + finally + FreePIFVariantList(ParamList); + end; +end; +function TPSExec.RunProcPVar(var Params: array of Variant; const Procno: Cardinal): Variant; +var + ParamList: TPSList; + ct: PIFTypeRec; + pvar: PPSVariant; + res, s: tbtString; + Proc: TPSInternalProcRec; + i: Longint; +begin + if ProcNo >= FProcs.Count then raise Exception.Create(RPS_UnknownProcedure); + Proc := GetProcNo(ProcNo) as TPSInternalProcRec; + ParamList := TPSList.Create; + try + s := Proc.ExportDecl; + res := grfw(s); + i := High(Params); + while s <> '' do + begin + if i < 0 then raise Exception.Create(RPS_NotEnoughParameters); + ct := FTypes[StrToInt(copy(GRLW(s), 2, MaxInt))]; + if ct = nil then raise Exception.Create(RPS_InvalidParameter); + pvar := CreateHeapVariant(ct); + ParamList.Add(pvar); + + if not VariantToPIFVariant(Self, Params[i], pvar) then raise Exception.Create(RPS_InvalidParameter); + + Dec(i); + end; + if I > -1 then raise Exception.Create(RPS_TooManyParameters); + if res <> '-1' then + begin + pvar := CreateHeapVariant(FTypes[StrToInt(res)]); + ParamList.Add(pvar); + end else + pvar := nil; + + RunProc(ParamList, ProcNo); + + RaiseCurrentException; + + for i := 0 to Length(Params) - 1 do + PIFVariantToVariant(ParamList[i], + Params[(Length(Params) - 1) - i]); + + if pvar <> nil then + begin + PIFVariantToVariant(PVar, Result); + end else + Result := Null; + finally + FreePIFVariantList(ParamList); + end; +end; + +function TPSExec.RunProcPN(const Params: array of Variant; const ProcName: tbtString): Variant; +var + ProcNo: Cardinal; +begin + ProcNo := GetProc(ProcName); + if ProcNo = InvalidVal then + raise Exception.Create(RPS_UnknownProcedure); + Result := RunProcP(Params, ProcNo); +end; + + +function TPSExec.RunProc(Params: TPSList; ProcNo: Cardinal): Boolean; +var + I, I2: Integer; + vnew, Vd: PIfVariant; + Cp: TPSInternalProcRec; + oldStatus: TPSStatus; + tmp: TObject; +begin + if FStatus <> isNotLoaded then begin + if ProcNo >= FProcs.Count then begin + CMD_Err(erOutOfProcRange); + Result := False; + exit; + end; + if Params <> nil then + begin + for I := 0 to Params.Count - 1 do + begin + vd := Params[I]; + if vd = nil then + begin + Result := False; + exit; + end; + vnew := FStack.PushType(FindType2(btPointer)); + if vd.FType.BaseType = btPointer then + begin + PPSVariantPointer(vnew).DestType := PPSVariantPointer(vd).DestType; + PPSVariantPointer(vnew).DataDest := PPSVariantPointer(vd).DataDest; + end else begin + PPSVariantPointer(vnew).DestType := vd.FType; + PPSVariantPointer(vnew).DataDest := @PPSVariantData(vd).Data; + end; + end; + end; + I := FStack.Count; + Cp := FCurrProc; + oldStatus := FStatus; + if TPSProcRec(FProcs.Data^[ProcNo]).ClassType <> TPSExternalProcRec then + begin + vd := FStack.PushType(FReturnAddressType); + PPSVariantReturnAddress(vd).Addr.ProcNo := nil; + PPSVariantReturnAddress(vd).Addr.Position := FCurrentPosition; + PPSVariantReturnAddress(vd).Addr.StackBase := FCurrStackBase; + FCurrStackBase := FStack.Count - 1; + FCurrProc := FProcs.Data^[ProcNo]; + FData := FCurrProc.Data; + FDataLength := FCurrProc.Length; + FCurrentPosition := 0; + FStatus := isPaused; + Result := RunScript; + end else + begin + try + Result := TPSExternalProcRec(FProcs.Data^[ProcNo]).ProcPtr(Self, TPSExternalProcRec(FProcs.Data^[ProcNo]), FGlobalVars, FStack); + if not Result then + begin + if ExEx = erNoError then + CMD_Err(erCouldNotCallProc); + end; + except + {$IFDEF DELPHI6UP} + Tmp := AcquireExceptionObject; + {$ELSE} + if RaiseList <> nil then + begin + Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject); + PRaiseFrame(RaiseList)^.ExceptObject := nil; + end else + Tmp := nil; + {$ENDIF} + if Tmp <> nil then + begin + if Tmp is EPSException then + begin + Result := False; + ExceptionProc(EPSException(tmp).ProcNo, EPSException(tmp).ProcPos, erCustomError, tbtString(EPSException(tmp).Message), nil); + exit; + end else + if Tmp is EDivByZero then + begin + Result := False; + CMD_Err3(erDivideByZero, '', Tmp); + Exit; + end; + if Tmp is EZeroDivide then + begin + Result := False; + CMD_Err3(erDivideByZero, '', Tmp); + Exit; + end; + if Tmp is EMathError then + begin + Result := False; + CMD_Err3(erMathError, '', Tmp); + Exit; + end; + end; + if (Tmp <> nil) and (Tmp is Exception) then + CMD_Err3(erException, tbtString(Exception(Tmp).Message), Tmp) else + CMD_Err3(erException, '', Tmp); + Result := false; + exit; + end; + end; + if Cardinal(FStack.Count) > Cardinal(I) then + begin + vd := FStack[I]; + if (vd <> nil) and (vd.FType = FReturnAddressType) then + begin + for i2 := FStack.Count - 1 downto I + 1 do + FStack.Pop; + FCurrentPosition := PPSVariantReturnAddress(vd).Addr.Position; + FCurrStackBase := PPSVariantReturnAddress(vd).Addr.StackBase; + FStack.Pop; + end; + end; + if Params <> nil then + begin + for I := Params.Count - 1 downto 0 do + begin + if FStack.Count = 0 then + Break + else + FStack.Pop; + end; + end; + FStatus := oldStatus; + FCurrProc := Cp; + if FCurrProc <> nil then + begin + FData := FCurrProc.Data; + FDataLength := FCurrProc.Length; + end; + end else begin + Result := False; + end; +end; + + +function TPSExec.FindType2(BaseType: TPSBaseType): PIFTypeRec; +var + l: Cardinal; +begin + FindType2 := FindType(0, BaseType, l); + +end; + +function TPSExec.FindType(StartAt: Cardinal; BaseType: TPSBaseType; var l: Cardinal): PIFTypeRec; +var + I: Integer; + n: PIFTypeRec; +begin + for I := StartAt to FTypes.Count - 1 do begin + n := FTypes[I]; + if n.BaseType = BaseType then begin + l := I; + Result := n; + exit; + end; + end; + Result := nil; +end; + +function TPSExec.GetTypeNo(l: Cardinal): PIFTypeRec; +begin + Result := FTypes[l]; +end; + +function TPSExec.GetProc(const Name: tbtString): Cardinal; +var + MM, + I: Longint; + n: PIFProcRec; + s: tbtString; +begin + s := FastUpperCase(name); + MM := MakeHash(s); + for I := FProcs.Count - 1 downto 0 do begin + n := FProcs.Data^[I]; + if (n.ClassType = TPSInternalProcRec) and (TPSInternalProcRec(n).ExportNameHash = MM) and (TPSInternalProcRec(n).ExportName = s) then begin + Result := I; + exit; + end else if (n.ClassType = TPSExternalProcRec) and (TPSExternalProcRec(n).Name = s) then + begin + Result := I; + exit; + end; + end; + Result := InvalidVal; +end; + +function TPSExec.GetType(const Name: tbtString): Cardinal; +var + MM, + I: Longint; + n: PIFTypeRec; + s: tbtString; +begin + s := FastUpperCase(name); + MM := MakeHash(s); + for I := 0 to FTypes.Count - 1 do begin + n := FTypes.Data^[I]; + if (Length(n.ExportName) <> 0) and (n.ExportNameHash = MM) and (n.ExportName = s) then begin + Result := I; + exit; + end; + end; + Result := InvalidVal; +end; + + +procedure TPSExec.AddResource(Proc, P: Pointer); +var + Temp: PPSResource; +begin + New(Temp); + Temp^.Proc := Proc; + Temp^.P := p; + FResources.Add(temp); +end; + +procedure TPSExec.DeleteResource(P: Pointer); +var + i: Longint; +begin + for i := Longint(FResources.Count) -1 downto 0 do + begin + if PPSResource(FResources[I])^.P = P then + begin + FResources.Delete(I); + exit; + end; + end; +end; + +function TPSExec.FindProcResource(Proc: Pointer): Pointer; +var + I: Longint; + temp: PPSResource; +begin + for i := Longint(FResources.Count) -1 downto 0 do + begin + temp := FResources[I]; + if temp^.Proc = proc then + begin + Result := Temp^.P; + exit; + end; + end; + Result := nil; +end; + +function TPSExec.IsValidResource(Proc, P: Pointer): Boolean; +var + i: Longint; + temp: PPSResource; +begin + for i := 0 to Longint(FResources.Count) -1 do + begin + temp := FResources[i]; + if temp^.p = p then begin + result := temp^.Proc = Proc; + exit; + end; + end; + result := false; +end; + +function TPSExec.FindProcResource2(Proc: Pointer; + var StartAt: Longint): Pointer; +var + I: Longint; + temp: PPSResource; +begin + if StartAt > longint(FResources.Count) -1 then + StartAt := longint(FResources.Count) -1; + for i := StartAt downto 0 do + begin + temp := FResources[I]; + if temp^.Proc = proc then + begin + Result := Temp^.P; + StartAt := i -1; + exit; + end; + end; + StartAt := -1; + Result := nil; +end; + +procedure TPSExec.RunLine; +begin + if @FOnRunLine <> nil then + FOnRunLine(Self); +end; + +procedure TPSExec.CMD_Err3(EC: TPSError; const Param: tbtString; ExObject: TObject); +var + l: Longint; + C: Cardinal; +begin + C := InvalidVal; + for l := FProcs.Count - 1 downto 0 do begin + if FProcs.Data^[l] = FCurrProc then begin + C := l; + break; + end; + end; + if @FOnException <> nil then + FOnException(Self, Ec, Param, ExObject, C, FCurrentPosition); + ExceptionProc(C, FCurrentPosition, EC, Param, ExObject); +end; + +procedure TPSExec.AddSpecialProcImport(const FName: tbtString; + P: TPSOnSpecialProcImport; Tag: Pointer); +var + N: PSpecialProc; +begin + New(n); + n^.P := P; + N^.Name := FName; + n^.namehash := MakeHash(N^.Name); + n^.Tag := Tag; + FSpecialProcList.Add(n); +end; + +function TPSExec.GetVar(const Name: tbtString): Cardinal; +var + l: Longint; + h: longint; + s: tbtString; + p: PPSExportedVar; +begin + s := FastUpperCase(name); + h := MakeHash(s); + for l := FExportedVars.Count - 1 downto 0 do + begin + p := FexportedVars.Data^[L]; + if (p^.FNameHash = h) and(p^.FName=s) then + begin + Result := L; + exit; + end; + end; + Result := InvalidVal; +end; + +function TPSExec.GetVarNo(C: Cardinal): PIFVariant; +begin + Result := FGlobalVars[c]; +end; + +function TPSExec.GetVar2(const Name: tbtString): PIFVariant; +begin + Result := GetVarNo(GetVar(Name)); +end; + +function TPSExec.GetProcNo(C: Cardinal): PIFProcRec; +begin + Result := FProcs[c]; +end; + +function TPSExec.DoIntegerNot(Dta: Pointer; aType: TPSTypeRec): Boolean; +begin + case aType.BaseType of + btU8: tbtu8(dta^) := not tbtu8(dta^); + btU16: tbtu16(dta^) := not tbtu16(dta^); + btU32: tbtu32(dta^) := not tbtu32(dta^); + btS8: tbts8(dta^) := not tbts8(dta^); + btS16: tbts16(dta^) := not tbts16(dta^); + btS32: tbts32(dta^) := not tbts32(dta^); + {$IFNDEF PS_NOINT64} + bts64: tbts64(dta^) := not tbts64(dta^); + {$ENDIF} + btVariant: + begin + try + Variant(dta^) := not Variant(dta^); + except + CMD_Err(erTypeMismatch); + Result := False; + exit; + end; + end; + else + begin + CMD_Err(erTypeMismatch); + Result := False; + exit; + end; + end; + Result := True; +end; + +type + TMyRunLine = procedure(Self: TPSExec); + TPSRunLine = procedure of object; + +function GetRunLine(FOnRunLine: TPSOnLineEvent; meth: TPSRunLine): TMyRunLine; +begin + if (TMethod(Meth).Code = @TPSExec.RunLine) and (@FOnRunLine = nil) then + Result := nil + else + Result := TMethod(Meth).Code; +end; + +function TPSExec.RunScript: Boolean; +var + CalcType: Cardinal; + vd, vs, v3: TPSResultData; + vtemp: PIFVariant; + p: Cardinal; + P2: Longint; + u: PIFProcRec; + Cmd: Cardinal; + I: Longint; + pp: TPSExceptionHandler; + FExitPoint: Cardinal; + FOldStatus: TPSStatus; + Tmp: TObject; + btemp: Boolean; + CallRunline: TMyRunLine; +begin + FExitPoint := InvalidVal; + if FStatus = isLoaded then + begin + for i := FExceptionStack.Count -1 downto 0 do + begin + pp := FExceptionStack.Data[i]; + pp.Free; + end; + FExceptionStack.Clear; + end; + ExceptionProc(InvalidVal, InvalidVal, erNoError, '', nil); + RunScript := True; + FOldStatus := FStatus; + case FStatus of + isLoaded: begin + if FMainProc = InvalidVal then + begin + RunScript := False; + exit; + end; + FStatus := isRunning; + FCurrProc := FProcs.Data^[FMainProc]; + if FCurrProc.ClassType = TPSExternalProcRec then begin + CMD_Err(erNoMainProc); + FStatus := isLoaded; + exit; + end; + FData := FCurrProc.Data; + FDataLength := FCurrProc.Length; + FCurrStackBase := InvalidVal; + FCurrentPosition := 0; + end; + isPaused: begin + FStatus := isRunning; + end; + else begin + RunScript := False; + exit; + end; + end; + CallRunLine := GetRunLine(FOnRunLine, Self.RunLine); + repeat + FStatus := isRunning; +// Cmd := InvalidVal; + while FStatus = isRunning do + begin + if @CallRunLine <> nil then CallRunLine(Self); + if FCurrentPosition >= FDataLength then + begin + CMD_Err(erOutOfRange); // Error + break; + end; +// if cmd <> invalidval then ProfilerExitProc(Cmd+1); + cmd := FData^[FCurrentPosition]; +// ProfilerEnterProc(Cmd+1); + Inc(FCurrentPosition); + case Cmd of + CM_A: + begin + if not ReadVariable(vd, True) then + break; + if vd.FreeType <> vtNone then + begin + if vd.aType.BaseType in NeedFinalization then + FinalizeVariant(vd.P, vd.aType); + p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr); + Dec(FTempVars.FCount); + {$IFNDEF PS_NOSMARTLIST} + Inc(FTempVars.FCheckCount); + if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate; + {$ENDIF} + FTempVars.FLength := P; + if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength; + + CMD_Err(erInvalidOpcodeParameter); + break; + end; + if not ReadVariable(vs, True) then + Break; + // nx change end +{ if (vd.aType.BaseType = btClass) and (vs.aType.BaseType in [btS32]) then + DWord(vd.P^):=Dword(vs.P^) + else + if (vd.aType.BaseType in [btS32]) and (vs.aType.BaseType = btClass) then + DWord(vd.P^):=Dword(vs.P^) + else} + // nx change start + if not SetVariantValue(vd.P, vs.P, vd.aType, vs.aType) then + begin + if vs.FreeType <> vtNone then + begin + if vs.aType.BaseType in NeedFinalization then + FinalizeVariant(vs.P, vs.aType); + p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr); + Dec(FTempVars.FCount); + {$IFNDEF PS_NOSMARTLIST} + Inc(FTempVars.FCheckCount); + if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate; + {$ENDIF} + FTempVars.FLength := P; + if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength; + end; + Break; + end; + if vs.FreeType <> vtNone then + begin + if vs.aType.BaseType in NeedFinalization then + FinalizeVariant(vs.P, vs.aType); + p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr); + Dec(FTempVars.FCount); + {$IFNDEF PS_NOSMARTLIST} + Inc(FTempVars.FCheckCount); + if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate; + {$ENDIF} + FTempVars.FLength := P; + if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength; + end; + end; + CM_CA: + begin + if FCurrentPosition >= FDataLength then + begin + CMD_Err(erOutOfRange); // Error + break; + end; + calctype := FData^[FCurrentPosition]; + Inc(FCurrentPosition); + if not ReadVariable(vd, True) then + break; + if vd.FreeType <> vtNone then + begin + if vd.aType.BaseType in NeedFinalization then + FinalizeVariant(vd.P, vd.aType); + p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr); + Dec(FTempVars.FCount); + {$IFNDEF PS_NOSMARTLIST} + Inc(FTempVars.FCheckCount); + if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate; + {$ENDIF} + FTempVars.FLength := P; + if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength; + CMD_Err(erInvalidOpcodeParameter); + break; + end; + if not ReadVariable(vs, True) then + Break; + if not DoCalc(vd.P, vs.p, vd.aType, vs.aType, CalcType) then + begin + if vs.FreeType <> vtNone then + begin + if vs.aType.BaseType in NeedFinalization then + FinalizeVariant(vs.P, vs.aType); + p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr); + Dec(FTempVars.FCount); + {$IFNDEF PS_NOSMARTLIST} + Inc(FTempVars.FCheckCount); + if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate; + {$ENDIF} + FTempVars.FLength := P; + if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength; + end; + Break; + end; + if vs.FreeType <> vtNone then + begin + if vs.aType.BaseType in NeedFinalization then + FinalizeVariant(vs.P, vs.aType); + p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr); + Dec(FTempVars.FCount); + {$IFNDEF PS_NOSMARTLIST} + Inc(FTempVars.FCheckCount); + if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate; + {$ENDIF} + FTempVars.FLength := P; + if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength; + end; + end; + CM_P: + begin + if not ReadVariable(vs, True) then + Break; + vtemp := FStack.PushType(vs.aType); + vd.P := Pointer(IPointer(vtemp)+PointerSize); + vd.aType := Pointer(vtemp^); + vd.FreeType := vtNone; + if not SetVariantValue(Vd.P, vs.P, vd.aType, vs.aType) then + begin + if vs.FreeType <> vtnone then + begin + if vs.aType.BaseType in NeedFinalization then + FinalizeVariant(vs.P, vs.aType); + p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr); + Dec(FTempVars.FCount); + {$IFNDEF PS_NOSMARTLIST} + Inc(FTempVars.FCheckCount); + if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate; + {$ENDIF} + FTempVars.FLength := P; + if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength; + end; + break; + end; + if vs.FreeType <> vtnone then + begin + if vs.aType.BaseType in NeedFinalization then + FinalizeVariant(vs.P, vs.aType); + p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr); + Dec(FTempVars.FCount); + {$IFNDEF PS_NOSMARTLIST} + Inc(FTempVars.FCheckCount); + if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate; + {$ENDIF} + FTempVars.FLength := P; + if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength; + end; + end; + CM_PV: + begin + if not ReadVariable(vs, True) then + Break; + if vs.FreeType <> vtnone then + begin + FTempVars.Pop; + CMD_Err(erInvalidOpcodeParameter); + break; + end; + vtemp := FStack.PushType(FindType2(btPointer)); + if vs.aType.BaseType = btPointer then + begin + PPSVariantPointer(vtemp).DataDest := Pointer(vs.p^); + PPSVariantPointer(vtemp).DestType := Pointer(Pointer(IPointer(vs.P)+PointerSize)^); + PPSVariantPointer(vtemp).FreeIt := False; + end + else + begin + PPSVariantPointer(vtemp).DataDest := vs.p; + PPSVariantPointer(vtemp).DestType := vs.aType; + PPSVariantPointer(vtemp).FreeIt := False; + end; + end; + CM_PO: begin + if FStack.Count = 0 then + begin + CMD_Err(erOutOfStackRange); + break; + end; + vtemp := FStack.Data^[FStack.Count -1]; + if (vtemp = nil) or (vtemp.FType.BaseType = btReturnAddress) then + begin + CMD_Err(erOutOfStackRange); + break; + end; + FStack.Pop; +(* Dec(FStack.FCount); + {$IFNDEF PS_NOSMARTLIST} + Inc(FStack.FCheckCount); + if FStack.FCheckCount > FMaxCheckCount then FStack.Recreate; + {$ENDIF} + FStack.FLength := Longint(IPointer(vtemp) - IPointer(FStack.DataPtr)); + if TPSTypeRec(vtemp^).BaseType in NeedFinalization then + FinalizeVariant(Pointer(IPointer(vtemp)+PointerSize), Pointer(vtemp^)); + if ((FStack.FCapacity - FStack.FLength) shr 12) > 2 then FStack.AdjustLength;*) + end; + Cm_C: begin + if FCurrentPosition + 3 >= FDataLength then + begin + Cmd_Err(erOutOfRange); + Break; + end; + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + p := unaligned(Cardinal((@FData^[FCurrentPosition])^)); + {$else} + p := Cardinal((@FData^[FCurrentPosition])^); + {$endif} + Inc(FCurrentPosition, 4); + if p >= FProcs.Count then begin + CMD_Err(erOutOfProcRange); + break; + end; + u := FProcs.Data^[p]; + if u.ClassType = TPSExternalProcRec then begin + try + if not TPSExternalProcRec(u).ProcPtr(Self, TPSExternalProcRec(u), FGlobalVars, FStack) then begin + if ExEx = erNoError then + CMD_Err(erCouldNotCallProc); + Break; + end; + except + {$IFDEF DELPHI6UP} + Tmp := AcquireExceptionObject; + {$ELSE} + if RaiseList <> nil then + begin + Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject); + PRaiseFrame(RaiseList)^.ExceptObject := nil; + end else + Tmp := nil; + {$ENDIF} + if Tmp <> nil then + begin + if Tmp is EPSException then + begin + ExceptionProc(EPSException(tmp).ProcNo, EPSException(tmp).ProcPos, erCustomError, tbtString(EPSException(tmp).Message), nil); + Break; + end else + if Tmp is EDivByZero then + begin + CMD_Err3(erDivideByZero, '', Tmp); + Break; + end; + if Tmp is EZeroDivide then + begin + CMD_Err3(erDivideByZero, '', Tmp); + Break; + end; + if Tmp is EMathError then + begin + CMD_Err3(erMathError, '', Tmp); + Break; + end; + end; + if (Tmp <> nil) and (Tmp is Exception) then + CMD_Err3(erException, tbtString(Exception(Tmp).Message), Tmp) else + CMD_Err3(erException, '', Tmp); + Break; + end; + end + else begin + Vtemp := Fstack.PushType(FReturnAddressType); + vd.P := Pointer(IPointer(VTemp)+PointerSize); + vd.aType := pointer(vtemp^); + vd.FreeType := vtNone; + PPSVariantReturnAddress(vtemp).Addr.ProcNo := FCurrProc; + PPSVariantReturnAddress(vtemp).Addr.Position := FCurrentPosition; + PPSVariantReturnAddress(vtemp).Addr.StackBase := FCurrStackBase; + + FCurrStackBase := FStack.Count - 1; + FCurrProc := TPSInternalProcRec(u); + FData := FCurrProc.Data; + FDataLength := FCurrProc.Length; + FCurrentPosition := 0; + end; + end; + CM_PG: + begin + FStack.Pop; + if FCurrentPosition + 3 >= FDataLength then + begin + Cmd_Err(erOutOfRange); + Break; + end; + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + p := unaligned(Cardinal((@FData^[FCurrentPosition])^)); + {$else} + p := Cardinal((@FData^[FCurrentPosition])^); + {$endif} + Inc(FCurrentPosition, 4); + FCurrentPosition := FCurrentPosition + p; + end; + CM_P2G: + begin + FStack.Pop; + FStack.Pop; + if FCurrentPosition + 3 >= FDataLength then + begin + Cmd_Err(erOutOfRange); + Break; + end; + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + p := unaligned(Cardinal((@FData^[FCurrentPosition])^)); + {$else} + p := Cardinal((@FData^[FCurrentPosition])^); + {$endif} + Inc(FCurrentPosition, 4); + FCurrentPosition := FCurrentPosition + p; + end; + Cm_G: + begin + if FCurrentPosition + 3 >= FDataLength then + begin + Cmd_Err(erOutOfRange); + Break; + end; + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + p := unaligned(Cardinal((@FData^[FCurrentPosition])^)); + {$else} + p := Cardinal((@FData^[FCurrentPosition])^); + {$endif} + Inc(FCurrentPosition, 4); + FCurrentPosition := FCurrentPosition + p; + end; + Cm_CG: + begin + if FCurrentPosition + 3 >= FDataLength then + begin + Cmd_Err(erOutOfRange); + Break; + end; + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + p := unaligned(Cardinal((@FData^[FCurrentPosition])^)); + {$else} + p := Cardinal((@FData^[FCurrentPosition])^); + {$endif} + Inc(FCurrentPosition, 4); + btemp := true; + if not ReadVariable(vs, btemp) then + Break; + case Vs.aType.BaseType of + btU8: btemp := tbtu8(vs.p^) <> 0; + btS8: btemp := tbts8(vs.p^) <> 0; + btU16: btemp := tbtu16(vs.p^) <> 0; + btS16: btemp := tbts16(vs.p^) <> 0; + btU32: btemp := tbtu32(vs.p^) <> 0; + btS32: btemp := tbts32(vs.p^) <> 0; + else begin + CMD_Err(erInvalidType); + if vs.FreeType <> vtNone then + FTempVars.Pop; + break; + end; + end; + if vs.FreeType <> vtNone then + FTempVars.Pop; + if btemp then + FCurrentPosition := FCurrentPosition + p; + end; + Cm_CNG: + begin + if FCurrentPosition + 3 >= FDataLength then + begin + Cmd_Err(erOutOfRange); + Break; + end; + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + p := unaligned(Cardinal((@FData^[FCurrentPosition])^)); + {$else} + p := Cardinal((@FData^[FCurrentPosition])^); + {$endif} + Inc(FCurrentPosition, 4); + btemp := true; + if not ReadVariable(vs, BTemp) then + Break; + case Vs.aType.BaseType of + btU8: btemp := tbtu8(vs.p^) = 0; + btS8: btemp := tbts8(vs.p^) = 0; + btU16: btemp := tbtu16(vs.p^) = 0; + btS16: btemp := tbts16(vs.p^) = 0; + btU32: btemp := tbtu32(vs.p^) = 0; + btS32: btemp := tbts32(vs.p^) = 0; + else begin + CMD_Err(erInvalidType); + if vs.FreeType <> vtNone then + FTempVars.Pop; + break; + end; + end; + if vs.FreeType <> vtNone then + FTempVars.Pop; + if btemp then + FCurrentPosition := FCurrentPosition + p; + end; + Cm_R: begin + FExitPoint := FCurrentPosition -1; + P2 := 0; + if FExceptionStack.Count > 0 then + begin + pp := FExceptionStack.Data[FExceptionStack.Count -1]; + while (pp.BasePtr = FCurrStackBase) or ((pp.BasePtr > FCurrStackBase) and (pp.BasePtr <> InvalidVal)) do + begin + if pp.StackSize < Cardinal(FStack.Count) then + begin + for p := Longint(FStack.count) -1 downto Longint(pp.StackSize) do + FStack.Pop + end; + FCurrStackBase := pp.BasePtr; + if pp.FinallyOffset <> InvalidVal then + begin + FCurrentPosition := pp.FinallyOffset; + pp.FinallyOffset := InvalidVal; + p2 := 1; + break; + end else if pp.Finally2Offset <> InvalidVal then + begin + FCurrentPosition := pp.Finally2Offset; + pp.Finally2Offset := InvalidVal; + p2 := 1; + break; + end else + begin + pp.Free; + FExceptionStack.DeleteLast; + if FExceptionStack.Count = 0 then break; + pp := FExceptionStack.Data[FExceptionStack.Count -1]; + end; + end; + end; + if p2 = 0 then + begin + FExitPoint := InvalidVal; + if FCurrStackBase = InvalidVal then + begin + FStatus := FOldStatus; + break; + end; + for P2 := FStack.Count - 1 downto FCurrStackBase + 1 do + FStack.Pop; + if FCurrStackBase >= FStack.Count then + begin + FStatus := FOldStatus; + break; + end; + vtemp := FStack.Data[FCurrStackBase]; + FCurrProc := PPSVariantReturnAddress(vtemp).Addr.ProcNo; + FCurrentPosition := PPSVariantReturnAddress(vtemp).Addr.Position; + FCurrStackBase := PPSVariantReturnAddress(vtemp).Addr.StackBase; + FStack.Pop; + if FCurrProc = nil then begin + FStatus := FOldStatus; + break; + end; + FData := FCurrProc.Data; + FDataLength := FCurrProc.Length; + end; + end; + Cm_Pt: begin + if FCurrentPosition + 3 >= FDataLength then + begin + Cmd_Err(erOutOfRange); + Break; + end; + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + p := unaligned(Cardinal((@FData^[FCurrentPosition])^)); + {$else} + p := Cardinal((@FData^[FCurrentPosition])^); + {$endif} + Inc(FCurrentPosition, 4); + if p > FTypes.Count then + begin + CMD_Err(erInvalidType); + break; + end; + FStack.PushType(FTypes.Data^[p]); + end; + cm_bn: + begin + if not ReadVariable(vd, True) then + Break; + if vd.FreeType <> vtNone then + FTempVars.Pop; + if not DoBooleanNot(Vd.P, vd.aType) then + break; + end; + cm_in: + begin + if not ReadVariable(vd, True) then + Break; + if vd.FreeType <> vtNone then + FTempVars.Pop; + if not DoIntegerNot(Vd.P, vd.aType) then + break; + end; + cm_vm: + begin + if not ReadVariable(vd, True) then + Break; + if vd.FreeType <> vtNone then + FTempVars.Pop; + if not DoMinus(Vd.P, vd.aType) then + break; + end; + cm_sf: + begin + if not ReadVariable(vd, True) then + Break; + if FCurrentPosition >= FDataLength then + begin + CMD_Err(erOutOfRange); // Error + if vd.FreeType <> vtNone then + FTempVars.Pop; + break; + end; + p := FData^[FCurrentPosition]; + Inc(FCurrentPosition); + case Vd.aType.BaseType of + btU8: FJumpFlag := tbtu8(Vd.p^) <> 0; + btS8: FJumpFlag := tbts8(Vd.p^) <> 0; + btU16: FJumpFlag := tbtu16(Vd.p^) <> 0; + btS16: FJumpFlag := tbts16(Vd.p^) <> 0; + btU32: FJumpFlag := tbtu32(Vd.p^) <> 0; + btS32: FJumpFlag := tbts32(Vd.p^) <> 0; + else begin + CMD_Err(erInvalidType); + if vd.FreeType <> vtNone then + FTempVars.Pop; + break; + end; + end; + if p <> 0 then + FJumpFlag := not FJumpFlag; + if vd.FreeType <> vtNone then + FTempVars.Pop; + end; + cm_fg: + begin + if FCurrentPosition + 3 >= FDataLength then + begin + Cmd_Err(erOutOfRange); + Break; + end; + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + p := unaligned(Cardinal((@FData^[FCurrentPosition])^)); + {$else} + p := Cardinal((@FData^[FCurrentPosition])^); + {$endif} + Inc(FCurrentPosition, 4); + if FJumpFlag then + FCurrentPosition := FCurrentPosition + p; + end; + cm_puexh: + begin + pp := TPSExceptionHandler.Create; + pp.CurrProc := FCurrProc; + pp.BasePtr :=FCurrStackBase; + pp.StackSize := FStack.Count; + if not ReadLong(pp.FinallyOffset) then begin + CMD_Err(erOutOfRange); + pp.Free; + Break; + end; + if not ReadLong(pp.ExceptOffset) then begin + CMD_Err(erOutOfRange); + pp.Free; + Break; + end; + if not ReadLong(pp.Finally2Offset) then begin + CMD_Err(erOutOfRange); + pp.Free; + Break; + end; + if not ReadLong(pp.EndOfBlock) then begin + CMD_Err(erOutOfRange); + pp.Free; + Break; + end; + if pp.FinallyOffset <> InvalidVal then + pp.FinallyOffset := pp.FinallyOffset + FCurrentPosition; + if pp.ExceptOffset <> InvalidVal then + pp.ExceptOffset := pp.ExceptOffset + FCurrentPosition; + if pp.Finally2Offset <> InvalidVal then + pp.Finally2Offset := pp.Finally2Offset + FCurrentPosition; + if pp.EndOfBlock <> InvalidVal then + pp.EndOfBlock := pp.EndOfBlock + FCurrentPosition; + if ((pp.FinallyOffset <> InvalidVal) and (pp.FinallyOffset >= FDataLength)) or + ((pp.ExceptOffset <> InvalidVal) and (pp.ExceptOffset >= FDataLength)) or + ((pp.Finally2Offset <> InvalidVal) and (pp.Finally2Offset >= FDataLength)) or + ((pp.EndOfBlock <> InvalidVal) and (pp.EndOfBlock >= FDataLength)) then + begin + CMD_Err(ErOutOfRange); + pp.Free; + Break; + end; + FExceptionStack.Add(pp); + end; + cm_poexh: + begin + if FCurrentPosition >= FDataLength then + begin + CMD_Err(erOutOfRange); // Error + break; + end; + p := FData^[FCurrentPosition]; + Inc(FCurrentPosition); + case p of + 2: + begin + if (FExceptionStack.Count = 0) then + begin + cmd_err(ErOutOfRange); + Break; + end; + pp := FExceptionStack.Data^[FExceptionStack.Count -1]; + if pp = nil then begin + cmd_err(ErOutOfRange); + Break; + end; + pp.ExceptOffset := InvalidVal; + if pp.Finally2Offset <> InvalidVal then + begin + FCurrentPosition := pp.Finally2Offset; + pp.Finally2Offset := InvalidVal; + end else begin + p := pp.EndOfBlock; + pp.Free; + FExceptionStack.DeleteLast; + if FExitPoint <> InvalidVal then + begin + FCurrentPosition := FExitPoint; + end else begin + FCurrentPosition := p; + end; + end; + end; + 0: + begin + pp := FExceptionStack.Data^[FExceptionStack.Count -1]; + if pp = nil then begin + cmd_err(ErOutOfRange); + Break; + end; + if pp.FinallyOffset <> InvalidVal then + begin + FCurrentPosition := pp.FinallyOffset; + pp.FinallyOffset := InvalidVal; + end else if pp.Finally2Offset <> InvalidVal then + begin + FCurrentPosition := pp.Finally2Offset; + pp.ExceptOffset := InvalidVal; + end else begin + p := pp.EndOfBlock; + pp.Free; + FExceptionStack.DeleteLast; + if ExEx <> eNoError then + begin + Tmp := ExObject; + ExObject := nil; + ExceptionProc(ExProc, ExPos, ExEx, ExParam, Tmp); + end else + if FExitPoint <> InvalidVal then + begin + FCurrentPosition := FExitPoint; + end else begin + FCurrentPosition := p; + end; + end; + end; + 1: + begin + pp := FExceptionStack.Data^[FExceptionStack.Count -1]; + if pp = nil then begin + cmd_err(ErOutOfRange); + Break; + end; + if (ExEx <> ENoError) and (pp.ExceptOffset <> InvalidVal) and (pp.ExceptOffset <> InvalidVal -1) then + begin + FCurrentPosition := pp.ExceptOffset; + pp.ExceptOffset := Cardinal(InvalidVal -1); + pp.ExceptionData := ExEx; + pp.ExceptionObject := ExObject; + pp.ExceptionParam := ExParam; + ExEx := ErNoError; + ExObject := nil; + end else if (pp.Finally2Offset <> InvalidVal) then + begin + FCurrentPosition := pp.Finally2Offset; + pp.Finally2Offset := InvalidVal; + end else begin + p := pp.EndOfBlock; + pp.Free; + FExceptionStack.DeleteLast; + if (ExEx <> eNoError) and (p <> InvalidVal) then + begin + Tmp := ExObject; + ExObject := nil; + ExceptionProc(ExProc, ExPos, ExEx, ExParam, Tmp); + end else + if FExitPoint <> InvalidVal then + begin + FCurrentPosition := FExitPoint; + end else begin + FCurrentPosition := p; + end; + end; + end; + 3: + begin + pp := FExceptionStack.Data^[FExceptionStack.Count -1]; + if pp = nil then begin + cmd_err(ErOutOfRange); + Break; + end; + p := pp.EndOfBlock; + pp.Free; + FExceptionStack.DeleteLast; + if ExEx <> eNoError then + begin + Tmp := ExObject; + ExObject := nil; + ExceptionProc(ExProc, ExPos, ExEx, ExParam, Tmp); + end else + if FExitPoint <> InvalidVal then + begin + FCurrentPosition := FExitPoint; + end else begin + FCurrentPosition := p; + end; + end; + end; + end; + cm_spc: + begin + if not ReadVariable(vd, False) then + Break; + if vd.FreeType <> vtNone then + begin + FTempVars.Pop; + CMD_Err(erInvalidOpcodeParameter); + break; + end; + if (Vd.aType.BaseType <> btPointer) then + begin + CMD_Err(erInvalidOpcodeParameter); + break; + end; + if not ReadVariable(vs, False) then + Break; + if Pointer(Pointer(IPointer(vD.P)+PointerSize2)^) <> nil then + DestroyHeapVariant2(Pointer(vD.P^), Pointer(Pointer(IPointer(vd.P)+PointerSize)^)); + if vs.aType.BaseType = btPointer then + begin + if Pointer(vs.P^) <> nil then + begin + Pointer(vd.P^) := CreateHeapVariant2(Pointer(Pointer(IPointer(vs.P) + PointerSize)^)); + Pointer(Pointer(IPointer(vd.P) + PointerSize)^) := Pointer(Pointer(IPointer(vs.P) + PointerSize)^); + Pointer(Pointer(IPointer(vd.P) + PointerSize2)^) := Pointer(1); + if not CopyArrayContents(Pointer(vd.P^), Pointer(vs.P^), 1, Pointer(Pointer(IPointer(vd.P) + PointerSize)^)) then + begin + if vs.FreeType <> vtNone then + FTempVars.Pop; + CMD_Err(ErTypeMismatch); + break; + end; + end else + begin + Pointer(vd.P^) := nil; + Pointer(Pointer(IPointer(vd.P) + PointerSize)^) := nil; + Pointer(Pointer(IPointer(vd.P) + PointerSize2)^) := nil; + end; + end else begin + Pointer(vd.P^) := CreateHeapVariant2(vs.aType); + Pointer(Pointer(IPointer(vd.P) + PointerSize)^) := vs.aType; + LongBool(Pointer(IPointer(vd.P) + PointerSize2)^) := true; + if not CopyArrayContents(Pointer(vd.P^), vs.P, 1, vs.aType) then + begin + if vs.FreeType <> vtNone then + FTempVars.Pop; + CMD_Err(ErTypeMismatch); + break; + end; + end; + if vs.FreeType <> vtNone then + FTempVars.Pop; + + end; + cm_nop:; + cm_dec: + begin + if not ReadVariable(vd, True) then + Break; + if vd.FreeType <> vtNone then + begin + FTempVars.Pop; + CMD_Err(erInvalidOpcodeParameter); + break; + end; + case vd.aType.BaseType of + btu8: dec(tbtu8(vd.P^)); + bts8: dec(tbts8(vd.P^)); + btu16: dec(tbtu16(vd.P^)); + bts16: dec(tbts16(vd.P^)); + btu32: dec(tbtu32(vd.P^)); + bts32: dec(tbts32(vd.P^)); +{$IFNDEF PS_NOINT64} + bts64: dec(tbts64(vd.P^)); +{$ENDIF} + else + begin + CMD_Err(ErTypeMismatch); + Break; + end; + end; + end; + cm_inc: + begin + if not ReadVariable(vd, True) then + Break; + if vd.FreeType <> vtNone then + begin + FTempVars.Pop; + CMD_Err(erInvalidOpcodeParameter); + break; + end; + case vd.aType.BaseType of + btu8: Inc(tbtu8(vd.P^)); + bts8: Inc(tbts8(vd.P^)); + btu16: Inc(tbtu16(vd.P^)); + bts16: Inc(tbts16(vd.P^)); + btu32: Inc(tbtu32(vd.P^)); + bts32: Inc(tbts32(vd.P^)); +{$IFNDEF PS_NOINT64} + bts64: Inc(tbts64(vd.P^)); +{$ENDIF} + else + begin + CMD_Err(ErTypeMismatch); + Break; + end; + end; + end; + cm_sp: + begin + if not ReadVariable(vd, False) then + Break; + if vd.FreeType <> vtNone then + begin + FTempVars.Pop; + CMD_Err(erInvalidOpcodeParameter); + break; + end; + if (Vd.aType.BaseType <> btPointer) then + begin + CMD_Err(erInvalidOpcodeParameter); + break; + end; + if not ReadVariable(vs, False) then + Break; + if vs.FreeType <> vtNone then + begin + FTempVars.Pop; + CMD_Err(erInvalidOpcodeParameter); + break; + end; + if vs.aType.BaseType = btPointer then + begin + Pointer(vd.P^) := Pointer(vs.p^); + Pointer(Pointer(IPointer(vd.P)+PointerSize)^) := Pointer(Pointer(IPointer(vs.P)+PointerSize)^); + end + else + begin + Pointer(vd.P^) := vs.P; + Pointer(Pointer(IPointer(vd.P)+PointerSize)^) := vs.aType; + end; + end; + Cm_cv: + begin + if not ReadVariable(vd, True) then + Break; + if vd.aType.BaseType <> btProcPtr then + begin + if vd.FreeType <> vtNone then + FTempVars.Pop; + CMD_Err(ErTypeMismatch); + break; + end; + p := tbtu32(vd.P^); + if vd.FreeType <> vtNone then + FTempVars.Pop; + if (p = 0) and (Pointer(Pointer(IPointer(vd.p)+PointerSize2)^) <> nil) then + begin + if not InvokeExternalMethod(TPSTypeRec_ProcPtr(vd.aType), Pointer(Pointer(IPointer(vd.p)+PointerSize)^), Pointer(Pointer(IPointer(vd.p)+PointerSize2)^)) then + Break; + end else begin + if (p >= FProcs.Count) or (p = FMainProc) then begin + CMD_Err(erOutOfProcRange); + break; + end; + u := FProcs.Data^[p]; + if u.ClassType = TPSExternalProcRec then begin + try + if not TPSExternalProcRec(u).ProcPtr(Self, TPSExternalProcRec(u), FGlobalVars, FStack) then begin + if ExEx = erNoError then + CMD_Err(erCouldNotCallProc); + Break; + end; + except + {$IFDEF DELPHI6UP} + Tmp := AcquireExceptionObject; + {$ELSE} + if RaiseList <> nil then + begin + Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject); + PRaiseFrame(RaiseList)^.ExceptObject := nil; + end else + Tmp := nil; + {$ENDIF} + if Tmp <> nil then + begin + if Tmp is EPSException then + begin + ExceptionProc(EPSException(tmp).ProcNo, EPSException(tmp).ProcPos, erCustomError, tbtString(EPSException(tmp).Message), nil); + break; + end else + if Tmp is EDivByZero then + begin + CMD_Err3(erDivideByZero, '', Tmp); + break; + end; + if Tmp is EZeroDivide then + begin + CMD_Err3(erDivideByZero, '', Tmp); + break; + end; + if Tmp is EMathError then + begin + CMD_Err3(erMathError, '', Tmp); + break; + end; + end; + if (Tmp <> nil) and (Tmp is Exception) then + CMD_Err3(erException, tbtString(Exception(Tmp).Message), Tmp) else + CMD_Err3(erException, '', Tmp); + Break; + end; + end + else begin + vtemp := FStack.PushType(FReturnAddressType); + PPSVariantReturnAddress(vtemp).Addr.ProcNo := FCurrProc; + PPSVariantReturnAddress(vtemp).Addr.Position := FCurrentPosition; + PPSVariantReturnAddress(vtemp).Addr.StackBase := FCurrStackBase; + FCurrStackBase := FStack.Count - 1; + FCurrProc := TPSInternalProcRec(u); + FData := FCurrProc.Data; + FDataLength := FCurrProc.Length; + FCurrentPosition := 0; + end; + end; + end; + CM_CO: + begin + if FCurrentPosition >= FDataLength then + begin + CMD_Err(erOutOfRange); // Error + break; + end; + calctype := FData^[FCurrentPosition]; + Inc(FCurrentPosition); + if not ReadVariable(v3, True) then + Break; + if v3.FreeType <> vtNone then + begin + if v3.aType.BaseType in NeedFinalization then + FinalizeVariant(v3.P, v3.aType); + p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr); + Dec(FTempVars.FCount); + {$IFNDEF PS_NOSMARTLIST} + Inc(FTempVars.FCheckCount); + if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate; + {$ENDIF} + FTempVars.FLength := P; + if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength; + CMD_Err(erInvalidOpcodeParameter); + break; + end; + if not ReadVariable(vs, True) then + Break; + if not ReadVariable(vd, True) then + begin + if vs.FreeType <> vtNone then + begin + if vs.aType.BaseType in NeedFinalization then + FinalizeVariant(vs.P, vs.aType); + p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr); + Dec(FTempVars.FCount); + {$IFNDEF PS_NOSMARTLIST} + Inc(FTempVars.FCheckCount); + if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate; + {$ENDIF} + FTempVars.FLength := P; + if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength; + end; + Break; + end; + DoBooleanCalc(Vs.P, Vd.P, v3.P, vs.aType, vd.aType, v3.aType, CalcType); + if vd.FreeType <> vtNone then + begin + if vd.aType.BaseType in NeedFinalization then + FinalizeVariant(vd.P, vd.aType); + p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr); + Dec(FTempVars.FCount); + {$IFNDEF PS_NOSMARTLIST} + Inc(FTempVars.FCheckCount); + if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate; + {$ENDIF} + FTempVars.FLength := P; + if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength; + end; + if vs.FreeType <> vtNone then + begin + if vs.aType.BaseType in NeedFinalization then + FinalizeVariant(vs.P, vs.aType); + p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr); + Dec(FTempVars.FCount); + {$IFNDEF PS_NOSMARTLIST} + Inc(FTempVars.FCheckCount); + if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate; + {$ENDIF} + FTempVars.FLength := P; + if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength; + end; + end; + + else + CMD_Err(erInvalidOpcode); // Error + end; + end; +// if cmd <> invalidval then ProfilerExitProc(Cmd+1); +// if ExEx <> erNoError then FStatus := FOldStatus; + until (FExceptionStack.Count = 0) or (Fstatus <> IsRunning); + if FStatus = isLoaded then begin + for I := Longint(FStack.Count) - 1 downto 0 do + FStack.Pop; + FStack.Clear; + if FCallCleanup then Cleanup; + end; + Result := ExEx = erNoError; +end; + +function NVarProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +var + tmp: TPSVariantIFC; +begin + case Longint(p.Ext1) of + 0: + begin + if @Caller.FOnSetNVariant = nil then begin Result := False; exit; end; + tmp := NewTPSVariantIFC(Stack.Items[Stack.Count - 2], True); + if (Tmp.Dta = nil) or (tmp.aType.BaseType <> btVariant) then begin Result := False; exit; end; + Caller.FOnSetNVariant(Caller, Stack.GetAnsiString(-1), Variant(tmp.Dta^)); + Result := true; + end; + 1: + begin + if @Caller.FOnGetNVariant = nil then begin Result := False; exit; end; + tmp := NewTPSVariantIFC(Stack.Items[Stack.Count - 1], False); + if (Tmp.Dta = nil) or (tmp.aType.BaseType <> btVariant) then begin Result := False; exit; end; + Variant(tmp.Dta^) := Caller.FOnGetNVariant(Caller, Stack.GetAnsiString(-2)); + Result := true; + end; + else + Result := False; + end; +end; + +function DefProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +var + temp: TPSVariantIFC; + I: Longint; + b: Boolean; + pex: TPSExceptionHandler; + Tmp: TObject; +begin + case Longint(p.Ext1) of + 0: Stack.SetAnsiString(-1, IntToStr(Stack.{$IFNDEF PS_NOINT64}GetInt64{$ELSE}GetInt{$ENDIF}(-2))); // inttostr + 1: Stack.SetInt(-1, StrToInt(Stack.GetAnsiString(-2))); // strtoint + 2: Stack.SetInt(-1, StrToIntDef(Stack.GetAnsiString(-2), Stack.GetInt(-3))); // strtointdef + 3: + if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then + Stack.SetInt(-1, Pos(Stack.GetUnicodeString(-2), Stack.GetUnicodeString(-3)))// pos + else + if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then + Stack.SetInt(-1, Pos(Stack.GetWideString(-2), Stack.GetWideString(-3)))// pos + else + Stack.SetInt(-1, Pos(Stack.GetAnsiString(-2), Stack.GetAnsiString(-3)));// pos + 4: + if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then + Stack.SetWideString(-1, Copy(Stack.GetWideString(-2), Stack.GetInt(-3), Stack.GetInt(-4))) // copy + else + if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then + Stack.SetUnicodeString(-1, Copy(Stack.GetUnicodeString(-2), Stack.GetInt(-3), Stack.GetInt(-4))) // copy + else + Stack.SetAnsiString(-1, Copy(Stack.GetAnsiString(-2), Stack.GetInt(-3), Stack.GetInt(-4))); // copy + 5: //delete + begin + temp := NewTPSVariantIFC(Stack[Stack.Count -1], True); + if (temp.Dta <> nil) and (temp.aType.BaseType = btUnicodeString) then + begin + Delete(tbtUnicodeString(temp.Dta^), Stack.GetInt(-2), Stack.GetInt(-3)); + end else + if (temp.Dta <> nil) and (temp.aType.BaseType = btWideString) then + begin + Delete(tbtwidestring(temp.Dta^), Stack.GetInt(-2), Stack.GetInt(-3)); + end else begin + if (temp.Dta = nil) or (temp.aType.BaseType <> btString) then + begin + Result := False; + exit; + end; + Delete(tbtstring(temp.Dta^), Stack.GetInt(-2), Stack.GetInt(-3)); + end; + end; + 6: // insert + begin + temp := NewTPSVariantIFC(Stack[Stack.Count -2], True); + if (temp.Dta <> nil) and (temp.aType.BaseType = btUnicodeString) then begin + Insert(Stack.GetUnicodeString(-1), tbtUnicodeString(temp.Dta^), Stack.GetInt(-3)); + end else if (temp.Dta <> nil) and (temp.aType.BaseType = btWideString) then begin + Insert(Stack.GetWideString(-1), tbtwidestring(temp.Dta^), Stack.GetInt(-3)); + end else begin + if (temp.Dta = nil) or (temp.aType.BaseType <> btString) then + begin + Result := False; + exit; + end; + Insert(Stack.GetAnsiString(-1), tbtstring(temp.Dta^), Stack.GetInt(-3)); + end; + end; + 7: // StrGet + begin + temp := NewTPSVariantIFC(Stack[Stack.Count -2], True); + if (temp.Dta = nil) or (temp.aType.BaseType <> btString) then + begin + Result := False; + exit; + end; + I := Stack.GetInt(-3); + if (i<1) or (i>length(tbtstring(temp.Dta^))) then + begin + Caller.CMD_Err2(erCustomError, tbtString(RPS_OutOfStringRange)); + Result := False; + exit; + end; + Stack.SetInt(-1,Ord(tbtstring(temp.Dta^)[i])); + end; + 8: // StrSet + begin + temp := NewTPSVariantIFC(Stack[Stack.Count -3], True); + if (temp.Dta = nil) or (temp.aType.BaseType <> btString) then + begin + Result := False; + exit; + end; + I := Stack.GetInt(-2); + if (i<1) or (i>length(tbtstring(temp.Dta^))) then + begin + Caller.CMD_Err2(erCustomError, tbtString(RPS_OutOfStringRange)); + Result := True; + exit; + end; + tbtstring(temp.Dta^)[i] := tbtchar(Stack.GetInt(-1)); + end; + 10: +{$IFDEF DELPHI2009UP} + if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then + Stack.SetUnicodeString(-1, UpperCase(Stack.GetUnicodeString(-2))) // Uppercase + else +{$ENDIF} + if (Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString) or + (Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString) then + Stack.SetWideString(-1, WideUpperCase(Stack.GetWideString(-2))) // Uppercase + else + Stack.SetAnsiString(-1, FastUppercase(Stack.GetAnsiString(-2))); // Uppercase + 11: +{$IFDEF DELPHI2009UP} + if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then + Stack.SetUnicodeString(-1, LowerCase(Stack.GetUnicodeString(-2))) // Uppercase + else +{$ENDIF} + if (Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString) or + (Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString) then + Stack.SetWideString(-1, WideLowerCase(Stack.GetWideString(-2))) // Uppercase + else + Stack.SetAnsiString(-1, FastLowercase(Stack.GetAnsiString(-2)));// LowerCase + 12: + if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then + Stack.SetUnicodeString(-1, SysUtils.Trim(Stack.GetUnicodestring(-2))) // Uppercase + else if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then + Stack.SetWideString(-1, SysUtils.Trim(Stack.GetWideString(-2))) // Uppercase + else + Stack.SetAnsiString(-1, Trim(Stack.GetAnsiString(-2)));// Trim + 13: Stack.SetInt(-1, Length(Stack.GetAnsiString(-2))); // Length + 14: // SetLength + begin + temp := NewTPSVariantIFC(Stack[Stack.Count -1], True); + if (temp.Dta = nil) or (temp.aType.BaseType <> btString) then + begin + Result := False; + exit; + end; + SetLength(tbtstring(temp.Dta^), STack.GetInt(-2)); + end; + 15: Stack.SetReal(-1, Sin(Stack.GetReal(-2))); // Sin + 16: Stack.SetReal(-1, Cos(Stack.GetReal(-2))); // Cos + 17: Stack.SetReal(-1, SQRT(Stack.GetReal(-2))); // Sqrt + 18: Stack.SetInt(-1, Round(Stack.GetReal(-2))); // Round + 19: Stack.SetInt(-1, Trunc(Stack.GetReal(-2))); // Trunc + 20: Stack.SetReal(-1, Int(Stack.GetReal(-2))); // Int + 21: Stack.SetReal(-1, Pi); // Pi + 22: Stack.SetReal(-1, Abs(Stack.GetReal(-2))); // Abs + 23: Stack.SetReal(-1, StrToFloat(Stack.GetAnsiString(-2))); // StrToFloat + 24: Stack.SetAnsiString(-1, FloatToStr(Stack.GetReal(-2)));// FloatToStr + 25: + if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then + Stack.SetUnicodeString(-1, upadL(Stack.GetUnicodeString(-2), Stack.GetInt(-3))) // PadL + else + if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then + Stack.SetWideString(-1, wPadL(Stack.GetWideString(-2), Stack.GetInt(-3))) // PadL + else + Stack.SetAnsiString(-1, PadL(Stack.GetAnsiString(-2), Stack.GetInt(-3))); // PadL + 26: + if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then + Stack.SetUnicodeString(-1, uPadR(Stack.GetUnicodeString(-2), Stack.GetInt(-3))) // PadR + else + if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then + Stack.SetWideString(-1, wPadR(Stack.GetWideString(-2), Stack.GetInt(-3))) // PadR + else + Stack.SetAnsiString(-1, PadR(Stack.GetAnsiString(-2), Stack.GetInt(-3))); // PadR + 27: + if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then + Stack.SetUnicodeString(-1, uPadZ(Stack.GetUnicodeString(-2), Stack.GetInt(-3)))// PadZ + else + if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then + Stack.SetWideString(-1, wPadZ(Stack.GetWideString(-2), Stack.GetInt(-3)))// PadZ + else + Stack.SetAnsiString(-1, PadZ(Stack.GetAnsiString(-2), Stack.GetInt(-3)));// PadZ + 28: Stack.SetAnsiString(-1, StringOfChar(tbtChar(Stack.GetInt(-2)), Stack.GetInt(-3))); // Replicate/StrOfChar + 29: // Assigned + begin + temp := NewTPSVariantIFC(Stack[Stack.Count -2], True); + if Temp.dta = nil then + begin + Result := False; + exit; + end; + case temp.aType.BaseType of + btU8, btS8: b := tbtu8(temp.dta^) <> 0; + btU16, btS16: b := tbtu16(temp.dta^) <> 0; + btU32, btS32: b := tbtu32(temp.dta^) <> 0; + btString, btPChar: b := tbtstring(temp.dta^) <> ''; +{$IFNDEF PS_NOWIDESTRING} + btWideString: b := tbtwidestring(temp.dta^)<> ''; + btUnicodeString: b := tbtUnicodeString(temp.dta^)<> ''; +{$ENDIF} + btArray, btClass{$IFNDEF PS_NOINTERFACES}, btInterface{$ENDIF}: b := Pointer(temp.dta^) <> nil; + else + Result := False; + Exit; + end; + if b then + Stack.SetInt(-1, 1) + else + Stack.SetInt(-1, 0); + end; + 30: + begin {RaiseLastException} + if (Caller.FExceptionStack.Count > 0) then begin + pex := Caller.FExceptionStack.Data[Caller.fExceptionStack.Count -1]; + if pex.ExceptOffset = Cardinal(InvalidVal -1) then begin + Tmp := pex.ExceptionObject; + pex.ExceptionObject := nil; + Caller.ExceptionProc(Caller.ExProc, pex.ExceptOffset, pex.ExceptionData, pex.ExceptionParam, tmp); + end; + end; + end; + 31: Caller.CMD_Err2(TPSError(Stack.GetInt(-1)), Stack.GetAnsiString(-2)); {RaiseExeption} + 32: Stack.SetInt(-1, Ord(Caller.LastEx)); {ExceptionType} + 33: Stack.SetAnsiString(-1, Caller.LastExParam); {ExceptionParam} + 34: Stack.SetInt(-1, Caller.LastExProc); {ExceptionProc} + 35: Stack.SetInt(-1, Caller.LastExPos); {ExceptionPos} + 36: Stack.SetAnsiString(-1, PSErrorToString(TPSError(Stack.GetInt(-2)), Stack.GetAnsiString(-3))); {ExceptionToString} + 37: Stack.SetAnsiString(-1, tbtString(AnsiUpperCase(string(Stack.GetAnsiString(-2))))); // AnsiUppercase + 38: Stack.SetAnsiString(-1, tbtString(AnsiLowercase(string(Stack.GetAnsiString(-2))))); // AnsiLowerCase +{$IFNDEF PS_NOINT64} + 39: Stack.SetInt64(-1, StrToInt64(string(Stack.GetAnsiString(-2)))); // StrToInt64 + 40: Stack.SetAnsiString(-1, SysUtils.IntToStr(Stack.GetInt64(-2)));// Int64ToStr +{$ENDIF} + 41: // sizeof + begin + temp := NewTPSVariantIFC(Stack[Stack.Count -2], False); + if Temp.aType = nil then + Stack.SetInt(-1, 0) + else + Stack.SetInt(-1, Temp.aType.RealSize) + end; +{$IFNDEF PS_NOWIDESTRING} + 42: // WStrGet + begin + temp := NewTPSVariantIFC(Stack[Stack.Count -2], True); + if temp.dta = nil then begin + result := false; + exit; + end; + case temp.aType.BaseType of + btWideString: + begin + I := Stack.GetInt(-3); + if (i<1) or (i>length(tbtwidestring(temp.Dta^))) then + begin + Caller.CMD_Err2(erCustomError, tbtString(RPS_OutOfStringRange)); + Result := False; + exit; + end; + Stack.SetInt(-1,Ord(tbtwidestring(temp.Dta^)[i])); + end; + btUnicodeString: + begin + I := Stack.GetInt(-3); + if (i<1) or (i>length(tbtUnicodeString(temp.Dta^))) then + begin + Caller.CMD_Err2(erCustomError, tbtString(RPS_OutOfStringRange)); + Result := False; + exit; + end; + Stack.SetInt(-1,Ord(tbtUnicodeString(temp.Dta^)[i])); + end; + + else + begin + Result := False; + exit; + end; + end; + end; + 43: // WStrSet + begin + temp := NewTPSVariantIFC(Stack[Stack.Count -3], True); + if (temp.Dta = nil) then + begin + Result := False; + exit; + end; + case temp.aType.BaseType of + btWideString: + begin + I := Stack.GetInt(-2); + if (i<1) or (i>length(tbtWidestring(temp.Dta^))) then + begin + Caller.CMD_Err2(erCustomError, tbtString(RPS_OutOfStringRange)); + Result := True; + exit; + end; + tbtWidestring(temp.Dta^)[i] := WideChar(Stack.GetInt(-1)); + end; + + btUnicodeString: + begin + I := Stack.GetInt(-2); + if (i<1) or (i>length(tbtunicodestring(temp.Dta^))) then + begin + Caller.CMD_Err2(erCustomError, tbtString(RPS_OutOfStringRange)); + Result := True; + exit; + end; + tbtunicodestring(temp.Dta^)[i] := WideChar(Stack.GetInt(-1)); + end; + else + begin + Result := False; + exit; + end; + end; + end; +{$ENDIF} + else + begin + Result := False; + exit; + end; + end; + Result := True; +end; +function GetArrayLength(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +var + arr: TPSVariantIFC; +begin + Arr := NewTPSVariantIFC(Stack[Stack.Count-2], True); + if (arr.Dta = nil) or (arr.aType.BaseType <> btArray) then + begin + Result := false; + exit; + end; + Stack.SetInt(-1, PSDynArrayGetLength(Pointer(arr.Dta^), arr.aType)); + Result := True; +end; + +function SetArrayLength(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +var + arr: TPSVariantIFC; +begin + Arr := NewTPSVariantIFC(Stack[Stack.Count-1], True); + if (arr.Dta = nil) or (arr.aType.BaseType <> btArray) then + begin + Result := false; + exit; + end; + PSDynArraySetLength(Pointer(arr.Dta^), arr.aType, Stack.GetInt(-2)); + Result := True; +end; + + +function InterfaceProc(Sender: TPSExec; p: TPSExternalProcRec; Tag: Pointer): Boolean; forward; + +procedure RegisterInterfaceLibraryRuntime(Se: TPSExec); +begin + SE.AddSpecialProcImport('intf', InterfaceProc, nil); +end; + +{$IFNDEF DELPHI6UP} +function Null: Variant; +begin + Result := System.Null; +end; + +function Unassigned: Variant; +begin + Result := System.Unassigned; +end; +{$ENDIF} +function Length_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +var + arr: TPSVariantIFC; +begin + arr:=NewTPSVariantIFC(Stack[Stack.Count-2],false); + case arr.aType.BaseType of + btArray: + begin + Stack.SetInt(-1,PSDynArrayGetLength(Pointer(arr.Dta^),arr.aType)); + Result:=true; + end; + btStaticArray: + begin + Stack.SetInt(-1,TPSTypeRec_StaticArray(arr.aType).Size); + Result:=true; + end; + btString: + begin + Stack.SetInt(-1,length(tbtstring(arr.Dta^))); + Result:=true; + end; + {$IFNDEF PS_NOWIDESTRING} + btWideString: + begin + Stack.SetInt(-1,length(tbtWidestring(arr.Dta^))); + Result:=true; + end; + btUnicodeString: + begin + Stack.SetInt(-1,length(tbtUnicodeString(arr.Dta^))); + Result:=true; + end; + {$ENDIF} + btvariant: + begin + Stack.SetInt(-1,length(Variant(arr.Dta^))); + Result:=true; + end; + else + begin + Caller.CMD_Err(ErTypeMismatch); + result := true; + end; + end; +end; + + +function SetLength_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +var + arr: TPSVariantIFC; +begin + Result:=false; + arr:=NewTPSVariantIFC(Stack[Stack.Count-1],true); + if arr.aType.BaseType=btArray then + begin + PSDynArraySetLength(Pointer(arr.Dta^),arr.aType,Stack.GetInt(-2)); + Result:=true; + end else + if arr.aType.BaseType=btString then + begin + SetLength(tbtstring(arr.Dta^),STack.GetInt(-2)); + Result:=true; +{$IFNDEF PS_NOWIDESTRING} + end else + if arr.aType.BaseType=btWideString then + begin + SetLength(tbtwidestring(arr.Dta^),STack.GetInt(-2)); + Result:=true; + end else + if arr.aType.BaseType=btUnicodeString then + begin + SetLength(tbtUnicodeString(arr.Dta^),STack.GetInt(-2)); + Result:=true; +{$ENDIF} + end; +end; + +function Low_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +var + arr: TPSVariantIFC; +begin + Result:=true; + arr:=NewTPSVariantIFC(Stack[Stack.Count-2],false); + case arr.aType.BaseType of + btArray : Stack.SetInt(-1,0); + btStaticArray: Stack.SetInt(-1,TPSTypeRec_StaticArray(arr.aType).StartOffset); + btString : Stack.SetInt(-1,1); + btU8 : Stack.SetInt(-1,Low(Byte)); //Byte: 0 + btS8 : Stack.SetInt(-1,Low(ShortInt)); //ShortInt: -128 + btU16 : Stack.SetInt(-1,Low(Word)); //Word: 0 + btS16 : Stack.SetInt(-1,Low(SmallInt)); //SmallInt: -32768 + btU32 : Stack.SetInt(-1,Low(Cardinal)); //Cardinal/LongWord: 0 + btS32 : Stack.SetInt(-1,Low(Integer)); //Integer/LongInt: -2147483648 + else Result:=false; + end; +end; + +function High_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +var + arr: TPSVariantIFC; +begin + Result:=true; + arr:=NewTPSVariantIFC(Stack[Stack.Count-2],false); + case arr.aType.BaseType of + btArray : Stack.SetInt(-1,PSDynArrayGetLength(Pointer(arr.Dta^),arr.aType)-1); + btStaticArray: Stack.SetInt(-1,TPSTypeRec_StaticArray(arr.aType).StartOffset+TPSTypeRec_StaticArray(arr.aType).Size-1); + btString : Stack.SetInt(-1,Length(tbtstring(arr.Dta^))); + btU8 : Stack.SetInt(-1,High(Byte)); //Byte: 255 + btS8 : Stack.SetInt(-1,High(ShortInt)); //ShortInt: 127 + btU16 : Stack.SetInt(-1,High(Word)); //Word: 65535 + btS16 : Stack.SetInt(-1,High(SmallInt)); //SmallInt: 32767 + btU32 : Stack.SetUInt(-1,High(Cardinal)); //Cardinal/LongWord: 4294967295 + btS32 : Stack.SetInt(-1,High(Integer)); //Integer/LongInt: 2147483647 + else Result:=false; + end; +end; + +function Dec_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +var + arr: TPSVariantIFC; +begin + Result:=true; + arr:=NewTPSVariantIFC(Stack[Stack.Count-1],true); + case arr.aType.BaseType of + btU8 : Stack.SetInt(-1,Tbtu8(arr.dta^)-1); //Byte + btS8 : Stack.SetInt(-1,Tbts8(arr.dta^)-1); //ShortInt + btU16 : Stack.SetInt(-1,Tbtu16(arr.dta^)-1); //Word + btS16 : Stack.SetInt(-1,Tbts16(arr.dta^)-1); //SmallInt + btU32 : Stack.SetInt(-1,Tbtu32(arr.dta^)-1); //Cardinal/LongWord + btS32 : Stack.SetInt(-1,Tbts32(arr.dta^)-1); //Integer/LongInt + else Result:=false; + end; +end; + +function Inc_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +var + arr: TPSVariantIFC; +begin + Result:=true; + arr:=NewTPSVariantIFC(Stack[Stack.Count-1],true); + case arr.aType.BaseType of + btU8 : Stack.SetInt(-1,Tbtu8(arr.dta^)+1); //Byte + btS8 : Stack.SetInt(-1,Tbts8(arr.dta^)+1); //ShortInt + btU16 : Stack.SetInt(-1,Tbtu16(arr.dta^)+1); //Word + btS16 : Stack.SetInt(-1,Tbts16(arr.dta^)+1); //SmallInt + btU32 : Stack.SetInt(-1,Tbtu32(arr.dta^)+1); //Cardinal/LongWord + btS32 : Stack.SetInt(-1,Tbts32(arr.dta^)+1); //Integer/LongInt + else Result:=false; + end; +end; + + +procedure TPSExec.RegisterStandardProcs; +begin + RegisterFunctionName('!NOTIFICATIONVARIANTSET', NVarProc, Pointer(0), nil); + RegisterFunctionName('!NOTIFICATIONVARIANTGET', NVarProc, Pointer(1), nil); + + RegisterFunctionName('INTTOSTR', DefProc, Pointer(0), nil); + RegisterFunctionName('STRTOINT', DefProc, Pointer(1), nil); + RegisterFunctionName('STRTOINTDEF', DefProc, Pointer(2), nil); + RegisterFunctionName('POS', DefProc, Pointer(3), nil); + RegisterFunctionName('COPY', DefProc, Pointer(4), nil); + RegisterFunctionName('DELETE', DefProc, Pointer(5), nil); + RegisterFunctionName('INSERT', DefProc, Pointer(6), nil); + + RegisterFunctionName('STRGET', DefProc, Pointer(7), nil); + RegisterFunctionName('STRSET', DefProc, Pointer(8), nil); + RegisterFunctionName('UPPERCASE', DefProc, Pointer(10), nil); + RegisterFunctionName('LOWERCASE', DefProc, Pointer(11), nil); + RegisterFunctionName('TRIM', DefProc, Pointer(12), nil); + + RegisterFunctionName('LENGTH',Length_,nil,nil); + RegisterFunctionName('SETLENGTH',SetLength_,nil,nil); + RegisterFunctionName('LOW',Low_,nil,nil); + RegisterFunctionName('HIGH',High_,nil,nil); + RegisterFunctionName('DEC',Dec_,nil,nil); + RegisterFunctionName('INC',Inc_,nil,nil); + + RegisterFunctionName('SIN', DefProc, Pointer(15), nil); + RegisterFunctionName('COS', DefProc, Pointer(16), nil); + RegisterFunctionName('SQRT', DefProc, Pointer(17), nil); + RegisterFunctionName('ROUND', DefProc, Pointer(18), nil); + RegisterFunctionName('TRUNC', DefProc, Pointer(19), nil); + RegisterFunctionName('INT', DefProc, Pointer(20), nil); + RegisterFunctionName('PI', DefProc, Pointer(21), nil); + RegisterFunctionName('ABS', DefProc, Pointer(22), nil); + RegisterFunctionName('STRTOFLOAT', DefProc, Pointer(23), nil); + RegisterFunctionName('FLOATTOSTR', DefProc, Pointer(24), nil); + RegisterFunctionName('PADL', DefProc, Pointer(25), nil); + RegisterFunctionName('PADR', DefProc, Pointer(26), nil); + RegisterFunctionName('PADZ', DefProc, Pointer(27), nil); + RegisterFunctionName('REPLICATE', DefProc, Pointer(28), nil); + RegisterFunctionName('STRINGOFCHAR', DefProc, Pointer(28), nil); + RegisterFunctionName('!ASSIGNED', DefProc, Pointer(29), nil); + + RegisterDelphiFunction(@Unassigned, 'UNASSIGNED', cdRegister); + RegisterDelphiFunction(@VarIsEmpty, 'VARISEMPTY', cdRegister); + RegisterDelphiFunction(@Null, 'NULL', cdRegister); + RegisterDelphiFunction(@VarIsNull, 'VARISNULL', cdRegister); + RegisterDelphiFunction(@VarType, 'VARTYPE', cdRegister); + {$IFNDEF PS_NOIDISPATCH} + RegisterDelphiFunction(@IDispatchInvoke, 'IDISPATCHINVOKE', cdregister); + {$ENDIF} + + + RegisterFunctionName('GETARRAYLENGTH', GetArrayLength, nil, nil); + RegisterFunctionName('SETARRAYLENGTH', SetArrayLength, nil, nil); + + RegisterFunctionName('RAISELASTEXCEPTION', DefPRoc, Pointer(30), nil); + RegisterFunctionName('RAISEEXCEPTION', DefPRoc, Pointer(31), nil); + RegisterFunctionName('EXCEPTIONTYPE', DefPRoc, Pointer(32), nil); + RegisterFunctionName('EXCEPTIONPARAM', DefPRoc, Pointer(33), nil); + RegisterFunctionName('EXCEPTIONPROC', DefPRoc, Pointer(34), nil); + RegisterFunctionName('EXCEPTIONPOS', DefPRoc, Pointer(35), nil); + RegisterFunctionName('EXCEPTIONTOSTRING', DefProc, Pointer(36), nil); + RegisterFunctionName('ANSIUPPERCASE', DefProc, Pointer(37), nil); + RegisterFunctionName('ANSILOWERCASE', DefProc, Pointer(38), nil); + + {$IFNDEF PS_NOINT64} + RegisterFunctionName('STRTOINT64', DefProc, Pointer(39), nil); + RegisterFunctionName('INT64TOSTR', DefProc, Pointer(40), nil); + {$ENDIF} + RegisterFunctionName('SIZEOF', DefProc, Pointer(41), nil); + + {$IFNDEF PS_NOWIDESTRING} + RegisterFunctionName('WSTRGET', DefProc, Pointer(42), nil); + RegisterFunctionName('WSTRSET', DefProc, Pointer(43), nil); + {$ENDIF} + + RegisterInterfaceLibraryRuntime(Self); +end; + + +function ToString(p: PansiChar): tbtString; +begin + SetString(Result, p, StrLen(p)); +end; + +function IntPIFVariantToVariant(Src: pointer; aType: TPSTypeRec; var Dest: Variant): Boolean; + function BuildArray(P: Pointer; aType: TPSTypeRec; Len: Longint): Boolean; + var + i, elsize: Longint; + v: variant; + begin + elsize := aType.RealSize; + Dest := VarArrayCreate([0, Len-1], varVariant); + for i := 0 to Len -1 do + begin + if not IntPIFVariantToVariant(p, aType, v) then + begin + result := false; + exit; + end; + Dest[i] := v; + p := Pointer(IPointer(p) + Cardinal(elSize)); + end; + result := true; + end; +begin + if aType = nil then + begin + Dest := null; + Result := True; + exit; + end; + if aType.BaseType = btPointer then + begin + aType := TPSTypeRec(Pointer(IPointer(src)+PointerSize)^); + Src := Pointer(Pointer(Src)^); + end; + + case aType.BaseType of + btVariant: Dest := variant(src^); + btArray: if not BuildArray(Pointer(Src^), TPSTypeRec_Array(aType).ArrayType, PSDynArrayGetLength(Pointer(src^), aType)) then begin result := false; exit; end; + btStaticArray: if not BuildArray(Pointer(Src), TPSTypeRec_StaticArray(aType).ArrayType, PSDynArrayGetLength(Pointer(src^), aType)) then begin result := false; exit; end; + btU8: + if aType.ExportName = 'BOOLEAN' then + Dest := boolean(tbtu8(Src^) <> 0) + else + Dest := tbtu8(Src^); + btS8: Dest := tbts8(Src^); + btU16: Dest := tbtu16(Src^); + btS16: Dest := tbts16(Src^); + btU32: Dest := {$IFDEF DELPHI6UP}tbtu32{$ELSE}tbts32{$ENDIF}(Src^); + btS32: Dest := tbts32(Src^); + btSingle: Dest := tbtsingle(Src^); + btCurrency: Dest:=tbtCurrency(Src^); + btDouble: + begin + if aType.ExportName = 'TDATETIME' then + Dest := TDateTime(tbtDouble(Src^)) + else + Dest := tbtDouble(Src^); + end; + btExtended: Dest := tbtExtended(Src^); + btString: Dest := tbtString(Src^); + btPChar: Dest := ToString(PansiChar(Src^)); + {$IFNDEF PS_NOINT64} + {$IFDEF DELPHI6UP} btS64: Dest := tbts64(Src^); {$ELSE} bts64: begin Result := False; exit; end; {$ENDIF} + {$ENDIF} + btChar: Dest := tbtString(tbtchar(src^)); + {$IFNDEF PS_NOWIDESTRING} + btWideString: Dest := tbtWideString(src^); + btWideChar: Dest := tbtwidestring(tbtwidechar(src^)); + btUnicodeString: Dest := tbtUnicodeString(src^); + {$ENDIF} + else + begin + Result := False; + exit; + end; + end; + Result := True; +end; + +function PIFVariantToVariant(Src: PIFVariant; var Dest: Variant): Boolean; +begin + Result := IntPIFVariantToVariant(@PPSVariantData(src).Data, Src.FType, Dest); +end; + +function VariantToPIFVariant(Exec: TPSExec; const Src: Variant; Dest: PIFVariant): Boolean; +var + TT: PIFTypeRec; +begin + if Dest = nil then begin Result := false; exit; end; + tt := Exec.FindType2(btVariant); + if tt = nil then begin Result := false; exit; end; + if Dest.FType.BaseType = btPointer then + Result := Exec.SetVariantValue(PPSVariantPointer(Dest).DataDest, @Src, PPSVariantPointer(Dest).DestType, tt) + else + Result := Exec.SetVariantValue(@PPSVariantData(Dest).Data, @Src, Dest.FType, tt); +end; + +type + POpenArray = ^TOpenArray; + TOpenArray = record + AType: Byte; {0} + OrgVar: PPSVariantIFC; + FreeIt: Boolean; + ElementSize, + ItemCount: Longint; + Data: Pointer; + VarParam: Boolean; + end; +function CreateOpenArray(VarParam: Boolean; Sender: TPSExec; val: PPSVariantIFC): POpenArray; +var + datap, p: Pointer; + ctype: TPSTypeRec; + cp: Pointer; + i: Longint; +begin + if (Val.aType.BaseType <> btArray) and (val.aType.BaseType <> btStaticArray) then + begin + Result := nil; + exit; + end; + New(Result); + Result.AType := 0; + Result.OrgVar := Val; + Result.VarParam := VarParam; + + if val.aType.BaseType = btStaticArray then + begin + Result^.ItemCount := TPSTypeRec_StaticArray(val.aType).Size; + datap := Val.Dta; + end else + begin + Result^.ItemCount := PSDynArrayGetLength(Pointer(Val.Dta^), val.aType); + datap := Pointer(Val.Dta^); + end; + if TPSTypeRec_Array(Val.aType).ArrayType.BaseType <> btPointer then + begin + Result.FreeIt := False; + result.ElementSize := 0; + Result.Data := datap; + exit; + end; + Result.FreeIt := True; + Result.ElementSize := sizeof(TVarRec); + GetMem(Result.Data, Result.ItemCount * Result.ElementSize); + P := Result.Data; + FillChar(p^, Result^.ItemCount * Result^.ElementSize, 0); + for i := 0 to Result^.ItemCount -1 do + begin + ctype := Pointer(Pointer(IPointer(datap)+PointerSize)^); + cp := Pointer(Datap^); + if cp = nil then + begin + tvarrec(p^).VType := vtPointer; + tvarrec(p^).VPointer := nil; + end else begin + case ctype.BaseType of + btVariant: begin + tvarrec(p^).VType := vtVariant; + tvarrec(p^).VVariant := cp; + end; + btchar: begin + tvarrec(p^).VType := vtChar; + tvarrec(p^).VChar := tbtChar(tbtchar(cp^)); + end; + btSingle: + begin + tvarrec(p^).VType := vtExtended; + New(tvarrec(p^).VExtended); + tvarrec(p^).VExtended^ := tbtsingle(cp^); + end; + btExtended: + begin + tvarrec(p^).VType := vtExtended; + New(tvarrec(p^).VExtended); + tvarrec(p^).VExtended^ := tbtextended(cp^);; + end; + btDouble: + begin + tvarrec(p^).VType := vtExtended; + New(tvarrec(p^).VExtended); + tvarrec(p^).VExtended^ := tbtdouble(cp^); + end; + {$IFNDEF PS_NOWIDESTRING} + btwidechar: begin + tvarrec(p^).VType := vtWideChar; + tvarrec(p^).VWideChar := tbtwidechar(cp^); + end; + {$IFDEF DELPHI2009UP} + btUnicodeString: begin + tvarrec(p^).VType := vtUnicodeString; + tbtunicodestring(TVarRec(p^).VWideString) := tbtunicodestring(cp^); + end; + {$ELSE} + btUnicodeString, + {$ENDIF} + btwideString: begin + tvarrec(p^).VType := vtWideString; + tbtwidestring(TVarRec(p^).VWideString) := tbtwidestring(cp^); + end; + {$ENDIF} + btU8: begin + tvarrec(p^).VType := vtInteger; + tvarrec(p^).VInteger := tbtu8(cp^); + end; + btS8: begin + tvarrec(p^).VType := vtInteger; + tvarrec(p^).VInteger := tbts8(cp^); + end; + btU16: begin + tvarrec(p^).VType := vtInteger; + tvarrec(p^).VInteger := tbtu16(cp^); + end; + btS16: begin + tvarrec(p^).VType := vtInteger; + tvarrec(p^).VInteger := tbts16(cp^); + end; + btU32: begin + tvarrec(p^).VType := vtInteger; + tvarrec(p^).VInteger := tbtu32(cp^); + end; + btS32: begin + tvarrec(p^).VType := vtInteger; + tvarrec(p^).VInteger := tbts32(cp^); + end; + {$IFNDEF PS_NOINT64} + btS64: begin + tvarrec(p^).VType := vtInt64; + New(tvarrec(p^).VInt64); + tvarrec(p^).VInt64^ := tbts64(cp^); + end; + {$ENDIF} + btString: begin + tvarrec(p^).VType := vtAnsiString; + tbtString(TVarRec(p^).VAnsiString) := tbtstring(cp^); + end; + btPChar: + begin + tvarrec(p^).VType := vtPchar; + TVarRec(p^).VPChar := pointer(cp^); + end; + btClass: + begin + tvarrec(p^).VType := vtObject; + tvarrec(p^).VObject := Pointer(cp^); + end; +{$IFNDEF PS_NOINTERFACES} +{$IFDEF Delphi3UP} + btInterface: + begin + tvarrec(p^).VType := vtInterface; + IUnknown(tvarrec(p^).VInterface) := IUnknown(cp^); + end; + +{$ENDIF} +{$ENDIF} + end; + end; + datap := Pointer(IPointer(datap)+ (2*sizeof(Pointer)+sizeof(Longbool))); + p := PansiChar(p) + Result^.ElementSize; + end; +end; + +procedure DestroyOpenArray(Sender: TPSExec; V: POpenArray); +var + cp, datap: pointer; + ctype: TPSTypeRec; + p: PVarRec; + i: Longint; +begin + if v.FreeIt then // basetype = btPointer + begin + p := v^.Data; + if v.OrgVar.aType.BaseType = btStaticArray then + datap := v.OrgVar.Dta + else + datap := Pointer(v.OrgVar.Dta^); + for i := 0 to v^.ItemCount -1 do + begin + ctype := Pointer(Pointer(IPointer(datap)+PointerSize)^); + cp := Pointer(Datap^); + case ctype.BaseType of + btU8: + begin + if v^.varParam then + tbtu8(cp^) := tvarrec(p^).VInteger + end; + btS8: begin + if v^.varParam then + tbts8(cp^) := tvarrec(p^).VInteger + end; + btU16: begin + if v^.varParam then + tbtu16(cp^) := tvarrec(p^).VInteger + end; + btS16: begin + if v^.varParam then + tbts16(cp^) := tvarrec(p^).VInteger + end; + btU32: begin + if v^.varParam then + tbtu32(cp^) := tvarrec(p^).VInteger + end; + btS32: begin + if v^.varParam then + tbts32(cp^) := tvarrec(p^).VInteger + end; + btChar: begin + if v^.VarParam then + tbtchar(cp^) := tbtChar(tvarrec(p^).VChar) + end; + btSingle: begin + if v^.VarParam then + tbtsingle(cp^) := tvarrec(p^).vextended^; + dispose(tvarrec(p^).vextended); + end; + btDouble: begin + if v^.VarParam then + tbtdouble(cp^) := tvarrec(p^).vextended^; + dispose(tvarrec(p^).vextended); + end; + btExtended: begin + if v^.VarParam then + tbtextended(cp^) := tvarrec(p^).vextended^; + dispose(tvarrec(p^).vextended); + end; + {$IFNDEF PS_NOINT64} + btS64: begin + if v^.VarParam then + tbts64(cp^) := tvarrec(p^).vInt64^; + dispose(tvarrec(p^).VInt64); + end; + {$ENDIF} + {$IFNDEF PS_NOWIDESTRING} + btWideChar: begin + if v^.varParam then + tbtwidechar(cp^) := tvarrec(p^).VWideChar; + end; + {$IFDEF DELPHI2009UP} + btUnicodeString: + begin + if v^.VarParam then + tbtunicodestring(cp^) := tbtunicodestring(TVarRec(p^).VUnicodeString); + finalize(tbtunicodestring(TVarRec(p^).VUnicodeString)); + end; + {$ELSE} + btUnicodeString, + {$ENDIF} + btWideString: + begin + if v^.VarParam then + tbtwidestring(cp^) := tbtwidestring(TVarRec(p^).VWideString); + finalize(widestring(TVarRec(p^).VWideString)); + end; + {$ENDIF} + btString: begin + if v^.VarParam then + tbtstring(cp^) := tbtstring(TVarRec(p^).VString); + finalize(tbtString(TVarRec(p^).VAnsiString)); + end; + btClass: begin + if v^.VarParam then + Pointer(cp^) := TVarRec(p^).VObject; + end; +{$IFNDEF PS_NOINTERFACES} +{$IFDEF Delphi3UP} + btInterface: begin + if v^.VarParam then + IUnknown(cp^) := IUnknown(TVarRec(p^).VInterface); + finalize(tbtString(TVarRec(p^).VAnsiString)); + end; +{$ENDIF} +{$ENDIF} + end; + datap := Pointer(IPointer(datap)+ (2*sizeof(Pointer)+sizeof(LongBool))); + p := Pointer(IPointer(p) + Cardinal(v^.ElementSize)); + end; + FreeMem(v.Data, v.ElementSize * v.ItemCount); + end; + Dispose(V); +end; + + +{$ifndef FPC} + {$include x86.inc} +{$else} +{$IFDEF Delphi6UP} + {$if defined(cpu86)} + {$include x86.inc} + {$elseif defined(cpupowerpc)} + {$include powerpc.inc} + {$elseif defined(cpuarm)} + {$include arm.inc} + {$elseif defined(CPUX86_64)} + {$include x64.inc} + {$else} + {$fatal Pascal Script is not supported for your architecture at the moment!} + {$ifend} +{$ELSE} +{$include x86.inc} +{$ENDIF} +{$endif} + +type + PScriptMethodInfo = ^TScriptMethodInfo; + TScriptMethodInfo = record + Se: TPSExec; + ProcNo: Cardinal; + end; + + +function MkMethod(FSE: TPSExec; No: Cardinal): TMethod; +begin + if (no = 0) or (no = InvalidVal) then + begin + Result.Code := nil; + Result.Data := nil; + end else begin + Result.Code := @MyAllMethodsHandler; + Result.Data := GetMethodInfoRec(FSE, No); + end; +end; + + +procedure PFree(Sender: TPSExec; P: PScriptMethodInfo); +begin + Dispose(p); +end; + +function GetMethodInfoRec(SE: TPSExec; ProcNo: Cardinal): Pointer; +var + I: Longint; + pp: PScriptMethodInfo; +begin + if (ProcNo = 0) or (ProcNo = InvalidVal) then + begin + Result := nil; + exit; + end; + I := 2147483647; + repeat + pp := Se.FindProcResource2(@PFree, I); + if (i <> -1) and (pp^.ProcNo = ProcNo) then + begin + Result := Pp; + exit; + end; + until i = -1; + New(pp); + pp^.Se := TPSExec(Se); + pp^.ProcNo := Procno; + Se.AddResource(@PFree, pp); + Result := pp; +end; + + + + + +type + TPtrArr = array[0..1000] of Pointer; + PPtrArr = ^TPtrArr; + TByteArr = array[0..1000] of byte; + PByteArr = ^TByteArr; + PPointer = ^Pointer; + + +function VirtualMethodPtrToPtr(Ptr, FSelf: Pointer): Pointer; +{$IFDEF FPC} +var + x : PPtrArr; +{$ENDIF} +begin + {$IFDEF FPC} + x := Pointer(TObject(FSelf).ClassType) + vmtMethodStart; + Result := x^[Longint(Ptr)]; + {$ELSE} + Result := PPtrArr(PPointer(FSelf)^)^[Longint(Ptr)]; + {$ENDIF} +end; + +function VirtualClassMethodPtrToPtr(Ptr, FSelf: Pointer): Pointer; +{$IFDEF FPC} +var + x : PPtrArr; +{$ENDIF} +begin + {$IFDEF FPC} + x := Pointer(FSelf) + vmtMethodStart; + Result := x^[Longint(Ptr)]; + {$ELSE} + Result := PPtrArr(FSelf)^[Longint(Ptr)]; + {$ENDIF} +end; + + +procedure CheckPackagePtr(var P: PByteArr); +begin + if (word((@p[0])^) = $25FF) and (word((@p[6])^)=$C08B)then + begin + p := PPointer((@p[2])^)^; + end; +end; + +{$IFDEF VER90}{$DEFINE NO_vmtSelfPtr}{$ENDIF} +{$IFDEF FPC}{$DEFINE NO_vmtSelfPtr}{$ENDIF} + +{$IFNDEF FPC} + +function FindVirtualMethodPtr(Ret: TPSRuntimeClass; FClass: TClass; Ptr: Pointer): Pointer; +// Idea of getting the number of VMT items from GExperts +var + p: PPtrArr; + I: Longint; +begin + p := Pointer(FClass); + CheckPackagePtr(PByteArr(Ptr)); + if Ret.FEndOfVMT = MaxInt then + begin + I := {$IFDEF NO_vmtSelfPtr}-48{$ELSE}vmtSelfPtr{$ENDIF} div SizeOf(Pointer) + 1; + while I < 0 do + begin + if I < 0 then + begin + if I <> ({$IFDEF VER90}-44{$ELSE}vmtTypeInfo{$ENDIF} div SizeOf(Pointer)) then + begin // from GExperts code + if (IPointer(p^[I]) > IPointer(p)) and ((IPointer(p^[I]) - IPointer(p)) + div + PointerSize < Ret.FEndOfVMT) then + begin + Ret.FEndOfVMT := (IPointer(p^[I]) - IPointer(p)) div SizeOf(Pointer); + end; + end; + end; + Inc(I); + end; + if Ret.FEndOfVMT = MaxInt then + begin + Ret.FEndOfVMT := 0; // cound not find EndOfVMT + Result := nil; + exit; + end; + end; + I := 0; + while I < Ret.FEndOfVMT do + begin + if p^[I] = Ptr then + begin + Result := Pointer(I); + exit; + end; + I := I + 1; + end; + Result := nil; +end; + +{$ELSE} + +function FindVirtualMethodPtr(Ret: TPSRuntimeClass; FClass: TClass; Ptr: Pointer): Pointer; +var + x,p: PPtrArr; + I: Longint; + t : Pointer; +begin + p := Pointer(FClass) + vmtMethodStart; + I := 0; + while (p^[I]<>nil) and (I < 10000) do + begin + if p^[I] = Ptr then + begin + Result := Pointer(I); + x := Pointer(FClass) + vmtMethodStart; + t := x^[I]; + Assert(t=Ptr,'Computation of virtual method pointer fail : t<>Ptr'); + exit; + end; + I := I + 1; + end; + Result := nil; +end; + +{$ENDIF} + + +function NewTPSVariantIFC(avar: PPSVariant; varparam: boolean): TPSVariantIFC; +begin + Result.VarParam := varparam; + if avar = nil then + begin + Result.aType := nil; + result.Dta := nil; + end else + begin + Result.aType := avar.FType; + result.Dta := @PPSVariantData(avar).Data; + if Result.aType.BaseType = btPointer then + begin + Result.aType := Pointer(Pointer(IPointer(result.dta)+ PointerSize)^); + Result.Dta := Pointer(Result.dta^); + end; + end; +end; + +function NewTPSVariantRecordIFC(avar: PPSVariant; Fieldno: Longint): TPSVariantIFC; +var + offs: Cardinal; +begin + Result := NewTPSVariantIFC(avar, false); + if Result.aType.BaseType = btRecord then + begin + Offs := Cardinal(TPSTypeRec_Record(Result.aType).RealFieldOffsets[FieldNo]); + Result.Dta := Pointer(IPointer(Result.dta) + Offs); + Result.aType := TPSTypeRec_Record(Result.aType).FieldTypes[FieldNo]; + end else + begin + Result.Dta := nil; + Result.aType := nil; + end; +end; + +function PSGetArrayField(const avar: TPSVariantIFC; Fieldno: Longint): TPSVariantIFC; +var + offs: Cardinal; + n: Longint; +begin + Result := aVar; + case Result.aType.BaseType of + btStaticArray, btArray: + begin + if Result.aType.BaseType = btStaticArray then + n := TPSTypeRec_StaticArray(Result.aType).Size + else + n := PSDynArrayGetLength(Pointer(Result.Dta^), Result.aType); + if (FieldNo <0) or (FieldNo >= n) then + begin + Result.Dta := nil; + Result.aType := nil; + exit; + end; + Offs := TPSTypeRec_Array(Result.aType).ArrayType.RealSize * Cardinal(FieldNo); + if Result.aType.BaseType = btStaticArray then + Result.Dta := Pointer(IPointer(Result.dta) + Offs) + else + Result.Dta := Pointer(IPointer(Result.dta^) + Offs); + Result.aType := TPSTypeRec_Array(Result.aType).ArrayType; + end + else + Result.Dta := nil; + Result.aType := nil; + end; +end; + +function PSGetRecField(const avar: TPSVariantIFC; Fieldno: Longint): TPSVariantIFC; +var + offs: Cardinal; +begin + Result := aVar; + if Result.aType.BaseType = btRecord then + begin + Offs := Cardinal(TPSTypeRec_Record(Result.aType).RealFieldOffsets[FieldNo]); + Result.aType := TPSTypeRec_Record(Result.aType).FieldTypes[FieldNo]; + Result.Dta := Pointer(IPointer(Result.dta) + Offs); + end else + begin + Result.Dta := nil; + Result.aType := nil; + end; +end; + +function NewPPSVariantIFC(avar: PPSVariant; varparam: boolean): PPSVariantIFC; +begin + New(Result); + Result^ := NewTPSVariantIFC(avar, varparam); +end; + + +procedure DisposePPSVariantIFC(aVar: PPSVariantIFC); +begin + if avar <> nil then + Dispose(avar); +end; + +procedure DisposePPSVariantIFCList(list: TPSList); +var + i: Longint; +begin + for i := list.Count -1 downto 0 do + DisposePPSVariantIFC(list[i]); + list.free; +end; + +function ClassCallProcMethod(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +var + i: Integer; + MyList: TPSList; + n: PIFVariant; + v: PPSVariantIFC; + FSelf: Pointer; + CurrStack: Cardinal; + cc: TPSCallingConvention; + s: tbtString; +begin + s := p.Decl; + if length(S) < 2 then + begin + Result := False; + exit; + end; + cc := TPSCallingConvention(s[1]); + Delete(s, 1, 1); + if s[1] = #0 then + n := Stack[Stack.Count -1] + else + n := Stack[Stack.Count -2]; + if (n = nil) or (n^.FType.BaseType <> btClass)or (PPSVariantClass(n).Data = nil) then + begin + Caller.CMD_Err(erNullPointerException); + result := false; + exit; + end; + FSelf := PPSVariantClass(n).Data; + CurrStack := Cardinal(Stack.Count) - Cardinal(length(s)) -1; + if s[1] = #0 then inc(CurrStack); + MyList := TPSList.Create; + for i := 2 to length(s) do + begin + MyList.Add(nil); + end; + for i := length(s) downto 2 do + begin + n := Stack[CurrStack]; + MyList[i - 2] := NewPPSVariantIFC(n, s[i] <> #0); + inc(CurrStack); + end; + if s[1] <> #0 then + begin + v := NewPPSVariantIFC(Stack[CurrStack + 1], True); + end else v := nil; + try + if p.Ext2 = nil then + Result := Caller.InnerfuseCall(FSelf, p.Ext1, cc, MyList, v) + else + Result := Caller.InnerfuseCall(FSelf, VirtualMethodPtrToPtr(p.Ext1, FSelf), cc, MyList, v); + finally + DisposePPSVariantIFC(v); + DisposePPSVariantIFCList(mylist); + end; +end; + +function ClassCallProcConstructor(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +var + i, h: Longint; + v: PPSVariantIFC; + MyList: TPSList; + n: PIFVariant; + FSelf: Pointer; + CurrStack: Cardinal; + cc: TPSCallingConvention; + s: tbtString; + FType: PIFTypeRec; + x: TPSRuntimeClass; + IntVal: PIFVariant; +begin + n := Stack[Stack.Count -2]; + if (n = nil) or (n^.FType.BaseType <> btU32) then + begin + result := false; + exit; + end; + FType := Caller.GetTypeNo(PPSVariantU32(N).Data); + if (FType = nil) then + begin + Result := False; + exit; + end; + h := MakeHash(FType.ExportName); + FSelf := nil; + for i := 0 to TPSRuntimeClassImporter(p.Ext2).FClasses.Count -1 do + begin + x:= TPSRuntimeClassImporter(p.Ext2).FClasses[i]; + if (x.FClassNameHash = h) and (x.FClassName = FType.ExportName) then + begin + FSelf := x.FClass; + end; + end; + if FSelf = nil then begin + Result := False; + exit; + end; + s := p.Decl; + if length(S) < 2 then + begin + Result := False; + exit; + end; + cc := TPSCallingConvention(s[1]); + Delete(s, 1, 1); + CurrStack := Cardinal(Stack.Count) - Cardinal(length(s)) -1; + if s[1] = #0 then inc(CurrStack); + IntVal := CreateHeapVariant(Caller.FindType2(btU32)); + if IntVal = nil then + begin + Result := False; + exit; + end; + {$IFDEF FPC} + // under FPC a constructor it's called with self=0 (EAX) and + // the VMT class pointer in EDX so they are effectively swaped + // using register calling convention + PPSVariantU32(IntVal).Data := Cardinal(FSelf); + FSelf := pointer(1); + {$ELSE} + PPSVariantU32(IntVal).Data := 1; + {$ENDIF} + MyList := TPSList.Create; + MyList.Add(NewPPSVariantIFC(intval, false)); + for i := 2 to length(s) do + begin + MyList.Add(nil); + end; + for i := length(s) downto 2 do + begin + n :=Stack[CurrStack]; +// if s[i] <> #0 then +// begin +// MyList[i - 2] := NewPPSVariantIFC(n, s[i] <> #0); +// end; + MyList[i - 1] := NewPPSVariantIFC(n, s[i] <> #0); + inc(CurrStack); + end; + if s[1] <> #0 then + begin + v := NewPPSVariantIFC(Stack[CurrStack + 1], True); + end else v := nil; + try + Result := Caller.InnerfuseCall(FSelf, p.Ext1, TPSCallingConvention(Integer(cc) or 64), MyList, v); + finally + DisposePPSVariantIFC(v); + DisposePPSVariantIFCList(mylist); + DestroyHeapVariant(intval); + end; +end; + + +function ClassCallProcVirtualConstructor(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +var + i, h: Longint; + v: PPSVariantIFC; + MyList: TPSList; + n: PIFVariant; + FSelf: Pointer; + CurrStack: Cardinal; + cc: TPSCallingConvention; + s: tbtString; + FType: PIFTypeRec; + x: TPSRuntimeClass; + IntVal: PIFVariant; +begin + n := Stack[Stack.Count -2]; + if (n = nil) or (n^.FType.BaseType <> btU32) then + begin + Caller.CMD_Err(erNullPointerException); + result := false; + exit; + end; + FType := Caller.GetTypeNo(PPSVariantU32(N).Data); + if (FType = nil) then + begin + Caller.CMD_Err(erNullPointerException); + Result := False; + exit; + end; + h := MakeHash(FType.ExportName); + FSelf := nil; + for i := 0 to TPSRuntimeClassImporter(p.Ext2).FClasses.Count -1 do + begin + x:= TPSRuntimeClassImporter(p.Ext2).FClasses[i]; + if (x.FClassNameHash = h) and (x.FClassName = FType.ExportName) then + begin + FSelf := x.FClass; + end; + end; + if FSelf = nil then begin + Result := False; + exit; + end; + s := p.Decl; + if length(S) < 2 then + begin + Result := False; + exit; + end; + cc := TPSCallingConvention(s[1]); + delete(s, 1, 1); + CurrStack := Cardinal(Stack.Count) - Cardinal(length(s)) -1; + if s[1] = #0 then inc(CurrStack); + IntVal := CreateHeapVariant(Caller.FindType2(btU32)); + if IntVal = nil then + begin + Result := False; + exit; + end; + PPSVariantU32(IntVal).Data := 1; + MyList := TPSList.Create; + MyList.Add(NewPPSVariantIFC(intval, false)); + for i := 2 to length(s) do + begin + MyList.Add(nil); + end; + for i := length(s) downto 2 do + begin + n :=Stack[CurrStack]; + MyList[i - 1] := NewPPSVariantIFC(n, s[i] <> #0); + inc(CurrStack); + end; + if s[1] <> #0 then + begin + v := NewPPSVariantIFC(Stack[CurrStack + 1], True); + end else v := nil; + try + Result := Caller.InnerfuseCall(FSelf, VirtualClassMethodPtrToPtr(p.Ext1, FSelf), cc, MyList, v); + finally + DisposePPSVariantIFC(v); + DisposePPSVariantIFCList(mylist); + DestroyHeapVariant(intval); + end; +end; + +function CastProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +var + TypeNo, InVar, ResVar: TPSVariantIFC; + FSelf: TClass; + FType: PIFTypeRec; + H, I: Longint; + x: TPSRuntimeClass; +begin + TypeNo := NewTPSVariantIFC(Stack[Stack.Count-3], false); + InVar := NewTPSVariantIFC(Stack[Stack.Count-2], false); + ResVar := NewTPSVariantIFC(Stack[Stack.Count-1], true); + if (TypeNo.Dta = nil) or (InVar.Dta = nil) or (ResVar.Dta = nil) or + (TypeNo.aType.BaseType <> btu32) or (resvar.aType <> Caller.FTypes[tbtu32(Typeno.dta^)]) + then + begin + Result := False; + Exit; + end; +{$IFNDEF PS_NOINTERFACES} + if (invar.atype.BaseType = btInterface) and (resvar.aType.BaseType = btInterface) then + begin +{$IFNDEF Delphi3UP} + if IUnknown(resvar.Dta^) <> nil then + IUnknown(resvar.Dta^).Release; +{$ENDIF} + IUnknown(resvar.Dta^) := nil; + if (IUnknown(invar.Dta^) = nil) or (IUnknown(invar.Dta^).QueryInterface(TPSTypeRec_Interface(ResVar.aType).Guid, IUnknown(resvar.Dta^)) <> 0) then + begin + Caller.CMD_Err2(erCustomError, tbtString(RPS_CannotCastInterface)); + Result := False; + exit; + end; +{$IFDEF Delphi3UP} + end else if (Invar.aType.BaseType = btclass) and (resvar.aType.BaseType = btInterface) then + begin +{$IFNDEF Delphi3UP} + if IUnknown(resvar.Dta^) <> nil then + IUnknown(resvar.Dta^).Release; +{$ENDIF} + IUnknown(resvar.Dta^) := nil; + if (TObject(invar.Dta^)= nil) or (not TObject(invar.dta^).GetInterface(TPSTypeRec_Interface(ResVar.aType).Guid, IUnknown(resvar.Dta^))) then + begin + Caller.CMD_Err2(erCustomError, tbtString(RPS_CannotCastInterface)); + Result := False; + exit; + end; +{$ENDIF} + end else {$ENDIF}if (invar.aType.BaseType = btclass) and (resvar.aType.BaseType = btclass ) then + begin + FType := Caller.GetTypeNo(tbtu32(TypeNo.Dta^)); + if (FType = nil) then + begin + Result := False; + exit; + end; + h := MakeHash(FType.ExportName); + FSelf := nil; + for i := 0 to TPSRuntimeClassImporter(p.Ext2).FClasses.Count -1 do + begin + x:= TPSRuntimeClassImporter(p.Ext2).FClasses[i]; + if (x.FClassNameHash = h) and (x.FClassName = FType.ExportName) then + begin + FSelf := x.FClass; + end; + end; + if FSelf = nil then begin + Result := False; + exit; + end; + + try + TObject(ResVar.Dta^) := TObject(InVar.Dta^) as FSelf; + except + Result := False; + Caller.CMD_Err2(erCustomError, tbtString(RPS_CannotCastObject)); + exit; + end; + end else + begin + Result := False; + exit; + end; + result := True; +end; + + +function NilProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +var + n: TPSVariantIFC; +begin + n := NewTPSVariantIFC(Stack[Stack.Count-1], True); + if (n.Dta = nil) or ((n.aType.BaseType <> btClass) and (n.aType.BaseType <> btInterface)) then + begin + Result := False; + Caller.CMD_Err(erNullPointerException); + Exit; + end; +{$IFNDEF PS_NOINTERFACES} + if n.aType.BaseType = btInterface then + begin + {$IFNDEF Delphi3UP} + if IUnknown(n.Dta^) <> nil then + IUnknown(n.Dta^).Release; + {$ENDIF} + IUnknown(n.Dta^) := nil; + end else + {$ENDIF} + Pointer(n.Dta^) := nil; + result := True; +end; +function IntfCallProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +var + i: Integer; + MyList: TPSList; + n: TPSVariantIFC; + n2: PPSVariantIFC; + FSelf: Pointer; + CurrStack: Cardinal; + cc: TPSCallingConvention; + s: tbtString; +begin + s := p.Decl; + if length(S) < 2 then + begin + Result := False; + exit; + end; + cc := TPSCallingConvention(s[1]); + Delete(s, 1, 1); + if s[1] = #0 then + n := NewTPSVariantIFC(Stack[Stack.Count -1], false) + else + n := NewTPSVariantIFC(Stack[Stack.Count -2], false); + if (n.dta = nil) or (n.atype.BaseType <> btInterface) or (Pointer(n.Dta^) = nil) then + begin + Caller.CMD_Err(erNullPointerException); + result := false; + exit; + end; + FSelf := Pointer(n.dta^); + CurrStack := Cardinal(Stack.Count) - Cardinal(length(s)) -1; + if s[1] = #0 then inc(CurrStack); + MyList := TPSList.Create; + for i := 2 to length(s) do + begin + MyList.Add(nil); + end; + for i := length(s) downto 2 do + begin + MyList[i - 2] := NewPPSVariantIFC(Stack[CurrStack], s[i] <> #0); + inc(CurrStack); + end; + if s[1] <> #0 then + begin + n2 := NewPPSVariantIFC(Stack[CurrStack + 1], True); + end else n2 := nil; + try + Caller.InnerfuseCall(FSelf, Pointer(Pointer(IPointer(FSelf^) + (Cardinal(p.Ext1) * Sizeof(Pointer)))^), cc, MyList, n2); + result := true; + finally + DisposePPSVariantIFC(n2); + DisposePPSVariantIFCList(MyList); + end; +end; + + +function InterfaceProc(Sender: TPSExec; p: TPSExternalProcRec; Tag: Pointer): Boolean; +var + s: tbtString; +begin + s := p.Decl; + delete(s,1,5); // delete 'intf:' + if s = '' then + begin + Result := False; + exit; + end; + if s[1] = '.'then + begin + Delete(s,1,1); + if length(S) < 6 then + begin + Result := False; + exit; + end; + p.ProcPtr := IntfCallProc; + p.Ext1 := Pointer((@s[1])^); // Proc Offset + Delete(s,1,4); + P.Decl := s; + Result := True; + end else Result := False; +end; + + +function getMethodNo(P: TMethod; SE: TPSExec): Cardinal; +begin + if (p.Code <> @MyAllMethodsHandler) or (p.Data = nil)or (PScriptMethodInfo(p.Data)^.Se <> se) then + Result := 0 + else + begin + Result := PScriptMethodInfo(p.Data)^.ProcNo; + end; +end; + +function ClassCallProcProperty(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +var + n: TPSVariantIFC; + ltemp: Longint; + FSelf: Pointer; + m: TMethod; +begin + try + if p.Ext2 = Pointer(0) then + begin + n := NewTPSVariantIFC(Stack[Stack.Count -1], False); + if (n.Dta = nil) or (n.aType.BaseType <> btclass) then + begin + result := false; + Caller.CMD_Err(erNullPointerException); + exit; + end; + FSelf := Pointer(n.dta^); + if FSelf = nil then + begin + Caller.CMD_Err(erCouldNotCallProc); + Result := False; + exit; + end; + n := NewTPSVariantIFC(Stack[Stack.Count -2], false); + if (PPropInfo(p.Ext1)^.PropType^.Kind = tkMethod) and ((n.aType.BaseType = btu32) or (n.aType.BaseType = btProcPtr))then + begin + SetMethodProp(TObject(FSelf), PPropInfo(p.Ext1), MkMethod(Caller, tbtu32(n.dta^))); + end else + case n.aType.BaseType of + btSet: + begin + ltemp := 0; + move(Byte(n.Dta^), ltemp, TPSTypeRec_Set(n.aType).aByteSize); + SetOrdProp(TObject(FSelf), PPropInfo(p.Ext1), ltemp); + end; + btChar, btU8: SetOrdProp(TObject(FSelf), PPropInfo(p.Ext1), tbtu8(n.Dta^)); + btS8: SetOrdProp(TObject(FSelf), PPropInfo(p.Ext1), tbts8(n.Dta^)); + {$IFNDEF PS_NOWIDESTRING}btwidechar, {$ENDIF}btU16: SetOrdProp(TObject(FSelf), PPropInfo(p.Ext1), tbtu16(n.Dta^)); + btS16: SetOrdProp(TObject(FSelf), PPropInfo(p.Ext1), tbts16(n.Dta^)); + btU32: SetOrdProp(TObject(FSelf), PPropInfo(p.Ext1), tbtu32(n.Dta^)); + btS32: SetOrdProp(TObject(FSelf), PPropInfo(p.Ext1), tbts32(n.Dta^)); + btSingle: SetFloatProp(TObject(FSelf), p.Ext1, tbtsingle(n.Dta^)); + btDouble: SetFloatProp(TObject(FSelf), p.Ext1, tbtdouble(n.Dta^)); + btExtended: SetFloatProp(TObject(FSelf), p.Ext1, tbtextended(n.Dta^)); + btString: SetStrProp(TObject(FSelf), p.Ext1, string(tbtString(n.Dta^))); + btPChar: SetStrProp(TObject(FSelf), p.Ext1, string(pansichar(n.Dta^))); + btClass: SetOrdProp(TObject(FSelf), P.Ext1, Longint(n.Dta^)); + {$IFDEF DELPHI6UP} +{$IFNDEF PS_NOWIDESTRING} +{$IFNDEF DELPHI2009UP}btUnicodeString,{$ENDIF} + btWideString: SetWideStrProp(TObject(FSelf), P.Ext1, tbtWidestring(n.dta^)); +{$IFDEF DELPHI2009UP} + btUnicodeString: SetUnicodeStrProp(TObject(FSelf), P.Ext1, tbtUnicodestring(n.dta^)); +{$ENDIF} + {$ENDIF} +{$ENDIF} + else + begin + Result := False; + exit; + end; + end; + Result := true; + end else begin + n := NewTPSVariantIFC(Stack[Stack.Count -2], False); + if (n.dta = nil) or (n.aType.BaseType <> btClass)then + begin + result := false; + Caller.CMD_Err(erNullPointerException); + exit; + end; + FSelf := Pointer(n.dta^); + if FSelf = nil then + begin + Caller.CMD_Err(erCouldNotCallProc); + Result := False; + exit; + end; + n := NewTPSVariantIFC(Stack[Stack.Count -1], false); + if (PPropInfo(p.Ext1)^.PropType^.Kind = tkMethod) and ((n.aType.BaseType = btu32) or (n.aType.BaseType = btprocptr)) then + begin + m := GetMethodProp(TObject(FSelf), PPropInfo(p.Ext1)); + Cardinal(n.Dta^) := GetMethodNo(m, Caller); + if Cardinal(n.dta^) = 0 then + begin + Pointer(Pointer((IPointer(n.dta)+PointerSize))^) := m.Data; + Pointer(Pointer((IPointer(n.dta)+PointerSize2))^) := m.Code; + end; + end else + case n.aType.BaseType of + btSet: + begin + ltemp := GetOrdProp(TObject(FSelf), PPropInfo(p.Ext1)); + move(ltemp, Byte(n.Dta^), TPSTypeRec_Set(n.aType).aByteSize); + end; + btU8: tbtu8(n.Dta^) := GetOrdProp(TObject(FSelf), p.Ext1); + btS8: tbts8(n.Dta^) := GetOrdProp(TObject(FSelf), p.Ext1); + btU16: tbtu16(n.Dta^) := GetOrdProp(TObject(FSelf), p.Ext1); + btS16: tbts16(n.Dta^) := GetOrdProp(TObject(FSelf), p.Ext1); + btU32: tbtu32(n.Dta^) := GetOrdProp(TObject(FSelf), p.Ext1); + btS32: tbts32(n.Dta^) := GetOrdProp(TObject(FSelf), p.Ext1); + btSingle: tbtsingle(n.Dta^) := GetFloatProp(TObject(FSelf), p.Ext1); + btDouble: tbtdouble(n.Dta^) := GetFloatProp(TObject(FSelf), p.Ext1); + btExtended: tbtextended(n.Dta^) := GetFloatProp(TObject(FSelf), p.Ext1); + btString: tbtString(n.Dta^) := tbtString(GetStrProp(TObject(FSelf), p.Ext1)); + btClass: Longint(n.dta^) := GetOrdProp(TObject(FSelf), p.Ext1); + {$IFDEF DELPHI6UP} +{$IFNDEF PS_NOWIDESTRING} + {$IFDEF DELPHI2009UP} + btUnicodeString: tbtUnicodeString(n.dta^) := GetUnicodeStrProp(TObject(FSelf), P.Ext1); + {$ELSE} + btUnicodeString, + {$ENDIF} + btWideString: tbtWidestring(n.dta^) := GetWideStrProp(TObject(FSelf), P.Ext1); +{$ENDIF} +{$ENDIF} + else + begin + Result := False; + exit; + end; + end; + Result := True; + end; + finally + end; +end; + +function ClassCallProcPropertyHelper(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +var + I, ParamCount: Longint; + Params: TPSList; + n: TPSVariantIFC; + FSelf: Pointer; +begin + if Length(P.Decl) < 4 then begin + Result := False; + exit; + end; + ParamCount := Longint((@P.Decl[1])^); + if Longint(Stack.Count) < ParamCount +1 then begin + Result := False; + exit; + end; + Dec(ParamCount); + if p.Ext1 <> nil then // read + begin + n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 2], False); + if (n.Dta = nil) or (n.aType.BaseType <> btClass) then + begin + result := false; + Caller.CMD_Err(erNullPointerException); + exit; + end; + FSelf := pointer(n.Dta^); + if FSelf = nil then + begin + Caller.CMD_Err(erCouldNotCallProc); + Result := False; + exit; + end; + Params := TPSList.Create; + Params.Add(NewPPSVariantIFC(Stack[Longint(Stack.Count) - 1], True)); + for i := Stack.Count -3 downto Longint(Stack.Count) - ParamCount -2 do + begin + Params.Add(NewPPSVariantIFC(Stack[I], False)); + end; + try + Result := Caller.InnerfuseCall(FSelf, p.Ext1, cdRegister, Params, nil); + finally + DisposePPSVariantIFCList(Params); + end; + end else begin + n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 1], False); + if (n.Dta = nil) or (n.aType.BaseType <> btClass) then + begin + result := false; + Caller.CMD_Err(erNullPointerException); + exit; + end; + FSelf := pointer(n.Dta^); + if FSelf = nil then + begin + Caller.CMD_Err(erCouldNotCallProc); + Result := False; + exit; + end; + Params := TPSList.Create; + Params.Add(NewPPSVariantIFC(Stack[Longint(Stack.Count) - ParamCount - 2], False)); + + for i := Stack.Count -2 downto Longint(Stack.Count) - ParamCount -1 do + begin + Params.Add(NewPPSVariantIFC(Stack[I], False)); + end; + try + Result := Caller.InnerfuseCall(FSelf, p.Ext2, cdregister, Params, nil); + finally + DisposePPSVariantIFCList(Params); + end; + end; +end; + +function ClassCallProcPropertyHelperName(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +var + I, ParamCount: Longint; + Params: TPSList; + tt: PIFVariant; + n: TPSVariantIFC; + FSelf: Pointer; +begin + if Length(P.Decl) < 4 then begin + Result := False; + exit; + end; + ParamCount := Longint((@P.Decl[1])^); + if Longint(Stack.Count) < ParamCount +1 then begin + Result := False; + exit; + end; + Dec(ParamCount); + if p.Ext1 <> nil then // read + begin + n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 2], false); + if (n.Dta = nil) or (n.aType.BaseType <> btClass) then + begin + result := false; + Caller.CMD_Err(erNullPointerException); + exit; + end; + FSelf := Tobject(n.dta^); + Params := TPSList.Create; + Params.Add(NewPPSVariantIFC(Stack[Longint(Stack.Count) - 1], True)); + for i := Stack.Count -3 downto Longint(Stack.Count) - ParamCount -2 do + Params.Add(NewPPSVariantIFC(Stack[I], False)); + tt := CreateHeapVariant(Caller.FindType2(btString)); + if tt <> nil then + begin + PPSVariantAString(tt).Data := p.Name; + Params.Add(NewPPSVariantIFC(tt, false)); + end; + try + Result := Caller.InnerfuseCall(FSelf, p.Ext1, cdRegister, Params, nil); + finally + DestroyHeapVariant(tt); + DisposePPSVariantIFCList(Params); + end; + end else begin + n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 1], false); + if (n.Dta = nil) or (n.aType.BaseType <> btClass) then + begin + result := false; + Caller.CMD_Err(erNullPointerException); + exit; + end; + FSelf := Tobject(n.dta^); + Params := TPSList.Create; + Params.Add(NewPPSVariantIFC(Stack[Longint(Stack.Count) - 2], True)); + + for i := Stack.Count -2 downto Longint(Stack.Count) - ParamCount -1 do + begin + Params.Add(NewPPSVariantIFC(Stack[I], false)); + end; + tt := CreateHeapVariant(Caller.FindType2(btString)); + if tt <> nil then + begin + PPSVariantAString(tt).Data := p.Name; + Params.Add(NewPPSVariantIFC(tt, false)); + end; + try + Result := Caller.InnerfuseCall(FSelf, p.Ext2, cdregister, Params, nil); + finally + DestroyHeapVariant(tt); + DisposePPSVariantIFCList(Params); + end; + end; +end; + + + +function ClassCallProcEventPropertyHelper(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +{Event property helper} +var + I, ParamCount: Longint; + Params: TPSList; + n: TPSVariantIFC; + data: TMethod; + n2: PIFVariant; + FSelf: Pointer; +begin + if Length(P.Decl) < 4 then begin + Result := False; + exit; + end; + ParamCount := Longint((@P.Decl[1])^); + if Longint(Stack.Count) < ParamCount +1 then begin + Result := False; + exit; + end; + Dec(ParamCount); + if p.Ext1 <> nil then // read + begin + n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 2], false); + if (n.Dta = nil) or (n.aType.BaseType <> btClass) then + begin + result := false; + Caller.CMD_Err(erNullPointerException); + exit; + end; + FSelf := Tobject(n.dta^); + n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 1], True); // Result + if (n.aType.BaseType <> btU32) and (n.aType.BaseType <> btProcPtr) then + begin + Result := False; + Caller.CMD_Err(erNullPointerException); + exit; + end; + n2 := CreateHeapVariant(Caller.FindType2(btPChar)); + if n2 = nil then + begin + Result := False; + exit; + end; + Params := TPSList.Create; +//{$IFDEF CPU64} +//{$ELSE} + data.Code := nil; + data.Data := nil; +//{$ENDIF} + PPSVariantDynamicArray(n2)^.Data:= @data; + Params.Add(NewPPSVariantIFC(n2, false)); + for i := Stack.Count -3 downto Longint(Stack.Count) - ParamCount -2 do + Params.Add(NewPPSVariantIFC(Stack[i], False)); + try + Result := Caller.InnerfuseCall(FSelf, p.Ext1, cdRegister, Params, nil); + finally + Cardinal(n.Dta^) := getMethodNo(data, Caller); + if Cardinal(n.Dta^) = 0 then + begin + Pointer(Pointer((IPointer(n.dta)+PointerSize))^) := data.Data; + Pointer(Pointer((IPointer(n.dta)+PointerSize2))^) := data.Code; + end; + DestroyHeapVariant(n2); + DisposePPSVariantIFCList(Params); + end; + end else begin + n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 1], false); + if (n.Dta = nil) or (n.aType.BaseType <> btClass) then + begin + result := false; + Caller.CMD_Err(erNullPointerException); + exit; + end; + FSelf := Tobject(n.dta^); + n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 2], false); + if (n.Dta = nil) or ((n.aType.BaseType <> btu32) and (n.aType.BaseType <> btProcPtr)) then + begin + result := false; + Caller.CMD_Err(erNullPointerException); + exit; + end; + n2 := CreateHeapVariant(Caller.FindType2(btPchar)); + if n2 = nil then + begin + Result := False; + exit; + end; + + if (n.aType.BaseType = btProcPtr) and (cardinal(n.dta^) = 0) then + data := TMethod(Pointer(IPointer(n.dta^)+4)^) + else + data := MkMethod(Caller, cardinal(n.dta^)); + Params := TPSList.Create; + Params.Add(NewPPSVariantIFC(n2, False)); + + for i := Stack.Count -2 downto Longint(Stack.Count) - ParamCount -1 do + begin + Params.Add(NewPPSVariantIFC(Stack[I], False)); + end; + try + Result := Caller.InnerfuseCall(FSelf, p.Ext2, cdregister, Params, nil); + finally + DestroyHeapVariant(n2); + DisposePPSVariantIFCList(Params); + end; + end; +end; + + +{'class:'+CLASSNAME+'|'+FUNCNAME+'|'+chr(CallingConv)+chr(hasresult)+params + +For property write functions there is an '@' after the funcname. +} +function SpecImport(Sender: TPSExec; p: TPSExternalProcRec; Tag: Pointer): Boolean; +var + H, I: Longint; + S, s2: tbtString; + CL: TPSRuntimeClass; + Px: PClassItem; + pp: PPropInfo; + IsRead: Boolean; +begin + s := p.Decl; + delete(s, 1, 6); + if s = '-' then {nil function} + begin + p.ProcPtr := NilProc; + Result := True; + exit; + end; + if s = '+' then {cast function} + begin + p.ProcPtr := CastProc; + p.Ext2 := Tag; + Result := True; + exit; + end; + s2 := copy(S, 1, pos(tbtchar('|'), s)-1); + delete(s, 1, length(s2) + 1); + H := MakeHash(s2); + ISRead := False; + cl := nil; + for I := TPSRuntimeClassImporter(Tag).FClasses.Count -1 downto 0 do + begin + Cl := TPSRuntimeClassImporter(Tag).FClasses[I]; + if (Cl.FClassNameHash = h) and (cl.FClassName = s2) then + begin + IsRead := True; + break; + end; + end; + if not isRead then begin + Result := False; + exit; + end; + s2 := copy(S, 1, pos(tbtchar('|'), s)-1); + delete(s, 1, length(s2) + 1); + if (s2 <> '') and (s2[length(s2)] = '@') then + begin + IsRead := False; + Delete(S2, length(s2), 1); + end else + isRead := True; + p.Name := s2; + H := MakeHash(s2); + for i := cl.FClassItems.Count -1 downto 0 do + begin + px := cl.FClassItems[I]; + if (px^.FNameHash = h) and (px^.FName = s2) then + begin + p.Decl := s; + case px^.b of + {0: ext1=ptr} + {1: ext1=pointerinlist} + {2: ext1=propertyinfo} + {3: ext1=readfunc; ext2=writefunc} + 4: + begin + p.ProcPtr := ClassCallProcConstructor; + p.Ext1 := px^.Ptr; + if p.Ext1 = nil then begin result := false; exit; end; + p.Ext2 := Tag; + end; + 5: + begin + p.ProcPtr := ClassCallProcVirtualConstructor; + p.Ext1 := px^.Ptr; + if p.Ext1 = nil then begin result := false; exit; end; + p.Ext2 := Tag; + end; + 6: + begin + p.ProcPtr := ClassCallProcEventPropertyHelper; + if IsRead then + begin + p.Ext1 := px^.FReadFunc; + if p.Ext1 = nil then begin result := false; exit; end; + p.Ext2 := nil; + end else + begin + p.Ext1 := nil; + p.Ext2 := px^.FWriteFunc; + if p.Ext2 = nil then begin result := false; exit; end; + end; + end; + 0: + begin + p.ProcPtr := ClassCallProcMethod; + p.Ext1 := px^.Ptr; + if p.Ext1 = nil then begin result := false; exit; end; + p.Ext2 := nil; + end; + 1: + begin + p.ProcPtr := ClassCallProcMethod; + p.Ext1 := px^.PointerInList; + //if p.Ext1 = nil then begin result := false; exit; end; + p.ext2 := pointer(1); + end; + 3: + begin + p.ProcPtr := ClassCallProcPropertyHelper; + if IsRead then + begin + p.Ext1 := px^.FReadFunc; + if p.Ext1 = nil then begin result := false; exit; end; + p.Ext2 := nil; + end else + begin + p.Ext1 := nil; + p.Ext2 := px^.FWriteFunc; + if p.Ext2 = nil then begin result := false; exit; end; + end; + end; + 7: + begin + p.ProcPtr := ClassCallProcPropertyHelperName; + if IsRead then + begin + p.Ext1 := px^.FReadFunc; + if p.Ext1 = nil then begin result := false; exit; end; + p.Ext2 := nil; + end else + begin + p.Ext1 := nil; + p.Ext2 := px^.FWriteFunc; + if p.Ext2 = nil then begin result := false; exit; end; + end; + end; + else + begin + result := false; + exit; + end; + end; + Result := true; + exit; + end; + end; + if cl.FClass.ClassInfo <> nil then + begin + pp := GetPropInfo(cl.FClass.ClassInfo, string(s2)); + if pp <> nil then + begin + p.ProcPtr := ClassCallProcProperty; + p.Ext1 := pp; + if IsRead then + p.Ext2 := Pointer(1) + else + p.Ext2 := Pointer(0); + Result := True; + end else + result := false; + end else + Result := False; +end; + +procedure RegisterClassLibraryRuntime(SE: TPSExec; Importer: TPSRuntimeClassImporter); +begin + SE.AddSpecialProcImport('class', SpecImport, Importer); +end; + + +procedure TPSExec.ClearspecialProcImports; +var + I: Longint; + P: PSpecialProc; +begin + for I := FSpecialProcList.Count -1 downto 0 do + begin + P := FSpecialProcList[I]; + Dispose(p); + end; + FSpecialProcList.Clear; +end; + +procedure TPSExec.RaiseCurrentException; +var + ExObj: TObject; +begin + if ExEx = erNoError then exit; // do nothing + ExObj := Self.ExObject; + if ExObj <> nil then + begin + Self.ExObject := nil; + raise ExObj; + end; + raise EPSException.Create(PSErrorToString(ExceptionCode, ExceptionString), Self, ExProc, ExPos); +end; + +procedure TPSExec.CMD_Err2(EC: TPSError; const Param: tbtString); +begin + CMD_Err3(EC, Param, Nil); +end; + +function TPSExec.GetProcAsMethod(const ProcNo: Cardinal): TMethod; +begin + Result := MkMethod(Self, ProcNo); +end; + +function TPSExec.GetProcAsMethodN(const ProcName: tbtString): TMethod; +var + procno: Cardinal; +begin + Procno := GetProc(ProcName); + if Procno = InvalidVal then + begin + Result.Code := nil; + Result.Data := nil; + end + else + Result := MkMethod(Self, procno) +end; + + +procedure TPSExec.RegisterAttributeType(useproc: TPSAttributeUseProc; + const TypeName: tbtString); +var + att: TPSAttributeType; +begin + att := TPSAttributeType.Create; + att.TypeName := TypeName; + att.TypeNameHash := MakeHash(TypeName); + att.UseProc := UseProc; + FAttributeTypes.Add(att); +end; + +function TPSExec.GetProcCount: Cardinal; +begin + Result := FProcs.Count; +end; + +function TPSExec.GetTypeCount: Longint; +begin + Result := FTypes.Count; +end; + +function TPSExec.GetVarCount: Longint; +begin + Result := FGlobalVars.Count; +end; + +function TPSExec.FindSpecialProcImport( + P: TPSOnSpecialProcImport): pointer; +var + i: Longint; + pr: PSpecialProc; +begin + for i := FSpecialProcList.Count -1 downto 0 do + begin + pr := FSpecialProcList[i]; + if @pr.P = @p then + begin + Result := pr.tag; + exit; + end; + end; + result := nil; +end; + +function TPSExec.InvokeExternalMethod(At: TPSTypeRec_ProcPtr; Slf, + Ptr: Pointer): Boolean; +var + res: PPSVariantIFC; + s: tbtString; + CurrStack, i: Longint; + n: PPSVariant; + MyList: TPSList; +begin + s := TPSTypeRec_ProcPtr(at).ParamInfo; + CurrStack := Cardinal(FStack.Count) - Cardinal(length(s)); + if s[1] = #0 then inc(CurrStack); + MyList := TPSList.Create; + for i := 2 to length(s) do + begin + MyList.Add(nil); + end; + for i := length(s) downto 2 do + begin + n := FStack[CurrStack]; + MyList[i - 2] := NewPPSVariantIFC(n, s[i] <> #0); + inc(CurrStack); + end; + if s[1] <> #0 then + begin + res := NewPPSVariantIFC(FStack[CurrStack + 1], True); + end else res := nil; + Result := InnerfuseCall(Slf, Ptr, cdRegister, MyList, Res); + + DisposePPSVariantIFC(res); + DisposePPSVariantIFCList(mylist); +end; + +function TPSExec.LastEx: TPSError; +var + pp: TPSExceptionHandler; +begin + if FExceptionStack.Count = 0 then begin + result := ExEx; + exit; + end; + pp := fExceptionStack[fExceptionStack.Count-1]; + result := pp.ExceptionData; +end; + +function TPSExec.LastExParam: tbtString; +begin + result := ExParam; +end; + +function TPSExec.LastExPos: Integer; +begin + result := ExPos; +end; + +function TPSExec.LastExProc: Integer; +begin + result := exProc; +end; + +{ TPSRuntimeClass } + +constructor TPSRuntimeClass.Create(aClass: TClass; const AName: tbtString); +begin + inherited Create; + FClass := AClass; + if AName = '' then + begin + FClassName := FastUpperCase(tbtString(aClass.ClassName)); + FClassNameHash := MakeHash(FClassName); + end else begin + FClassName := FastUppercase(AName); + FClassNameHash := MakeHash(FClassName); + end; + FClassItems:= TPSList.Create; + FEndOfVmt := MaxInt; +end; + +destructor TPSRuntimeClass.Destroy; +var + I: Longint; + P: PClassItem; +begin + for i:= FClassItems.Count -1 downto 0 do + begin + P := FClassItems[I]; + Dispose(p); + end; + FClassItems.Free; + inherited Destroy; +end; + +procedure TPSRuntimeClass.RegisterVirtualAbstractMethod(ClassDef: TClass; + ProcPtr: Pointer; const Name: tbtString); +var + P: PClassItem; +begin + New(P); + p^.FName := FastUppercase(Name); + p^.FNameHash := MakeHash(p^.FName); + p^.b := 1; + p^.PointerInList := FindVirtualMethodPtr(Self, ClassDef, ProcPtr); + FClassItems.Add(p); +end; + +procedure TPSRuntimeClass.RegisterConstructor(ProcPtr: Pointer; + const Name: tbtString); +var + P: PClassItem; +begin + New(P); + p^.FName := FastUppercase(Name); + p^.FNameHash := MakeHash(p^.FName); + p^.b := 4; + p^.Ptr := ProcPtr; + FClassItems.Add(p); +end; + +procedure TPSRuntimeClass.RegisterMethod(ProcPtr: Pointer; const Name: tbtString); +var + P: PClassItem; +begin + New(P); + p^.FName := FastUppercase(Name); + p^.FNameHash := MakeHash(p^.FName); + p^.b := 0; + p^.Ptr := ProcPtr; + FClassItems.Add(p); +end; + + +procedure TPSRuntimeClass.RegisterPropertyHelper(ReadFunc, + WriteFunc: Pointer; const Name: tbtString); +var + P: PClassItem; +begin + New(P); + p^.FName := FastUppercase(Name); + p^.FNameHash := MakeHash(p^.FName); + p^.b := 3; + p^.FReadFunc := ReadFunc; + p^.FWriteFunc := WriteFunc; + FClassItems.Add(p); +end; + +procedure TPSRuntimeClass.RegisterVirtualConstructor(ProcPtr: Pointer; + const Name: tbtString); +var + P: PClassItem; +begin + New(P); + p^.FName := FastUppercase(Name); + p^.FNameHash := MakeHash(p^.FName); + p^.b := 5; + p^.PointerInList := FindVirtualMethodPtr(Self, FClass, ProcPtr); + FClassItems.Add(p); +end; + +procedure TPSRuntimeClass.RegisterVirtualMethod(ProcPtr: Pointer; const Name: tbtString); +var + P: PClassItem; +begin + New(P); + p^.FName := FastUppercase(Name); + p^.FNameHash := MakeHash(p^.FName); + p^.b := 1; + p^.PointerInList := FindVirtualMethodPtr(Self, FClass, ProcPtr); + FClassItems.Add(p); +end; + +procedure TPSRuntimeClass.RegisterEventPropertyHelper(ReadFunc, + WriteFunc: Pointer; const Name: tbtString); +var + P: PClassItem; +begin + New(P); + p^.FName := FastUppercase(Name); + p^.FNameHash := MakeHash(p^.FName); + p^.b := 6; + p^.FReadFunc := ReadFunc; + p^.FWriteFunc := WriteFunc; + FClassItems.Add(p); +end; + + +procedure TPSRuntimeClass.RegisterPropertyHelperName(ReadFunc, + WriteFunc: Pointer; const Name: tbtString); +var + P: PClassItem; +begin + New(P); + p^.FName := FastUppercase(Name); + p^.FNameHash := MakeHash(p^.FName); + p^.b := 7; + p^.FReadFunc := ReadFunc; + p^.FWriteFunc := WriteFunc; + FClassItems.Add(p); +end; + +{ TPSRuntimeClassImporter } + +function TPSRuntimeClassImporter.Add(aClass: TClass): TPSRuntimeClass; +begin + Result := FindClass(tbtstring(aClass.ClassName)); + if Result <> nil then exit; + Result := TPSRuntimeClass.Create(aClass, ''); + FClasses.Add(Result); +end; + +function TPSRuntimeClassImporter.Add2(aClass: TClass; + const Name: tbtString): TPSRuntimeClass; +begin + Result := FindClass(Name); + if Result <> nil then exit; + Result := TPSRuntimeClass.Create(aClass, Name); + FClasses.Add(Result); +end; + +procedure TPSRuntimeClassImporter.Clear; +var + I: Longint; +begin + for i := 0 to FClasses.Count -1 do + begin + TPSRuntimeClass(FClasses[I]).Free; + end; + FClasses.Clear; +end; + +constructor TPSRuntimeClassImporter.Create; +begin + inherited Create; + FClasses := TPSList.Create; + +end; + +constructor TPSRuntimeClassImporter.CreateAndRegister(Exec: TPSexec; + AutoFree: Boolean); +begin + inherited Create; + FClasses := TPSList.Create; + RegisterClassLibraryRuntime(Exec, Self); + if AutoFree then + Exec.AddResource(@RCIFreeProc, Self); +end; + +destructor TPSRuntimeClassImporter.Destroy; +begin + Clear; + FClasses.Free; + inherited Destroy; +end; + +{$IFNDEF PS_NOINTERFACES} +procedure SetVariantToInterface(V: PIFVariant; Cl: IUnknown); +begin + if (v <> nil) and (v.FType.BaseType = btInterface) then + begin + PPSVariantinterface(v).Data := cl; + {$IFNDEF Delphi3UP} + if PPSVariantinterface(v).Data <> nil then + PPSVariantinterface(v).Data.AddRef; + {$ENDIF} + end; +end; +{$ENDIF} + +procedure SetVariantToClass(V: PIFVariant; Cl: TObject); +begin + if (v <> nil) and (v.FType.BaseType = btClass) then + begin + PPSVariantclass(v).Data := cl; + end; +end; + +function BGRFW(var s: tbtString): tbtString; +var + l: Longint; +begin + l := Length(s); + while l >0 do + begin + if s[l] = ' ' then + begin + Result := copy(s, l + 1, Length(s) - l); + Delete(s, l, Length(s) - l + 1); + exit; + end; + Dec(l); + end; + Result := s; + s := ''; +end; + +{$ifdef fpc} + {$if defined(cpupowerpc) or defined(cpuarm) or defined(cpu64)} + {$define empty_methods_handler} + {$ifend} +{$endif} + +{$ifdef empty_methods_handler} +procedure MyAllMethodsHandler; +begin +end; +{$else} + + +function MyAllMethodsHandler2(Self: PScriptMethodInfo; const Stack: PPointer; _EDX, _ECX: Pointer): Integer; forward; + +procedure MyAllMethodsHandler; +// On entry: +// EAX = Self pointer +// EDX, ECX = param1 and param2 +// STACK = param3... paramcount +asm + push 0 + push ecx + push edx + mov edx, esp + add edx, 16 // was 12 + pop ecx + call MyAllMethodsHandler2 + pop ecx + mov edx, [esp] + add esp, eax + mov [esp], edx + mov eax, ecx +end; + +function ResultAsRegister(b: TPSTypeRec): Boolean; +begin + case b.BaseType of + btSingle, + btDouble, + btExtended, + btU8, + bts8, + bts16, + btu16, + bts32, + btu32, +{$IFDEF PS_FPCSTRINGWORKAROUND} + btString, +{$ENDIF} +{$IFNDEF PS_NOINT64} + bts64, +{$ENDIF} + btPChar, +{$IFNDEF PS_NOWIDESTRING} + btWideChar, +{$ENDIF} + btChar, + btclass, + btEnum: Result := true; + btSet: Result := b.RealSize <= PointerSize; + btStaticArray: Result := b.RealSize <= PointerSize; + else + Result := false; + end; +end; + +function SupportsRegister(b: TPSTypeRec): Boolean; +begin + case b.BaseType of + btU8, + bts8, + bts16, + btu16, + bts32, + btu32, + btstring, + btclass, +{$IFNDEF PS_NOINTERFACES} + btinterface, +{$ENDIF} + btPChar, +{$IFNDEF PS_NOWIDESTRING} + btwidestring, + btUnicodeString, + btWideChar, +{$ENDIF} + btChar, + btArray, + btEnum: Result := true; + btSet: Result := b.RealSize <= PointerSize; + btStaticArray: Result := b.RealSize <= PointerSize; + else + Result := false; + end; +end; + +function AlwaysAsVariable(aType: TPSTypeRec): Boolean; +begin + case atype.BaseType of + btVariant: Result := true; + btSet: Result := atype.RealSize > PointerSize; + btRecord: Result := atype.RealSize > PointerSize; + btStaticArray: Result := atype.RealSize > PointerSize; + else + Result := false; + end; +end; + + +procedure PutOnFPUStackExtended(ft: extended); +asm +// fstp tbyte ptr [ft] + fld tbyte ptr [ft] + +end; + + +function MyAllMethodsHandler2(Self: PScriptMethodInfo; const Stack: PPointer; _EDX, _ECX: Pointer): Integer; +var + Decl: tbtString; + I, C, regno: Integer; + Params: TPSList; + Res, Tmp: PIFVariant; + cpt: PIFTypeRec; + fmod: tbtchar; + s,e: tbtString; + FStack: pointer; + ex: TPSExceptionHandler; + + +begin + Decl := TPSInternalProcRec(Self^.Se.FProcs[Self^.ProcNo]).ExportDecl; + + FStack := Stack; + Params := TPSList.Create; + s := decl; + grfw(s); + while s <> '' do + begin + Params.Add(nil); + grfw(s); + end; + c := Params.Count; + regno := 0; + Result := 0; + s := decl; + grfw(s); + for i := c-1 downto 0 do + begin + e := grfw(s); + fmod := e[1]; + delete(e, 1, 1); + cpt := Self.Se.GetTypeNo(StrToInt(e)); + if ((fmod = '%') or (fmod = '!') or (AlwaysAsVariable(cpt))) and (RegNo < 2) then + begin + tmp := CreateHeapVariant(self.Se.FindType2(btPointer)); + PPSVariantPointer(tmp).DestType := cpt; + Params[i] := tmp; + case regno of + 0: begin + PPSVariantPointer(tmp).DataDest := Pointer(_EDX); + inc(regno); + end; + 1: begin + PPSVariantPointer(tmp).DataDest := Pointer(_ECX); + inc(regno); + end; +(* else begin + PPSVariantPointer(tmp).DataDest := Pointer(FStack^); + FStack := Pointer(IPointer(FStack) + 4); + end;*) + end; + end + else if SupportsRegister(cpt) and (RegNo < 2) then + begin + tmp := CreateHeapVariant(cpt); + Params[i] := tmp; + case regno of + 0: begin + CopyArrayContents(@PPSVariantData(tmp)^.Data, @_EDX, 1, cpt); + inc(regno); + end; + 1: begin + CopyArrayContents(@PPSVariantData(tmp)^.Data, @_ECX, 1, cpt); + inc(regno); + end; +(* else begin + CopyArrayContents(@PPSVariantData(tmp)^.Data, Pointer(FStack), 1, cpt); + FStack := Pointer(IPointer(FStack) + 4); + end;*) + end; +(* end else + begin + tmp := CreateHeapVariant(cpt); + Params[i] := tmp; + CopyArrayContents(@PPSVariantData(tmp)^.Data, Pointer(FStack), 1, cpt); + FStack := Pointer(IPointer(FStack) + cpt.RealSize + 3 and not 3);*) + end; + end; + s := decl; + e := grfw(s); + + if e <> '-1' then + begin + cpt := Self.Se.GetTypeNo(StrToInt(e)); + if not ResultAsRegister(cpt) then + begin + Res := CreateHeapVariant(Self.Se.FindType2(btPointer)); + PPSVariantPointer(Res).DestType := cpt; + Params.Add(Res); + case regno of + 0: begin + PPSVariantPointer(Res).DataDest := Pointer(_EDX); + end; + 1: begin + PPSVariantPointer(Res).DataDest := Pointer(_ECX); + end; + else begin + PPSVariantPointer(Res).DataDest := Pointer(FStack^); + Inc(Result, PointerSize); + end; + end; + end else + begin + Res := CreateHeapVariant(cpt); + Params.Add(Res); + end; + end else Res := nil; + s := decl; + grfw(s); + for i := 0 to c -1 do + begin + e := grlw(s); + fmod := e[1]; + delete(e, 1, 1); + if Params[i] <> nil then Continue; + cpt := Self.Se.GetTypeNo(StrToInt(e)); + if (fmod = '%') or (fmod = '!') or (AlwaysAsVariable(cpt)) then + begin + tmp := CreateHeapVariant(self.Se.FindType2(btPointer)); + PPSVariantPointer(tmp).DestType := cpt; + Params[i] := tmp; + PPSVariantPointer(tmp).DataDest := Pointer(FStack^); + FStack := Pointer(IPointer(FStack) + PointerSize); + Inc(Result, PointerSize); + end +(* else if SupportsRegister(cpt) then + begin + tmp := CreateHeapVariant(cpt); + Params[i] := tmp; + CopyArrayContents(@PPSVariantData(tmp)^.Data, Pointer(FStack), 1, cpt); + FStack := Pointer(IPointer(FStack) + 4); + end; + end *)else + begin + tmp := CreateHeapVariant(cpt); + Params[i] := tmp; + CopyArrayContents(@PPSVariantData(tmp)^.Data, Pointer(FStack), 1, cpt); + FStack := Pointer((IPointer(FStack) + cpt.RealSize + 3) and not 3); + Inc(Result, (cpt.RealSize + 3) and not 3); + end; + end; + ex := TPSExceptionHandler.Create; + ex.FinallyOffset := InvalidVal; + ex.ExceptOffset := InvalidVal; + ex.Finally2Offset := InvalidVal; + ex.EndOfBlock := InvalidVal; + ex.CurrProc := nil; + ex.BasePtr := Self.Se.FCurrStackBase; + Ex.StackSize := Self.Se.FStack.Count; + i := Self.Se.FExceptionStack.Add(ex); + Self.Se.RunProc(Params, Self.ProcNo); + if Self.Se.FExceptionStack[i] = ex then + begin + Self.Se.FExceptionStack.Remove(ex); + ex.Free; + end; + + if (Res <> nil) then + begin + Params.DeleteLast; + if (ResultAsRegister(Res.FType)) then + begin + if (res^.FType.BaseType = btSingle) or (res^.FType.BaseType = btDouble) or + (res^.FType.BaseType = btCurrency) or (res^.Ftype.BaseType = btExtended) then + begin + case Res^.FType.BaseType of + btSingle: PutOnFPUStackExtended(PPSVariantSingle(res).Data); + btDouble: PutOnFPUStackExtended(PPSVariantDouble(res).Data); + btExtended: PutOnFPUStackExtended(PPSVariantExtended(res).Data); + btCurrency: PutOnFPUStackExtended(PPSVariantCurrency(res).Data); + end; + DestroyHeapVariant(Res); + Res := nil; + end else + begin +{$IFNDEF PS_NOINT64} + if res^.FType.BaseType <> btS64 then +{$ENDIF} + CopyArrayContents(Pointer(Longint(Stack)-PointerSize2), @PPSVariantData(res)^.Data, 1, Res^.FType); + end; + end; + DestroyHeapVariant(res); + end; + for i := 0 to Params.Count -1 do + DestroyHeapVariant(Params[i]); + Params.Free; + if Self.Se.ExEx <> erNoError then + begin + if Self.Se.ExObject <> nil then + begin + FStack := Self.Se.ExObject; + Self.Se.ExObject := nil; + raise TObject(FStack); + end else + raise EPSException.Create(PSErrorToString(Self.SE.ExceptionCode, Self.Se.ExceptionString), Self.Se, Self.Se.ExProc, Self.Se.ExPos); + end; +end; +{$endif} +function TPSRuntimeClassImporter.FindClass(const Name: tbtString): TPSRuntimeClass; +var + h, i: Longint; + lName: tbtstring; + p: TPSRuntimeClass; +begin + lName := FastUpperCase(Name); + h := MakeHash(lName); + for i := FClasses.Count -1 downto 0 do + begin + p := FClasses[i]; + if (p.FClassNameHash = h) and (p.FClassName = lName) then + begin + Result := P; + exit; + end; + end; + Result := nil; +end; + +function DelphiFunctionProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack; CC: TPSCallingConvention): Boolean; +var + i: Integer; + MyList: TPSList; + n: PPSVariantIFC; + CurrStack: Cardinal; + s: tbtString; +begin + s := P.Decl; + if length(s) = 0 then begin Result := False; exit; end; + CurrStack := Cardinal(Stack.Count) - Cardinal(length(s)); + if s[1] = #0 then inc(CurrStack); + MyList := TPSList.Create; + + for i := 2 to length(s) do + begin + MyList.Add(nil); + end; + for i := length(s) downto 2 do + begin + MyList[i - 2] := NewPPSVariantIFC(Stack[CurrStack], s[i] <> #0); + inc(CurrStack); + end; + if s[1] <> #0 then + begin + n := NewPPSVariantIFC(Stack[CurrStack], True); + end else n := nil; + try + result := Caller.InnerfuseCall(p.Ext2, p.Ext1, cc, MyList, n); + finally + DisposePPSVariantIFC(n); + DisposePPSVariantIFCList(mylist); + end; +end; + +function DelphiFunctionProc_CDECL(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +begin + Result := DelphiFunctionProc(Caller, p, Global, Stack, cdCdecl); +end; +function DelphiFunctionProc_Register(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +begin + Result := DelphiFunctionProc(Caller, p, Global, Stack, cdRegister); +end; +function DelphiFunctionProc_Pascal(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +begin + Result := DelphiFunctionProc(Caller, p, Global, Stack, cdPascal); +end; +function DelphiFunctionProc_Stdcall(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +begin + Result := DelphiFunctionProc(Caller, p, Global, Stack, cdStdCall); +end; +function DelphiFunctionProc_Safecall(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +begin + Result := DelphiFunctionProc(Caller, p, Global, Stack, cdSafeCall); +end; + +procedure TPSExec.RegisterDelphiFunction(ProcPtr: Pointer; + const Name: tbtString; CC: TPSCallingConvention); +begin + RegisterDelphiMethod(nil, ProcPtr, FastUppercase(Name), CC); +end; + +procedure TPSExec.RegisterDelphiMethod(Slf, ProcPtr: Pointer; + const Name: tbtString; CC: TPSCallingConvention); +begin + case cc of + cdRegister: RegisterFunctionName(FastUppercase(Name), DelphiFunctionProc_Register, ProcPtr, Slf); + cdPascal: RegisterFunctionName(FastUppercase(Name), DelphiFunctionProc_Pascal, ProcPtr, Slf); + cdStdCall: RegisterFunctionName(FastUppercase(Name), DelphiFunctionProc_Stdcall, ProcPtr, Slf); + cdSafeCall: RegisterFunctionName(FastUppercase(Name), DelphiFunctionProc_Safecall, ProcPtr, Slf); + cdCdecl: RegisterFunctionName(FastUppercase(Name), DelphiFunctionProc_CDECL, ProcPtr, Slf); + end; +end; + +{ EPSException } + +constructor EPSException.Create(const Error: tbtString; Exec: TPSExec; + Procno, ProcPos: Cardinal); +begin + inherited Create(string(Error)); + FExec := Exec; + FProcNo := Procno; + FProcPos := ProcPos; +end; + +{ TPSRuntimeAttribute } + +function TPSRuntimeAttribute.AddValue(aType: TPSTypeRec): PPSVariant; +begin + Result := FValues.PushType(aType); +end; + +procedure TPSRuntimeAttribute.AdjustSize; +begin + FValues.Capacity := FValues.Length; +end; + +constructor TPSRuntimeAttribute.Create(Owner: TPSRuntimeAttributes); +begin + inherited Create; + FOwner := Owner; + FValues := TPSStack.Create; +end; + +procedure TPSRuntimeAttribute.DeleteValue(i: Longint); +begin + if Cardinal(i) <> Cardinal(FValues.Count -1) then + raise Exception.Create(RPS_CanOnlySendLastItem); + FValues.Pop; +end; + +destructor TPSRuntimeAttribute.Destroy; +begin + FValues.Free; + inherited Destroy; +end; + +function TPSRuntimeAttribute.GetValue(I: Longint): PIFVariant; +begin + Result := FValues[i]; +end; + +function TPSRuntimeAttribute.GetValueCount: Longint; +begin + Result := FValues.Count; +end; + +{ TPSRuntimeAttributes } + +function TPSRuntimeAttributes.Add: TPSRuntimeAttribute; +begin + Result := TPSRuntimeAttribute.Create(Self); + FAttributes.Add(Result); +end; + +constructor TPSRuntimeAttributes.Create(AOwner: TPSExec); +begin + inherited Create; + FAttributes := TPSList.Create; + FOwner := AOwner; +end; + +procedure TPSRuntimeAttributes.Delete(I: Longint); +begin + TPSRuntimeAttribute(FAttributes[i]).Free; + FAttributes.Delete(i); +end; + +destructor TPSRuntimeAttributes.Destroy; +var + i: Longint; +begin + for i := FAttributes.Count -1 downto 0 do + TPSRuntimeAttribute(FAttributes[i]).Free; + FAttributes.Free; + inherited Destroy; +end; + +function TPSRuntimeAttributes.FindAttribute( + const Name: tbtString): TPSRuntimeAttribute; +var + n: tbtString; + i, h: Longint; +begin + n := FastUpperCase(Name); + h := MakeHash(n); + for i := 0 to FAttributes.Count -1 do + begin + Result := FAttributes[i]; + if (Result.AttribTypeHash = h) and (Result.AttribType = n) then + exit; + end; + Result := nil; +end; + +function TPSRuntimeAttributes.GetCount: Longint; +begin + Result := FAttributes.Count; +end; + +function TPSRuntimeAttributes.GetItem(I: Longint): TPSRuntimeAttribute; +begin + Result := FAttributes[i]; +end; + +{ TPSInternalProcRec } + +destructor TPSInternalProcRec.Destroy; +begin + if FData <> nil then + Freemem(Fdata, FLength); + inherited Destroy; +end; + +{ TPsProcRec } + +constructor TPSProcRec.Create(Owner: TPSExec); +begin + inherited Create; + FAttributes := TPSRuntimeAttributes.Create(Owner); +end; + +destructor TPSProcRec.Destroy; +begin + FAttributes.Free; + inherited Destroy; +end; + +{ TPSTypeRec_Array } + +procedure TPSTypeRec_Array.CalcSize; +begin + FrealSize := PointerSize; +end; + +{ TPSTypeRec_StaticArray } + +procedure TPSTypeRec_StaticArray.CalcSize; +begin + FrealSize := Cardinal(FArrayType.RealSize) * Cardinal(Size); +end; + +{ TPSTypeRec_Set } + +procedure TPSTypeRec_Set.CalcSize; +begin + FrealSize := FByteSize; +end; + +const + MemDelta = 4096; + +{ TPSStack } + +procedure TPSStack.AdjustLength; +var + MyLen: Longint; +begin + MyLen := ((FLength shr 12) + 1) shl 12; + + SetCapacity(MyLen); +end; + +procedure TPSStack.Clear; +var + v: Pointer; + i: Longint; +begin + for i := Count -1 downto 0 do + begin + v := Data[i]; + if TPSTypeRec(v^).BaseType in NeedFinalization then + FinalizeVariant(Pointer(IPointer(v)+PointerSize), TPSTypeRec(v^)); + end; + inherited Clear; + FLength := 0; + SetCapacity(0); +end; + +constructor TPSStack.Create; +begin + inherited Create; + GetMem(FDataPtr, MemDelta); + FCapacity := MemDelta; + FLength := 0; +end; + +destructor TPSStack.Destroy; +var + v: Pointer; + i: Longint; +begin + for i := Count -1 downto 0 do + begin + v := Data[i]; + if TPSTypeRec(v^).BaseType in NeedFinalization then + FinalizeVariant(Pointer(IPointer(v)+PointerSize), Pointer(v^)); + end; + FreeMem(FDataPtr, FCapacity); + inherited Destroy; +end; + +function TPSStack.GetBool(ItemNo: Longint): Boolean; +var + val: PPSVariant; +begin + if ItemNo < 0 then + val := Items[Longint(ItemNo) + Longint(Count)] + else + val := Items[ItemNo]; + Result := PSGetUInt(@PPSVariantData(val).Data, val.FType) <> 0; +end; + +function TPSStack.GetClass(ItemNo: Longint): TObject; +var + val: PPSVariant; +begin + if ItemNo < 0 then + val := Items[Longint(ItemNo) + Longint(Count)] + else + val := Items[ItemNo]; + Result := PSGetObject(@PPSVariantData(val).Data, val.FType); +end; + +function TPSStack.GetCurrency(ItemNo: Longint): Currency; +var + val: PPSVariant; +begin + if ItemNo < 0 then + val := Items[Longint(ItemNo) + Longint(Count)] + else + val := Items[ItemNo]; + Result := PSGetCurrency(@PPSVariantData(val).Data, val.FType); +end; + +function TPSStack.GetInt(ItemNo: Longint): Longint; +var + val: PPSVariant; +begin + if ItemNo < 0 then + val := items[Longint(ItemNo) + Longint(Count)] + else + val := items[ItemNo]; + Result := PSGetInt(@PPSVariantData(val).Data, val.FType); +end; + +{$IFNDEF PS_NOINT64} +function TPSStack.GetInt64(ItemNo: Longint): Int64; +var + val: PPSVariant; +begin + if ItemNo < 0 then + val := items[Longint(ItemNo) + Longint(Count)] + else + val := items[ItemNo]; + Result := PSGetInt64(@PPSVariantData(val).Data, val.FType); +end; +{$ENDIF} + +function TPSStack.GetItem(I: Longint): PPSVariant; +begin + if Cardinal(I) >= Cardinal(Count) then + Result := nil + else + Result := Data[i]; +end; + +function TPSStack.GetReal(ItemNo: Longint): Extended; +var + val: PPSVariant; +begin + if ItemNo < 0 then + val := items[Longint(ItemNo) + Longint(Count)] + else + val := items[ItemNo]; + Result := PSGetreal(@PPSVariantData(val).Data, val.FType); +end; + +function TPSStack.GetAnsiString(ItemNo: Longint): tbtString; +var + val: PPSVariant; +begin + if ItemNo < 0 then + val := items[Longint(ItemNo) + Longint(Count)] + else + val := items[ItemNo]; + Result := PSGetAnsiString(@PPSVariantData(val).Data, val.FType); +end; + +function TPSStack.GetString(ItemNo: Longint): string; // calls the native method +begin + result := {$IFDEF DELPHI2009UP}GetUnicodeString(ItemNo){$ELSE}GetAnsiString(ItemNo){$ENDIF}; +end; + +function TPSStack.GetUInt(ItemNo: Longint): Cardinal; +var + val: PPSVariant; +begin + if ItemNo < 0 then + val := items[Longint(ItemNo) + Longint(Count)] + else + val := items[ItemNo]; + Result := PSGetUInt(@PPSVariantData(val).Data, val.FType); +end; + +function TPSStack.GetUnicodeString(ItemNo: Integer): tbtunicodestring; +var + val: PPSVariant; +begin + if ItemNo < 0 then + val := items[Longint(ItemNo) + Longint(Count)] + else + val := items[ItemNo]; + Result := PSGetUnicodeString(@PPSVariantData(val).Data, val.FType); +end; + +{$IFNDEF PS_NOWIDESTRING} +function TPSStack.GetWideString(ItemNo: Longint): tbtWideString; +var + val: PPSVariant; +begin + if ItemNo < 0 then + val := items[Longint(ItemNo) + Longint(Count)] + else + val := items[ItemNo]; + Result := PSGetWideString(@PPSVariantData(val).Data, val.FType); +end; +{$ENDIF} + +procedure TPSStack.Pop; +var + p1: Pointer; + c: Longint; +begin + c := count -1; + p1 := Data[c]; + DeleteLast; + FLength := IPointer(p1) - IPointer(FDataPtr); + if TPSTypeRec(p1^).BaseType in NeedFinalization then + FinalizeVariant(Pointer(IPointer(p1)+PointerSize), Pointer(p1^)); + if ((FCapacity - FLength) shr 12) > 2 then AdjustLength; +end; + +function TPSStack.Push(TotalSize: Longint): PPSVariant; +var + o: Cardinal; + p: Pointer; +begin + o := FLength; + FLength := (FLength + TotalSize); + if FLength mod PointerSize <> 0 then + FLength := FLength + (PointerSize - (FLength mod PointerSize)); + if FLength > FCapacity then AdjustLength; + p := Pointer(IPointer(FDataPtr) + IPointer(o)); + Add(p); + Result := P; +end; + +function TPSStack.PushType(aType: TPSTypeRec): PPSVariant; +var + o: Cardinal; + p: Pointer; +begin + Result := Push(aType.RealSize + Sizeof(Pointer)); + Result.FType := aType; + InitializeVariant(Pointer(IPointer(Result)+PointerSize), aType); +end; + +procedure TPSStack.SetBool(ItemNo: Longint; const Data: Boolean); +var + val: PPSVariant; + ok: Boolean; +begin + if ItemNo < 0 then + val := items[Longint(ItemNo) + Longint(Count)] + else + val := items[ItemNo]; + ok := true; + if Data then + PSSetUInt(@PPSVariantData(val).Data, val.FType, ok, 1) + else + PSSetUInt(@PPSVariantData(val).Data, val.FType, ok, 0); + if not ok then raise Exception.Create(RPS_TypeMismatch); +end; + +procedure TPSStack.SetCapacity(const Value: Longint); +var + p: Pointer; + OOFS: IPointer; + I: Longint; +begin + if Value < FLength then raise Exception.Create(RPS_CapacityLength); + if Value = 0 then + begin + if FDataPtr <> nil then + begin + FreeMem(FDataPtr, FCapacity); + FDataPtr := nil; + end; + FCapacity := 0; + end; + GetMem(p, Value); + if FDataPtr <> nil then + begin + if FLength > FCapacity then + OOFS := FCapacity + else + OOFS := FLength; + Move(FDataPtr^, p^, OOFS); + OOFS := IPointer(P) - IPointer(FDataPtr); + + for i := Count -1 downto 0 do begin + Data[i] := Pointer(IPointer(Data[i]) + OOFS); + if Items[i].FType.FBaseType = btPointer then begin // check if pointer points to moved stack data + if (IPointer(PPSVariantPointer(Data[i]).DataDest) >= IPointer(FDataPtr)) and + (IPointer(PPSVariantPointer(Data[i]).DataDest) < IPointer(FDataPtr)+IPointer(FLength)) then + PPSVariantPointer(Data[i]).DataDest := Pointer(IPointer(PPSVariantPointer(Data[i]).DataDest) + OOFS); + end; + end; + + FreeMem(FDataPtr, FCapacity); + end; + FDataPtr := p; + FCapacity := Value; +end; + +procedure TPSStack.SetClass(ItemNo: Longint; const Data: TObject); +var + val: PPSVariant; + ok: Boolean; +begin + if ItemNo < 0 then + val := items[Longint(ItemNo) + Longint(Count)] + else + val := items[ItemNo]; + ok := true; + PSSetObject(@PPSVariantData(val).Data, val.FType, ok, Data); + if not ok then raise Exception.Create(RPS_TypeMismatch); +end; + +procedure TPSStack.SetCurrency(ItemNo: Longint; const Data: Currency); +var + val: PPSVariant; + ok: Boolean; +begin + if ItemNo < 0 then + val := items[Longint(ItemNo) + Longint(Count)] + else + val := items[ItemNo]; + ok := true; + PSSetCurrency(@PPSVariantData(val).Data, val.FType, ok, Data); + if not ok then raise Exception.Create(RPS_TypeMismatch); +end; + +procedure TPSStack.SetInt(ItemNo: Longint; const Data: Longint); +var + val: PPSVariant; + ok: Boolean; +begin + if ItemNo < 0 then + val := items[Longint(ItemNo) + Longint(Count)] + else + val := items[ItemNo]; + ok := true; + PSSetInt(@PPSVariantData(val).Data, val.FType, ok, Data); + if not ok then raise Exception.Create(RPS_TypeMismatch); +end; + +{$IFNDEF PS_NOINT64} +procedure TPSStack.SetInt64(ItemNo: Longint; const Data: Int64); +var + val: PPSVariant; + ok: Boolean; +begin + if ItemNo < 0 then + val := items[Longint(ItemNo) + Longint(Count)] + else + val := items[ItemNo]; + ok := true; + PSSetInt64(@PPSVariantData(val).Data, val.FType, ok, Data); + if not ok then raise Exception.Create(RPS_TypeMismatch); +end; +{$ENDIF} + +procedure TPSStack.SetReal(ItemNo: Longint; const Data: Extended); +var + val: PPSVariant; + ok: Boolean; +begin + if ItemNo < 0 then + val := items[Longint(ItemNo) + Longint(Count)] + else + val := items[ItemNo]; + ok := true; + PSSetReal(@PPSVariantData(val).Data, val.FType, ok, Data); + if not ok then raise Exception.Create(RPS_TypeMismatch); +end; + +procedure TPSStack.SetAnsiString(ItemNo: Longint; const Data: tbtString); +var + val: PPSVariant; + ok: Boolean; +begin + if ItemNo < 0 then + val := items[Longint(ItemNo) + Longint(Count)] + else + val := items[ItemNo]; + ok := true; + PSSetAnsiString(@PPSVariantData(val).Data, val.FType, ok, Data); + if not ok then raise Exception.Create(RPS_TypeMismatch); +end; + +procedure TPSStack.SetString(ItemNo: Longint; const Data: string); +begin + {$IFDEF DELPHI2009UP} + SetUnicodeString(ItemNo, Data); + {$ELSE} + SetAnsiString(ItemNo, Data); + {$ENDIF} +end; + + +procedure TPSStack.SetUInt(ItemNo: Longint; const Data: Cardinal); +var + val: PPSVariant; + ok: Boolean; +begin + if ItemNo < 0 then + val := items[Longint(ItemNo) + Longint(Count)] + else + val := items[ItemNo]; + ok := true; + PSSetUInt(@PPSVariantData(val).Data, val.FType, ok, Data); + if not ok then raise Exception.Create(RPS_TypeMismatch); +end; + + +{$IFNDEF PS_NOWIDESTRING} +procedure TPSStack.SetUnicodeString(ItemNo: Integer; + const Data: tbtunicodestring); +var + val: PPSVariant; + ok: Boolean; +begin + if ItemNo < 0 then + val := items[Longint(ItemNo) + Longint(Count)] + else + val := items[ItemNo]; + ok := true; + PSSetUnicodeString(@PPSVariantData(val).Data, val.FType, ok, Data); +end; + +procedure TPSStack.SetWideString(ItemNo: Longint; + const Data: tbtWideString); +var + val: PPSVariant; + ok: Boolean; +begin + if ItemNo < 0 then + val := items[Longint(ItemNo) + Longint(Count)] + else + val := items[ItemNo]; + ok := true; + PSSetWideString(@PPSVariantData(val).Data, val.FType, ok, Data); + if not ok then raise Exception.Create(RPS_TypeMismatch); +end; +{$ENDIF} + + +{$IFNDEF PS_NOIDISPATCH} +var + DispPropertyPut: Integer = DISPID_PROPERTYPUT; +const + LOCALE_SYSTEM_DEFAULT = 2 shl 10; // Delphi 2 doesn't define this + +function IDispatchInvoke(Self: IDispatch; PropertySet: Boolean; const Name: tbtString; const Par: array of Variant): Variant; +var + Param: Word; + i, ArgErr: Longint; + DispatchId: Longint; + DispParam: TDispParams; + ExceptInfo: TExcepInfo; + aName: PWideChar; + WSFreeList: TPSList; +begin + FillChar(ExceptInfo, SizeOf(ExceptInfo), 0); + if Name='' then begin + DispatchId:=0; + end else begin + aName := StringToOleStr(Name); + try + if Self = nil then + raise Exception.Create(RPS_NILInterfaceException); + if Self.GetIDsOfNames(GUID_NULL, @aName, 1, LOCALE_SYSTEM_DEFAULT, @DispatchId) <> S_OK then + raise Exception.Create(RPS_UnknownMethod); + finally + SysFreeString(aName); + end; + end; + DispParam.cNamedArgs := 0; + DispParam.rgdispidNamedArgs := nil; + DispParam.cArgs := (High(Par) + 1); + + if PropertySet then + begin + Param := DISPATCH_PROPERTYPUT; + DispParam.cNamedArgs := 1; + DispParam.rgdispidNamedArgs := @DispPropertyPut; + end else + Param := DISPATCH_METHOD or DISPATCH_PROPERTYGET; + + WSFreeList := TPSList.Create; + try + GetMem(DispParam.rgvarg, sizeof(TVariantArg) * (High(Par) + 1)); + FillCHar(DispParam.rgvarg^, sizeof(TVariantArg) * (High(Par) + 1), 0); + try + for i := 0 to High(Par) do + begin + if PVarData(@Par[High(Par)-i]).VType = varString then + begin + DispParam.rgvarg[i].vt := VT_BSTR; + DispParam.rgvarg[i].bstrVal := StringToOleStr(AnsiString(Par[High(Par)-i])); + WSFreeList.Add(DispParam.rgvarg[i].bstrVal); + {$IFDEF UNICODE} + end else if (PVarData(@Par[High(Par)-i]).VType = varOleStr) or (PVarData(@Par[High(Par)-i]).VType = varUString) then + begin + DispParam.rgvarg[i].vt := VT_BSTR; + DispParam.rgvarg[i].bstrVal := StringToOleStr(UnicodeString(Par[High(Par)-i])); + WSFreeList.Add(DispParam.rgvarg[i].bstrVal); + {$ENDIF} + end else + begin + DispParam.rgvarg[i].vt := VT_VARIANT or VT_BYREF; + New( + {$IFDEF DELPHI4UP} + POleVariant + {$ELSE} + PVariant{$ENDIF} + (DispParam.rgvarg[i].pvarVal)); + + (* + {$IFDEF DELPHI4UP} + POleVariant + {$ELSE} + PVariant + {$ENDIF} + (DispParam.rgvarg[i].pvarVal)^ := Par[High(Par)-i]; + *) + Move(Par[High(Par)-i],Pointer(DispParam.rgvarg[i].pvarVal)^, + Sizeof({$IFDEF DELPHI4UP}OleVariant{$ELSE}Variant{$ENDIF})); + + end; + end; + i :=Self.Invoke(DispatchId, GUID_NULL, LOCALE_SYSTEM_DEFAULT, Param, DispParam, @Result, @ExceptInfo, @ArgErr); + {$IFNDEF Delphi3UP} + try + if not Succeeded(i) then + begin + if i = DISP_E_EXCEPTION then + raise Exception.Create(OleStrToString(ExceptInfo.bstrSource)+': '+OleStrToString(ExceptInfo.bstrDescription)) + else + raise Exception.Create(SysErrorMessage(i)); + end; + finally + SysFreeString(ExceptInfo.bstrSource); + SysFreeString(ExceptInfo.bstrDescription); + SysFreeString(ExceptInfo.bstrHelpFile); + end; + {$ELSE} + if not Succeeded(i) then + begin + if i = DISP_E_EXCEPTION then + raise Exception.Create(ExceptInfo.bstrSource+': '+ExceptInfo.bstrDescription) + else + raise Exception.Create(SysErrorMessage(i)); + end; + {$ENDIF} + finally + for i := 0 to High(Par) do + begin + if DispParam.rgvarg[i].vt = (VT_VARIANT or VT_BYREF) then + begin + if{$IFDEF DELPHI4UP}POleVariant{$ELSE}PVariant{$ENDIF} + (DispParam.rgvarg[i].pvarVal) <> nil then + Dispose( + {$IFDEF DELPHI4UP} + POleVariant + {$ELSE} + PVariant + {$ENDIF} + (DispParam.rgvarg[i].pvarVal)); + end; + end; + FreeMem(DispParam.rgvarg, sizeof(TVariantArg) * (High(Par) + 1)); + end; + finally + for i := WSFreeList.Count -1 downto 0 do + SysFreeString(WSFreeList[i]); + WSFreeList.Free; + end; +end; +{$ENDIF} + + +{ TPSTypeRec_ProcPtr } + +procedure TPSTypeRec_ProcPtr.CalcSize; +begin + FRealSize := 2 * sizeof(Pointer) + Sizeof(Cardinal); +end; + +end. + diff --git a/Units/PascalScript/uPSUtils.pas b/Units/PascalScript/uPSUtils.pas new file mode 100644 index 0000000..76f2d48 --- /dev/null +++ b/Units/PascalScript/uPSUtils.pas @@ -0,0 +1,1592 @@ +unit uPSUtils; +{$I PascalScript.inc} + +interface +uses + Classes, SysUtils {$IFDEF VER130}, Windows {$ENDIF}; + +const + + PSMainProcName = '!MAIN'; + + PSMainProcNameOrg = 'Main Proc'; + + PSLowBuildSupport = 12; + + PSCurrentBuildNo = 23; + + PSCurrentversion = '1.31'; + + PSValidHeader = 1397769801; + + PSAddrStackStart = 1610612736; + + PSAddrNegativeStackStart = 1073741824; +type + TbtString = {$IFDEF DELPHI2009UP}AnsiString{$ELSE}String{$ENDIF}; + + TPSBaseType = Byte; + + TPSVariableType = (ivtGlobal, ivtParam, ivtVariable); + +const + + btReturnAddress = 0; + + btU8 = 1; + + btS8 = 2; + + btU16 = 3; + + btS16 = 4; + + btU32 = 5; + + btS32 = 6; + + btSingle = 7; + + btDouble = 8; + + btExtended = 9; + + btString = 10; + + btRecord = 11; + + btArray = 12; + + btPointer = 13; + + btPChar = 14; + + btResourcePointer = 15; + + btVariant = 16; + +{$IFNDEF PS_NOINT64} + btS64 = 17; +{$ENDIF} + + btChar = 18; + +{$IFNDEF PS_NOWIDESTRING} + btWideString = 19; + + btWideChar = 20; +{$ENDIF} + + btProcPtr = 21; + + btStaticArray = 22; + + btSet = 23; + + btCurrency = 24; + + btClass = 25; + + btInterface = 26; + + btNotificationVariant = 27; + + btUnicodeString = 28; + + btType = 130; + + btEnum = 129; + + btExtClass = 131; + +function MakeHash(const s: TbtString): Longint; + +const +{ Script internal command: Assign command<br> + Command: TPSCommand;<br> + VarDest, // no data<br> + VarSrc: TPSVariable;<br> +} + CM_A = 0; +{ Script internal command: Calculate Command<br> + Command: TPSCommand; <br> + CalcType: Byte;<br> + <i><br> + 0 = +<br> + 1 = -<br> + 2 = *<br> + 3 = /<br> + 4 = MOD<br> + 5 = SHL<br> + 6 = SHR<br> + 7 = AND<br> + 8 = OR<br> + 9 = XOR<br> + </i><br> + VarDest, // no data<br> + VarSrc: TPSVariable;<br> +<br> +} + CM_CA = 1; +{ Script internal command: Push<br> + Command: TPSCommand; <br> + Var: TPSVariable;<br> +} + CM_P = 2; +{ Script internal command: Push Var<br> + Command: TPSCommand; <br> + Var: TPSVariable;<br> +} + CM_PV = 3; +{ Script internal command: Pop<br> + Command: TPSCommand; <br> +} + CM_PO = 4; +{ Script internal command: Call<br> + Command: TPSCommand; <br> + ProcNo: Longword;<br> +} + Cm_C = 5; +{ Script internal command: Goto<br> + Command: TPSCommand; <br> + NewPosition: Longint; //relative to end of this instruction<br> +} + Cm_G = 6; +{ Script internal command: Conditional Goto<br> + Command: TPSCommand; <br> + NewPosition: LongWord; //relative to end of this instruction<br> + Var: TPSVariable; // no data<br> +} + Cm_CG = 7; +{ Script internal command: Conditional NOT Goto<br> + Command: TPSCommand; <br> + NewPosition: LongWord; // relative to end of this instruction<br> + Var: TPSVariable; // no data<br> +} + Cm_CNG = 8; +{ Script internal command: Ret<br> + Command: TPSCommand; <br> +} + Cm_R = 9; +{ Script internal command: Set Stack Type<br> + Command: TPSCommand; <br> + NewType: LongWord;<br> + OffsetFromBase: LongWord;<br> +} + Cm_ST = 10; +{ Script internal command: Push Type<br> + Command: TPSCommand; <br> + FType: LongWord;<br> +} + Cm_Pt = 11; +{ Script internal command: Compare<br> + Command: TPSCommand; <br> + CompareType: Byte;<br> + <i><br> + 0 = >=<br> + 1 = <=<br> + 2 = ><br> + 3 = <<br> + 4 = <><br> + 5 = =<br> + <i><br> + IntoVar: TPSAssignment;<br> + Compare1, Compare2: TPSAssigment;<br> +} + CM_CO = 12; +{ Script internal command: Call Var<br> + Command: TPSCommand; <br> + Var: TPSVariable;<br> +} + Cm_cv = 13; +{ Script internal command: Set Pointer<br> + Command: TPSCommand; <br> + VarDest: TPSVariable;<br> + VarSrc: TPSVariable;<br> +} + cm_sp = 14; +{ Script internal command: Boolean NOT<br> + Command: TPSCommand; <br> + Var: TPSVariable;<br> +} + cm_bn = 15; +{ Script internal command: Var Minus<br> + Command: TPSCommand; <br> + Var: TPSVariable; +} + cm_vm = 16; +{ Script internal command: Set Flag<br> + Command: TPSCommand; <br> + Var: TPSVariable;<br> + DoNot: Boolean;<br> +} + cm_sf = 17; +{ Script internal command: Flag Goto<br> + Command: TPSCommand; <br> + Where: Cardinal;<br> +} + cm_fg = 18; +{ Script internal command: Push Exception Handler<br> + Command: TPSCommand; <br> + FinallyOffset,<br> + ExceptionOffset, // FinallyOffset or ExceptionOffset need to be set.<br> + Finally2Offset,<br> + EndOfBlock: Cardinal;<br> +} + cm_puexh = 19; +{ Script internal command: Pop Exception Handler<br> + Command:TPSCommand; <br> + Position: Byte;<br> + <i> 0 = end of try/finally/exception block;<br> + 1 = end of first finally<br> + 2 = end of except<br> + 3 = end of second finally<br> + </i><br> +} + cm_poexh = 20; +{ Script internal command: Integer NOT<br> + Command: TPSCommand; <br> + Where: Cardinal;<br> +} + cm_in = 21; + {Script internal command: Set Stack Pointer To Copy<br> + Command: TPSCommand; <br> + Where: Cardinal;<br> +} + cm_spc = 22; + {Script internal command: Inc<br> + Command: TPSCommand; <br> + Var: TPSVariable;<br> + } + cm_inc = 23; + {Script internal command: Dec<br> + Command: TPSCommand; <br> + Var: TPSVariable;<br> + } + cm_dec = 24; + {Script internal command: nop<br> + Command: TPSCommand; <br>} + cm_nop = 255; +{ Script internal command: Pop and Goto<br> + Command: TPSCommand; <br> + NewPosition: Longint; //relative to end of this instruction<br> +} + Cm_PG = 25; +{ Script internal command: Pop*2 and Goto<br> + Command: TPSCommand; <br> + NewPosition: Longint; //relative to end of this instruction<br> +} + Cm_P2G = 26; + + +type + + TbtU8 = Byte; + + TbtS8 = ShortInt; + + TbtU16 = Word; + + TbtS16 = SmallInt; + + TbtU32 = Cardinal; + + TbtS32 = Longint; + + TbtSingle = Single; + + TbtDouble = double; + + TbtExtended = Extended; + + tbtCurrency = Currency; + +{$IFNDEF PS_NOINT64} + + tbts64 = int64; +{$ENDIF} + + tbtchar = {$IFDEF DELPHI4UP}AnsiChar{$ELSE}CHAR{$ENDIF}; +{$IFNDEF PS_NOWIDESTRING} + + tbtwidestring = widestring; + tbtunicodestring = {$IFDEF DELPHI2009UP}UnicodeString{$ELSE}widestring{$ENDIF}; + + tbtwidechar = widechar; + tbtNativeString = {$IFDEF DELPHI2009UP}tbtUnicodeString{$ELSE}tbtString{$ENDIF}; +{$ENDIF} +{$IFDEF FPC} + IPointer = PtrUInt; +{$ELSE} + {$IFDEF CPU64} IPointer = LongWord;{$ELSE} IPointer = Cardinal;{$ENDIF} +{$ENDIF} + TPSCallingConvention = (cdRegister, cdPascal, cdCdecl, cdStdCall, cdSafeCall); + + +const + + PointerSize = IPointer({$IFDEF CPU64}8{$ELSE}4{$ENDIF}); + PointerSize2 = IPointer(2*PointerSize); + MaxListSize = Maxint div 16; + +type + + PPointerList = ^TPointerList; + + TPointerList = array[0..MaxListSize - 1] of Pointer; + + + TPSList = class(TObject) + protected + + FData: PPointerList; + + FCapacity: Cardinal; + + FCount: Cardinal; + + FCheckCount: Cardinal; + private + function GetItem(Nr: Cardinal): Pointer; + procedure SetItem(Nr: Cardinal; P: Pointer); + public + {$IFNDEF PS_NOSMARTLIST} + + procedure Recreate; + {$ENDIF} + + property Data: PPointerList read FData; + + constructor Create; + + function IndexOf(P: Pointer): Longint; + + destructor Destroy; override; + + property Count: Cardinal read FCount; + + property Items[nr: Cardinal]: Pointer read GetItem write SetItem; default; + + function Add(P: Pointer): Longint; + + procedure AddBlock(List: PPointerList; Count: Longint); + + procedure Remove(P: Pointer); + + procedure Delete(Nr: Cardinal); + + procedure DeleteLast; + + procedure Clear; virtual; + end; + TIFList = TPSList; + + TPSStringList = class(TObject) + private + List: TPSList; + function GetItem(Nr: LongInt): TbtString; + procedure SetItem(Nr: LongInt; const s: TbtString); + public + + function Count: LongInt; + + property Items[Nr: Longint]: TbtString read GetItem write SetItem; default; + + + procedure Add(const P: TbtString); + + procedure Delete(NR: LongInt); + + procedure Clear; + + constructor Create; + + destructor Destroy; override; + end; + TIFStringList = TPsStringList; + + +type + + TPSPasToken = ( + CSTI_EOF, + + CSTIINT_Comment, + CSTIINT_WhiteSpace, + + CSTI_Identifier, + CSTI_SemiColon, + CSTI_Comma, + CSTI_Period, + CSTI_Colon, + CSTI_OpenRound, + CSTI_CloseRound, + CSTI_OpenBlock, + CSTI_CloseBlock, + CSTI_Assignment, + CSTI_Equal, + CSTI_NotEqual, + CSTI_Greater, + CSTI_GreaterEqual, + CSTI_Less, + CSTI_LessEqual, + CSTI_Plus, + CSTI_Minus, + CSTI_Divide, + CSTI_Multiply, + CSTI_Integer, + CSTI_Real, + CSTI_String, + CSTI_Char, + CSTI_HexInt, + CSTI_AddressOf, + CSTI_Dereference, + CSTI_TwoDots, + + CSTII_and, + CSTII_array, + CSTII_begin, + CSTII_case, + CSTII_const, + CSTII_div, + CSTII_do, + CSTII_downto, + CSTII_else, + CSTII_end, + CSTII_for, + CSTII_function, + CSTII_if, + CSTII_in, + CSTII_mod, + CSTII_not, + CSTII_of, + CSTII_or, + CSTII_procedure, + CSTII_program, + CSTII_repeat, + CSTII_record, + CSTII_set, + CSTII_shl, + CSTII_shr, + CSTII_then, + CSTII_to, + CSTII_type, + CSTII_until, + CSTII_uses, + CSTII_var, + CSTII_while, + CSTII_with, + CSTII_xor, + CSTII_exit, + CSTII_class, + CSTII_constructor, + CSTII_destructor, + CSTII_inherited, + CSTII_private, + CSTII_public, + CSTII_published, + CSTII_protected, + CSTII_property, + CSTII_virtual, + CSTII_override, + //CSTII_default, //Birb + CSTII_As, + CSTII_Is, + CSTII_Unit, + CSTII_Try, + CSTII_Except, + CSTII_Finally, + CSTII_External, + CSTII_Forward, + CSTII_Export, + CSTII_Label, + CSTII_Goto, + CSTII_Chr, + CSTII_Ord, + CSTII_Interface, + CSTII_Implementation, + CSTII_initialization, //* Nvds + CSTII_finalization, //* Nvds + CSTII_out, + CSTII_nil + ); + + TPSParserErrorKind = (iNoError + , iCommentError + , iStringError + , iCharError + , iSyntaxError + ); + TPSParserErrorEvent = procedure (Parser: TObject; Kind: TPSParserErrorKind) of object; + + + TPSPascalParser = class(TObject) + protected + FData: TbtString; + FText: {$IFDEF DELPHI4UP}PAnsiChar{$ELSE}PChar{$ENDIF}; + FLastEnterPos, FRow, FRealPosition, FTokenLength: Cardinal; + FTokenId: TPSPasToken; + FToken: TbtString; + FOriginalToken: TbtString; + FParserError: TPSParserErrorEvent; + FEnableComments: Boolean; + FEnableWhitespaces: Boolean; + function GetCol: Cardinal; + // only applicable when Token in [CSTI_Identifier, CSTI_Integer, CSTI_Real, CSTI_String, CSTI_Char, CSTI_HexInt] + public + + property EnableComments: Boolean read FEnableComments write FEnableComments; + + property EnableWhitespaces: Boolean read FEnableWhitespaces write FEnableWhitespaces; + + procedure Next; virtual; + + property GetToken: TbtString read FToken; + + property OriginalToken: TbtString read FOriginalToken; + + property CurrTokenPos: Cardinal read FRealPosition; + + property CurrTokenID: TPSPasToken read FTokenId; + + property Row: Cardinal read FRow; + + property Col: Cardinal read GetCol; + + procedure SetText(const Data: TbtString); virtual; + + property OnParserError: TPSParserErrorEvent read FParserError write FParserError; + end; + +function FloatToStr(E: Extended): TbtString; + +function FastLowerCase(const s: TbtString): TbtString; + +function Fw(const S: TbtString): TbtString; + +function IntToStr(I: LongInt): TbtString; + +function StrToIntDef(const S: TbtString; Def: LongInt): LongInt; + +function StrToInt(const S: TbtString): LongInt; +function StrToFloat(const s: TbtString): Extended; + +function FastUpperCase(const s: TbtString): TbtString; + +function GRFW(var s: TbtString): TbtString; +function GRLW(var s: TbtString): TbtString; + +const + + FCapacityInc = 32; +{$IFNDEF PS_NOSMARTLIST} + + FMaxCheckCount = (FCapacityInc div 4) * 64; +{$ENDIF} + +{$IFDEF VER130} +function WideUpperCase(const S: WideString): WideString; +function WideLowerCase(const S: WideString): WideString; +{$ENDIF} +implementation + +{$IFDEF DELPHI3UP } +resourceString +{$ELSE } +const +{$ENDIF } + RPS_InvalidFloat = 'Invalid float'; + +{$IFDEF VER130} + +function WideUpperCase(const S: WideString): WideString; +var + Len: Integer; +begin + // CharUpperBuffW is stubbed out on Win9x platofmrs + if Win32Platform = VER_PLATFORM_WIN32_NT then + begin + Len := Length(S); + SetString(Result, PWideChar(S), Len); + if Len > 0 then CharUpperBuffW(Pointer(Result), Len); + end + else + Result := AnsiUpperCase(S); +end; + +function WideLowerCase(const S: WideString): WideString; +var + Len: Integer; +begin + // CharLowerBuffW is stubbed out on Win9x platofmrs + if Win32Platform = VER_PLATFORM_WIN32_NT then + begin + Len := Length(S); + SetString(Result, PWideChar(S), Len); + if Len > 0 then CharLowerBuffW(Pointer(Result), Len); + end + else + Result := AnsiLowerCase(S); +end; + +{$ENDIF} + + +function MakeHash(const s: TbtString): Longint; +{small hash maker} +var + I: Integer; +begin + Result := 0; + for I := 1 to Length(s) do + Result := ((Result shl 7) or (Result shr 25)) + Ord(s[I]); +end; + +function GRFW(var s: TbtString): TbtString; +var + l: Longint; +begin + l := 1; + while l <= Length(s) do + begin + if s[l] = ' ' then + begin + Result := copy(s, 1, l - 1); + Delete(s, 1, l); + exit; + end; + l := l + 1; + end; + Result := s; + s := ''; +end; + +function GRLW(var s: TbtString): TbtString; +var + l: Longint; +begin + l := Length(s); + while l >= 1 do + begin + if s[l] = ' ' then + begin + Result := copy(s, l+1, MaxInt); + Delete(s, l, MaxInt); + exit; + end; + Dec(l); + end; + Result := s; + s := ''; +end; + +function StrToFloat(const s: TbtString): Extended; +var + i: longint; +begin + Val(string(s), Result, i); + if i <> 0 then raise Exception.Create(RPS_InvalidFloat); +end; +//------------------------------------------------------------------- + +function IntToStr(I: LongInt): TbtString; +var + s: tbtstring; +begin + Str(i, s); + IntToStr := s; +end; +//------------------------------------------------------------------- + +function FloatToStr(E: Extended): TbtString; +var + s: tbtstring; +begin + Str(e:0:12, s); + result := s; +end; + +function StrToInt(const S: TbtString): LongInt; +var + e: Integer; + Res: LongInt; +begin + Val(string(S), Res, e); + if e <> 0 then + StrToInt := -1 + else + StrToInt := Res; +end; +//------------------------------------------------------------------- + +function StrToIntDef(const S: TbtString; Def: LongInt): LongInt; +var + e: Integer; + Res: LongInt; +begin + Val(string(S), Res, e); + if e <> 0 then + StrToIntDef := Def + else + StrToIntDef := Res; +end; +//------------------------------------------------------------------- + +constructor TPSList.Create; +begin + inherited Create; + FCount := 0; + FCapacity := 16; + {$IFNDEF PS_NOSMARTLIST} + FCheckCount := 0; + {$ENDIF} + GetMem(FData, FCapacity * PointerSize); +end; + + +function MM(i1,i2: Integer): Integer; +begin + if ((i1 div i2) * i2) < i1 then + mm := (i1 div i2 + 1) * i2 + else + mm := (i1 div i2) * i2; +end; + +{$IFNDEF PS_NOSMARTLIST} +procedure TPSList.Recreate; +var + NewData: PPointerList; + NewCapacity: Cardinal; + I: Longint; + +begin + + FCheckCount := 0; + NewCapacity := mm(FCount, FCapacityInc); + if NewCapacity < 64 then NewCapacity := 64; + GetMem(NewData, NewCapacity * PointerSize); + for I := 0 to Longint(FCount) -1 do + begin + NewData^[i] := FData^[I]; + end; + FreeMem(FData, FCapacity * PointerSize); + FData := NewData; + FCapacity := NewCapacity; +end; +{$ENDIF} + +//------------------------------------------------------------------- + +function TPSList.Add(P: Pointer): Longint; +begin + if FCount >= FCapacity then + begin + Inc(FCapacity, FCapacityInc);// := FCount + 1; + ReAllocMem(FData, FCapacity * PointerSize); + end; + FData[FCount] := P; // Instead of SetItem + Result := FCount; + Inc(FCount); +{$IFNDEF PS_NOSMARTLIST} + Inc(FCheckCount); + if FCheckCount > FMaxCheckCount then Recreate; +{$ENDIF} +end; + +procedure TPSList.AddBlock(List: PPointerList; Count: Longint); +var + L: Longint; + +begin + if Longint(FCount) + Count > Longint(FCapacity) then + begin + Inc(FCapacity, mm(Count, FCapacityInc)); + ReAllocMem(FData, FCapacity *PointerSize); + end; + for L := 0 to Count -1 do + begin + FData^[FCount] := List^[L]; + Inc(FCount); + end; +{$IFNDEF PS_NOSMARTLIST} + Inc(FCheckCount); + if FCheckCount > FMaxCheckCount then Recreate; +{$ENDIF} +end; + + +//------------------------------------------------------------------- + +procedure TPSList.DeleteLast; +begin + if FCount = 0 then Exit; + Dec(FCount); +{$IFNDEF PS_NOSMARTLIST} + Inc(FCheckCount); + if FCheckCount > FMaxCheckCount then Recreate; +{$ENDIF} +end; + + + +procedure TPSList.Delete(Nr: Cardinal); +begin + if FCount = 0 then Exit; + if Nr < FCount then + begin + Move(FData[Nr + 1], FData[Nr], (FCount - Nr) * PointerSize); + Dec(FCount); +{$IFNDEF PS_NOSMARTLIST} + Inc(FCheckCount); + if FCheckCount > FMaxCheckCount then Recreate; +{$ENDIF} + end; +end; +//------------------------------------------------------------------- + +procedure TPSList.Remove(P: Pointer); +var + I: Cardinal; +begin + if FCount = 0 then Exit; + I := 0; + while I < FCount do + begin + if FData[I] = P then + begin + Delete(I); + Exit; + end; + Inc(I); + end; +end; +//------------------------------------------------------------------- + +procedure TPSList.Clear; +begin + FCount := 0; +{$IFNDEF PS_NOSMARTLIST} + Recreate; +{$ENDIF} +end; +//------------------------------------------------------------------- + +destructor TPSList.Destroy; +begin + FreeMem(FData, FCapacity * PointerSize); + inherited Destroy; +end; +//------------------------------------------------------------------- + +procedure TPSList.SetItem(Nr: Cardinal; P: Pointer); +begin + if (FCount = 0) or (Nr >= FCount) then + Exit; + FData[Nr] := P; +end; +//------------------------------------------------------------------- + +function TPSList.GetItem(Nr: Cardinal): Pointer; {12} +begin + if Nr < FCount then + GetItem := FData[Nr] + else + GetItem := nil; +end; + + + +//------------------------------------------------------------------- + +function TPSStringList.Count: LongInt; +begin + count := List.count; +end; +type pStr = ^TbtString; + +//------------------------------------------------------------------- + +function TPSStringList.GetItem(Nr: LongInt): TbtString; +var + S: PStr; +begin + s := List.GetItem(Nr); + if s = nil then + Result := '' + else + + Result := s^; +end; +//------------------------------------------------------------------- + + +procedure TPSStringList.SetItem(Nr: LongInt; const s: TbtString); +var + p: PStr; +begin + p := List.GetItem(Nr); + if p = nil + then + Exit; + p^ := s; +end; +//------------------------------------------------------------------- + +procedure TPSStringList.Add(const P: TbtString); +var + w: PStr; +begin + new(w); + w^ := p; + List.Add(w); +end; +//------------------------------------------------------------------- + +procedure TPSStringList.Delete(NR: LongInt); +var + W: PStr; +begin + W := list.getitem(nr); + if w<>nil then + begin + dispose(w); + end; + list.Delete(Nr); +end; + +procedure TPSStringList.Clear; +begin + while List.Count > 0 do Delete(0); +end; + +constructor TPSStringList.Create; +begin + inherited Create; + List := TPSList.Create; +end; + +destructor TPSStringList.Destroy; +begin + while List.Count > 0 do + Delete(0); + List.Destroy; + inherited Destroy; +end; + +//------------------------------------------------------------------- + + +function Fw(const S: TbtString): TbtString; // First word +var + x: integer; +begin + x := pos(tbtstring(' '), s); + if x > 0 + then Fw := Copy(S, 1, x - 1) + else Fw := S; +end; +//------------------------------------------------------------------- +function FastUpperCase(const s: TbtString): TbtString; +{Fast uppercase} +var + I: Integer; + C: tbtChar; +begin + Result := S; + I := Length(Result); + while I > 0 do + begin + C := Result[I]; + if c in [#97..#122] then + Result[I] := tbtchar(Ord(Result[I]) -32); + Dec(I); + end; +end; +function FastLowerCase(const s: TbtString): TbtString; +{Fast lowercase} +var + I: Integer; + C: tbtChar; +begin + Result := S; + I := Length(Result); + while I > 0 do + begin + C := Result[I]; + if C in [#65..#90] then + Result[I] := tbtchar(Ord(Result[I]) + 32); + Dec(I); + end; +end; +//------------------------------------------------------------------- + +type + TRTab = record + name: TbtString; + c: TPSPasToken; + end; + + +const + KEYWORD_COUNT = 65; //*NVDS + LookupTable: array[0..KEYWORD_COUNT - 1] of TRTab = ( + (name: 'AND'; c: CSTII_and), + (name: 'ARRAY'; c: CSTII_array), + (name: 'AS'; c: CSTII_as), + (name: 'BEGIN'; c: CSTII_begin), + (name: 'CASE'; c: CSTII_case), + (name: 'CHR'; c: CSTII_chr), + (name: 'CLASS'; c: CSTII_class), + (name: 'CONST'; c: CSTII_const), + (name: 'CONSTRUCTOR'; c: CSTII_constructor), + (name: 'DESTRUCTOR'; c: CSTII_destructor), + (name: 'DIV'; c: CSTII_div), + (name: 'DO'; c: CSTII_do), + (name: 'DOWNTO'; c: CSTII_downto), + (name: 'ELSE'; c: CSTII_else), + (name: 'END'; c: CSTII_end), + (name: 'EXCEPT'; c: CSTII_except), + (name: 'EXIT'; c: CSTII_exit), + (name: 'EXPORT'; c: CSTII_Export), + (name: 'EXTERNAL'; c: CSTII_External), + (Name: 'FINALIZATION'; c : CSTII_finalization),//* Nvds + (name: 'FINALLY'; c: CSTII_finally), + (name: 'FOR'; c: CSTII_for), + (name: 'FORWARD'; c: CSTII_Forward), + (name: 'FUNCTION'; c: CSTII_function), + (name: 'GOTO'; c: CSTII_Goto), + (name: 'IF'; c: CSTII_if), + (name: 'IMPLEMENTATION'; c: CSTII_Implementation), + (name: 'IN'; c: CSTII_in), + (name: 'INHERITED'; c: CSTII_inherited), + (Name: 'INITIALIZATION'; c: CSTII_initialization), //* Nvds + (name: 'INTERFACE'; c: CSTII_Interface), + (name: 'IS'; c: CSTII_is), + (name: 'LABEL'; c: CSTII_Label), + (name: 'MOD'; c: CSTII_mod), + (name: 'NIL'; c: CSTII_nil), + (name: 'NOT'; c: CSTII_not), + (name: 'OF'; c: CSTII_of), + (name: 'OR'; c: CSTII_or), + (name: 'ORD'; c: CSTII_ord), + (name: 'OUT'; c: CSTII_Out), + (name: 'OVERRIDE'; c: CSTII_override), + //(name: 'DEFAULT'; c: CSTII_default), //Birb (if added, don't forget to increase KEYWORD_COUNT) + (name: 'PRIVATE'; c: CSTII_private), + (name: 'PROCEDURE'; c: CSTII_procedure), + (name: 'PROGRAM'; c: CSTII_program), + (name: 'PROPERTY'; c: CSTII_property), + (name: 'PROTECTED'; c: CSTII_protected), + (name: 'PUBLIC'; c: CSTII_public), + (name: 'PUBLISHED'; c: CSTII_published), + (name: 'RECORD'; c: CSTII_record), + (name: 'REPEAT'; c: CSTII_repeat), + (name: 'SET'; c: CSTII_set), + (name: 'SHL'; c: CSTII_shl), + (name: 'SHR'; c: CSTII_shr), + (name: 'THEN'; c: CSTII_then), + (name: 'TO'; c: CSTII_to), + (name: 'TRY'; c: CSTII_try), + (name: 'TYPE'; c: CSTII_type), + (name: 'UNIT'; c: CSTII_Unit), + (name: 'UNTIL'; c: CSTII_until), + (name: 'USES'; c: CSTII_uses), + (name: 'VAR'; c: CSTII_var), + (name: 'VIRTUAL'; c: CSTII_virtual), + (name: 'WHILE'; c: CSTII_while), + (name: 'WITH'; c: CSTII_with), + (name: 'XOR'; c: CSTII_xor)); + +function TPSPascalParser.GetCol: Cardinal; +begin + Result := FRealPosition - FLastEnterPos + 1; +end; + +procedure TPSPascalParser.Next; +var + Err: TPSParserErrorKind; + FLastUpToken: TbtString; + function CheckReserved(Const S: ShortString; var CurrTokenId: TPSPasToken): Boolean; + var + L, H, I: LongInt; + J: tbtChar; + SName: ShortString; + begin + L := 0; + J := S[0]; + H := KEYWORD_COUNT-1; + while L <= H do + begin + I := (L + H) shr 1; + SName := LookupTable[i].Name; + if J = SName[0] then + begin + if S = SName then + begin + CheckReserved := True; + CurrTokenId := LookupTable[I].c; + Exit; + end; + if S > SName then + L := I + 1 + else + H := I - 1; + end else + if S > SName then + L := I + 1 + else + H := I - 1; + end; + CheckReserved := False; + end; + //------------------------------------------------------------------- + + function _GetToken(CurrTokenPos, CurrTokenLen: Cardinal): TbtString; + var + s: tbtString; + begin + SetLength(s, CurrTokenLen); + Move(FText[CurrTokenPos], S[1], CurrtokenLen); + Result := s; + end; + + function ParseToken(var CurrTokenPos, CurrTokenLen: Cardinal; var CurrTokenId: TPSPasToken): TPSParserErrorKind; + {Parse the token} + var + ct, ci: Cardinal; + hs: Boolean; + p: {$IFDEF DELPHI4UP}PAnsiChar{$ELSE}PChar{$ENDIF}; + begin + ParseToken := iNoError; + ct := CurrTokenPos; + case FText[ct] of + #0: + begin + CurrTokenId := CSTI_EOF; + CurrTokenLen := 0; + end; + 'A'..'Z', 'a'..'z', '_': + begin + ci := ct + 1; + while (FText[ci] in ['_', '0'..'9', 'a'..'z', 'A'..'Z']) do begin + Inc(ci); + end; + CurrTokenLen := ci - ct; + + FLastUpToken := _GetToken(CurrTokenPos, CurrtokenLen); + p := {$IFDEF DELPHI4UP}PAnsiChar{$ELSE}pchar{$ENDIF}(FLastUpToken); + while p^<>#0 do + begin + if p^ in [#97..#122] then + Dec(Byte(p^), 32); + inc(p); + end; + if not CheckReserved(FLastUpToken, CurrTokenId) then + begin + CurrTokenId := CSTI_Identifier; + end; + end; + '$': + begin + ci := ct + 1; + + while (FText[ci] in ['0'..'9', 'a'..'f', 'A'..'F']) + do Inc(ci); + + CurrTokenId := CSTI_HexInt; + CurrTokenLen := ci - ct; + end; + + '0'..'9': + begin + hs := False; + ci := ct; + while (FText[ci] in ['0'..'9']) do + begin + Inc(ci); + if (FText[ci] = '.') and (not hs) then + begin + if FText[ci+1] = '.' then break; + hs := True; + Inc(ci); + end; + end; + if (FText[ci] in ['E','e']) and ((FText[ci+1] in ['0'..'9']) + or ((FText[ci+1] in ['+','-']) and (FText[ci+2] in ['0'..'9']))) then + begin + hs := True; + Inc(ci); + if FText[ci] in ['+','-'] then + Inc(ci); + repeat + Inc(ci); + until not (FText[ci] in ['0'..'9']); + end; + + if hs + then CurrTokenId := CSTI_Real + else CurrTokenId := CSTI_Integer; + + CurrTokenLen := ci - ct; + end; + + + #39: + begin + ci := ct + 1; + while true do + begin + if (FText[ci] = #0) or (FText[ci] = #13) or (FText[ci] = #10) then Break; + if (FText[ci] = #39) then + begin + if FText[ci+1] = #39 then + Inc(ci) + else + Break; + end; + Inc(ci); + end; + if FText[ci] = #39 then + CurrTokenId := CSTI_String + else + begin + CurrTokenId := CSTI_String; + ParseToken := iStringError; + end; + CurrTokenLen := ci - ct + 1; + end; + '#': + begin + ci := ct + 1; + if FText[ci] = '$' then + begin + inc(ci); + while (FText[ci] in ['A'..'F', 'a'..'f', '0'..'9']) do begin + Inc(ci); + end; + CurrTokenId := CSTI_Char; + CurrTokenLen := ci - ct; + end else + begin + while (FText[ci] in ['0'..'9']) do begin + Inc(ci); + end; + if FText[ci] in ['A'..'Z', 'a'..'z', '_'] then + begin + ParseToken := iCharError; + CurrTokenId := CSTI_Char; + end else + CurrTokenId := CSTI_Char; + CurrTokenLen := ci - ct; + end; + end; + '=': + begin + CurrTokenId := CSTI_Equal; + CurrTokenLen := 1; + end; + '>': + begin + if FText[ct + 1] = '=' then + begin + CurrTokenid := CSTI_GreaterEqual; + CurrTokenLen := 2; + end else + begin + CurrTokenid := CSTI_Greater; + CurrTokenLen := 1; + end; + end; + '<': + begin + if FText[ct + 1] = '=' then + begin + CurrTokenId := CSTI_LessEqual; + CurrTokenLen := 2; + end else + if FText[ct + 1] = '>' then + begin + CurrTokenId := CSTI_NotEqual; + CurrTokenLen := 2; + end else + begin + CurrTokenId := CSTI_Less; + CurrTokenLen := 1; + end; + end; + ')': + begin + CurrTokenId := CSTI_CloseRound; + CurrTokenLen := 1; + end; + '(': + begin + if FText[ct + 1] = '*' then + begin + ci := ct + 1; + while (FText[ci] <> #0) do begin + if (FText[ci] = '*') and (FText[ci + 1] = ')') then + Break; + if FText[ci] = #13 then + begin + inc(FRow); + if FText[ci+1] = #10 then + inc(ci); + FLastEnterPos := ci +1; + end else if FText[ci] = #10 then + begin + inc(FRow); + FLastEnterPos := ci +1; + end; + Inc(ci); + end; + if (FText[ci] = #0) then + begin + CurrTokenId := CSTIINT_Comment; + ParseToken := iCommentError; + end else + begin + CurrTokenId := CSTIINT_Comment; + Inc(ci, 2); + end; + CurrTokenLen := ci - ct; + end + else + begin + CurrTokenId := CSTI_OpenRound; + CurrTokenLen := 1; + end; + end; + '[': + begin + CurrTokenId := CSTI_OpenBlock; + CurrTokenLen := 1; + end; + ']': + begin + CurrTokenId := CSTI_CloseBlock; + CurrTokenLen := 1; + end; + ',': + begin + CurrTokenId := CSTI_Comma; + CurrTokenLen := 1; + end; + '.': + begin + if FText[ct + 1] = '.' then + begin + CurrTokenLen := 2; + CurrTokenId := CSTI_TwoDots; + end else + begin + CurrTokenId := CSTI_Period; + CurrTokenLen := 1; + end; + end; + '@': + begin + CurrTokenId := CSTI_AddressOf; + CurrTokenLen := 1; + end; + '^': + begin + CurrTokenId := CSTI_Dereference; + CurrTokenLen := 1; + end; + ';': + begin + CurrTokenId := CSTI_Semicolon; + CurrTokenLen := 1; + end; + ':': + begin + if FText[ct + 1] = '=' then + begin + CurrTokenId := CSTI_Assignment; + CurrTokenLen := 2; + end else + begin + CurrTokenId := CSTI_Colon; + CurrTokenLen := 1; + end; + end; + '+': + begin + CurrTokenId := CSTI_Plus; + CurrTokenLen := 1; + end; + '-': + begin + CurrTokenId := CSTI_Minus; + CurrTokenLen := 1; + end; + '*': + begin + CurrTokenId := CSTI_Multiply; + CurrTokenLen := 1; + end; + '/': + begin + if FText[ct + 1] = '/' then + begin + ci := ct + 1; + while (FText[ci] <> #0) and (FText[ci] <> #13) and + (FText[ci] <> #10) do begin + Inc(ci); + end; + if (FText[ci] = #0) then + begin + CurrTokenId := CSTIINT_Comment; + end else + begin + CurrTokenId := CSTIINT_Comment; + end; + CurrTokenLen := ci - ct; + end else + begin + CurrTokenId := CSTI_Divide; + CurrTokenLen := 1; + end; + end; + #32, #9, #13, #10: + begin + ci := ct; + while (FText[ci] in [#32, #9, #13, #10]) do + begin + if FText[ci] = #13 then + begin + inc(FRow); + if FText[ci+1] = #10 then + inc(ci); + FLastEnterPos := ci +1; + end else if FText[ci] = #10 then + begin + inc(FRow); + FLastEnterPos := ci +1; + end; + Inc(ci); + end; + CurrTokenId := CSTIINT_WhiteSpace; + CurrTokenLen := ci - ct; + end; + '{': + begin + ci := ct + 1; + while (FText[ci] <> #0) and (FText[ci] <> '}') do begin + if FText[ci] = #13 then + begin + inc(FRow); + if FText[ci+1] = #10 then + inc(ci); + FLastEnterPos := ci + 1; + end else if FText[ci] = #10 then + begin + inc(FRow); + FLastEnterPos := ci + 1; + end; + Inc(ci); + end; + if (FText[ci] = #0) then + begin + CurrTokenId := CSTIINT_Comment; + ParseToken := iCommentError; + end else + CurrTokenId := CSTIINT_Comment; + CurrTokenLen := ci - ct + 1; + end; + else + begin + ParseToken := iSyntaxError; + CurrTokenId := CSTIINT_Comment; + CurrTokenLen := 1; + end; + end; + end; + //------------------------------------------------------------------- +begin + if FText = nil then + begin + FTokenLength := 0; + FRealPosition := 0; + FTokenId := CSTI_EOF; + Exit; + end; + repeat + FRealPosition := FRealPosition + Cardinal(FTokenLength); + Err := ParseToken(FRealPosition, Cardinal(FTokenLength), FTokenID); + if Err <> iNoError then + begin + FTokenLength := 0; + FTokenId := CSTI_EOF; + FToken := ''; + FOriginalToken := ''; + if @FParserError <> nil then FParserError(Self, Err); + exit; + end; + + case FTokenID of + CSTIINT_Comment: if not FEnableComments then Continue else + begin + SetLength(FOriginalToken, FTokenLength); + Move(FText[CurrTokenPos], FOriginalToken[1], FTokenLength); + FToken := FOriginalToken; + end; + CSTIINT_WhiteSpace: if not FEnableWhitespaces then Continue else + begin + SetLength(FOriginalToken, FTokenLength); + Move(FText[CurrTokenPos], FOriginalToken[1], FTokenLength); + FToken := FOriginalToken; + end; + CSTI_Integer, CSTI_Real, CSTI_String, CSTI_Char, CSTI_HexInt: + begin + SetLength(FOriginalToken, FTokenLength); + Move(FText[CurrTokenPos], FOriginalToken[1], FTokenLength); + FToken := FOriginalToken; + end; + CSTI_Identifier: + begin + SetLength(FOriginalToken, FTokenLength); + Move(FText[CurrTokenPos], FOriginalToken[1], FTokenLength); + FToken := FLastUpToken; + end; + else + begin + FOriginalToken := ''; + FToken := ''; + end; + end; + Break; + until False; +end; + +procedure TPSPascalParser.SetText(const Data: TbtString); +begin + FData := Data; + FText := Pointer(FData); + FTokenLength := 0; + FRealPosition := 0; + FTokenId := CSTI_EOF; + FLastEnterPos := 0; + FRow := 1; + Next; +end; + +function TPSList.IndexOf(P: Pointer): Longint; +var + i: Integer; +begin + for i := FCount -1 downto 0 do + begin + if FData[i] = p then + begin + result := i; + exit; + end; + end; + result := -1; +end; + +end. + + diff --git a/Units/PascalScript/uPS_ExtReg.pas b/Units/PascalScript/uPS_ExtReg.pas new file mode 100644 index 0000000..b0dec7a --- /dev/null +++ b/Units/PascalScript/uPS_ExtReg.pas @@ -0,0 +1,17 @@ +unit uPS_ExtReg; + +interface + +procedure Register; + +implementation + +uses classes, uPSI_IBX, uPSI_Mask, upSI_JvMail, uPSI_Dialogs, uPSI_Registry; + +procedure Register; +begin + RegisterComponents('Pascal Script', [TPSImport_IBX, TPSImport_Mask, TPSImport_JvMail, + TPSImport_Dialogs, TPSImport_Registry]); +end; + +end. diff --git a/Units/PascalScript/uROPSImports.pas b/Units/PascalScript/uROPSImports.pas new file mode 100644 index 0000000..da70685 --- /dev/null +++ b/Units/PascalScript/uROPSImports.pas @@ -0,0 +1,366 @@ +unit uROPSImports; + +interface + +uses + uPSCompiler, uPSRuntime, uROBINMessage, uROIndyHTTPChannel, + uROXMLSerializer, uROIndyTCPChannel, idTcpClient, + uROPSServerLink, uROWinInetHttpChannel; + + +procedure SIRegisterTROBINMESSAGE(CL: TIFPSPascalCompiler); +procedure SIRegisterTROINDYHTTPCHANNEL(CL: TIFPSPascalCompiler); +procedure SIRegisterTROINDYTCPCHANNEL(CL: TIFPSPascalCompiler); +procedure SIRegisterTIDTCPCLIENT(CL: TIFPSPascalCompiler); +procedure SIRegisterRODLImports(Cl: TIFPSPascalCompiler); + + + +procedure RIRegisterTROBINMESSAGE(Cl: TIFPSRuntimeClassImporter); +procedure RIRegisterTROINDYHTTPCHANNEL(Cl: TIFPSRuntimeClassImporter); +procedure RIRegisterTROINDYTCPCHANNEL(Cl: TIFPSRuntimeClassImporter); +procedure RIRegisterTIDTCPCLIENT(Cl: TIFPSRuntimeClassImporter); +procedure RIRegisterRODLImports(CL: TIFPSRuntimeClassImporter); +(* +Todo: + TROWinInetHTTPChannel = class(TROTransportChannel, IROTransport, IROTCPTransport, IROHTTPTransport) + published + property UserAgent:string read GetUserAgent write SetUserAgent; + property TargetURL : string read fTargetURL write SetTargetURL; + property StoreConnected:boolean read fStoreConnected write fStoreConnected default false; + property KeepConnection:boolean read fKeepConnection write fKeepConnection default false; + end; +*) +type + + TPSROIndyTCPModule = class(TPSROModule) + protected + class procedure ExecImp(exec: TIFPSExec; ri: TIFPSRuntimeClassImporter); override; + class procedure CompImp(comp: TIFPSPascalCompiler); override; + end; + + TPSROIndyHTTPModule = class(TPSROModule) + protected + class procedure ExecImp(exec: TIFPSExec; ri: TIFPSRuntimeClassImporter); override; + class procedure CompImp(comp: TIFPSPascalCompiler); override; + end; + + TPSROBinModule = class(TPSROModule) + protected + class procedure ExecImp(exec: TIFPSExec; ri: TIFPSRuntimeClassImporter); override; + class procedure CompImp(comp: TIFPSPascalCompiler); override; + end; + + +implementation + +{procedure TROSOAPMESSAGESERIALIZATIONOPTIONS_W(Self: TROSOAPMESSAGE; + const T: TXMLSERIALIZATIONOPTIONS); +begin + Self.SERIALIZATIONOPTIONS := T; +end; + +procedure TROSOAPMESSAGESERIALIZATIONOPTIONS_R(Self: TROSOAPMESSAGE; + var T: TXMLSERIALIZATIONOPTIONS); +begin + T := Self.SERIALIZATIONOPTIONS; +end; + +procedure TROSOAPMESSAGECUSTOMLOCATION_W(Self: TROSOAPMESSAGE; const T: string); +begin + Self.CUSTOMLOCATION := T; +end; + +procedure TROSOAPMESSAGECUSTOMLOCATION_R(Self: TROSOAPMESSAGE; var T: string); +begin + T := Self.CUSTOMLOCATION; +end; + +procedure TROSOAPMESSAGELIBRARYNAME_W(Self: TROSOAPMESSAGE; const T: string); +begin + Self.LIBRARYNAME := T; +end; + +procedure TROSOAPMESSAGELIBRARYNAME_R(Self: TROSOAPMESSAGE; var T: string); +begin + T := Self.LIBRARYNAME; +end; } + +procedure TROBINMESSAGEUSECOMPRESSION_W(Self: TROBINMESSAGE; const T: boolean); +begin + Self.USECOMPRESSION := T; +end; + +procedure TROBINMESSAGEUSECOMPRESSION_R(Self: TROBINMESSAGE; var T: boolean); +begin + T := Self.USECOMPRESSION; +end; + +procedure TROINDYHTTPCHANNELTARGETURL_W(Self: TROINDYHTTPCHANNEL; const T: string); +begin + Self.TARGETURL := T; +end; + +procedure TROINDYHTTPCHANNELTARGETURL_R(Self: TROINDYHTTPCHANNEL; var T: string); +begin + T := Self.TARGETURL; +end; + +procedure TROINDYTCPCHANNELINDYCLIENT_R(Self: TROINDYTCPCHANNEL; var T: TIdTCPClientBaseClass); +begin + T := Self.INDYCLIENT; +end; + +procedure TIDTCPCLIENTPORT_W(Self: TIDTCPCLIENT; const T: integer); +begin + Self.PORT := T; +end; + +procedure TIDTCPCLIENTPORT_R(Self: TIdTCPClientBaseClass; var T: integer); +begin + T := TIdIndy10HackClient(Self).PORT; +end; + +procedure TIDTCPCLIENTHOST_W(Self: TIdTCPClientBaseClass; const T: string); +begin + TIdIndy10HackClient(Self).HOST := T; +end; + +procedure TIDTCPCLIENTHOST_R(Self: TIdTCPClientBaseClass; var T: string); +begin + T := TIdIndy10HackClient(Self).HOST; +end; + +{procedure TIDTCPCLIENTBOUNDPORT_W(Self: TIdTCPClientBaseClass; const T: integer); +begin + Self.BOUNDPORT := T; +end; + +procedure TIDTCPCLIENTBOUNDPORT_R(Self: TIdTCPClientBaseClass; var T: integer); +begin + T := Self.BOUNDPORT; +end; + +procedure TIDTCPCLIENTBOUNDIP_W(Self: TIdTCPClientBaseClass; const T: string); +begin + Self.BOUNDIP := T; +end; + +procedure TIDTCPCLIENTBOUNDIP_R(Self: TIdTCPClientBaseClass; var T: string); +begin + T := Self.BOUNDIP; +end;] + +procedure TIDTCPCLIENTBOUNDPORTMIN_W(Self: TIdTCPClientBaseClass; const T: integer); +begin + Self.BOUNDPORTMIN := T; +end; + +procedure TIDTCPCLIENTBOUNDPORTMIN_R(Self: TIdTCPClientBaseClass; var T: integer); +begin + T := Self.BOUNDPORTMIN; +end; + +procedure TIDTCPCLIENTBOUNDPORTMAX_W(Self: TIdTCPClientBaseClass; const T: integer); +begin + Self.BOUNDPORTMAX := T; +end; + +procedure TIDTCPCLIENTBOUNDPORTMAX_R(Self: TIdTCPClientBaseClass; var T: integer); +begin + T := Self.BOUNDPORTMAX; +end; + +{procedure RIRegisterTROSOAPMESSAGE(Cl: TIFPSRuntimeClassImporter); +begin + with Cl.Add(TROSOAPMESSAGE) do + begin + RegisterPropertyHelper(@TROSOAPMESSAGELIBRARYNAME_R, @TROSOAPMESSAGELIBRARYNAME_W, + 'LIBRARYNAME'); + RegisterPropertyHelper(@TROSOAPMESSAGECUSTOMLOCATION_R, + @TROSOAPMESSAGECUSTOMLOCATION_W, 'CUSTOMLOCATION'); + RegisterPropertyHelper(@TROSOAPMESSAGESERIALIZATIONOPTIONS_R, + @TROSOAPMESSAGESERIALIZATIONOPTIONS_W, 'SERIALIZATIONOPTIONS'); + end; +end; } + +procedure RIRegisterTROBINMESSAGE(Cl: TIFPSRuntimeClassImporter); +begin + with Cl.Add(TROBINMESSAGE) do + begin + RegisterPropertyHelper(@TROBINMESSAGEUSECOMPRESSION_R, + @TROBINMESSAGEUSECOMPRESSION_W, 'USECOMPRESSION'); + end; +end; + +procedure RIRegisterTROINDYHTTPCHANNEL(Cl: TIFPSRuntimeClassImporter); +begin + with Cl.Add(TROINDYHTTPCHANNEL) do + begin + RegisterPropertyHelper(@TROINDYHTTPCHANNELTARGETURL_R, + @TROINDYHTTPCHANNELTARGETURL_W, 'TARGETURL'); + end; +end; + +procedure RIRegisterTROINDYTCPCHANNEL(Cl: TIFPSRuntimeClassImporter); +begin + with Cl.Add(TROINDYTCPCHANNEL) do + begin + RegisterPropertyHelper(@TROINDYTCPCHANNELINDYCLIENT_R, nil, 'INDYCLIENT'); + end; +end; + +procedure RIRegisterTIDTCPCLIENT(Cl: TIFPSRuntimeClassImporter); +begin + with Cl.Add(TIdTCPClientBaseClass) do + begin + {RegisterPropertyHelper(@TIDTCPCLIENTBOUNDPORTMAX_R, @TIDTCPCLIENTBOUNDPORTMAX_W, + 'BOUNDPORTMAX'); + RegisterPropertyHelper(@TIDTCPCLIENTBOUNDPORTMIN_R, @TIDTCPCLIENTBOUNDPORTMIN_W, + 'BOUNDPORTMIN'); + RegisterPropertyHelper(@TIDTCPCLIENTBOUNDIP_R, @TIDTCPCLIENTBOUNDIP_W, 'BOUNDIP'); + RegisterPropertyHelper(@TIDTCPCLIENTBOUNDPORT_R, @TIDTCPCLIENTBOUNDPORT_W, + 'BOUNDPORT');} + RegisterPropertyHelper(@TIDTCPCLIENTHOST_R, @TIDTCPCLIENTHOST_W, 'HOST'); + RegisterPropertyHelper(@TIDTCPCLIENTPORT_R, @TIDTCPCLIENTPORT_W, 'PORT'); + end; +end; + +procedure RIRegisterRODLImports(CL: TIFPSRuntimeClassImporter); +begin + RIRegisterTIDTCPCLIENT(Cl); + RIRegisterTROINDYTCPCHANNEL(Cl); + RIRegisterTROINDYHTTPCHANNEL(Cl); + RIRegisterTROBINMESSAGE(Cl); + //RIRegisterTROSOAPMESSAGE(Cl); +end; + +function RegClassS(cl: TIFPSPascalCompiler; const InheritsFrom, + ClassName: string): TPSCompileTimeClass; +begin + Result := cl.FindClass(ClassName); + if Result = nil then + Result := cl.AddClassN(cl.FindClass(InheritsFrom), ClassName) + else + Result.ClassInheritsFrom := cl.FindClass(InheritsFrom); +end; + +{procedure SIRegisterTROSOAPMESSAGE(CL: TIFPSPascalCompiler); +begin + Cl.addTypeS('TXMLSERIALIZATIONOPTIONS', 'BYTE'); + Cl.AddConstantN('XSOWRITEMULTIREFARRAY', 'BYTE').SetInt(1); + Cl.AddConstantN('XSOWRITEMULTIREFOBJECT', 'BYTE').SetInt(2); + Cl.AddConstantN('XSOSENDUNTYPED', 'BYTE').SetInt(4); + with RegClassS(cl, 'TROMESSAGE', 'TROSOAPMESSAGE') do + begin + RegisterProperty('LIBRARYNAME', 'STRING', iptrw); + RegisterProperty('CUSTOMLOCATION', 'STRING', iptrw); + RegisterProperty('SERIALIZATIONOPTIONS', 'TXMLSERIALIZATIONOPTIONS', iptrw); + end; +end;} + +procedure SIRegisterTROBINMESSAGE(CL: TIFPSPascalCompiler); +begin + with RegClassS(cl, 'TROMESSAGE', 'TROBINMESSAGE') do + begin + RegisterProperty('USECOMPRESSION', 'BOOLEAN', iptrw); + end; +end; + +procedure SIRegisterTROINDYHTTPCHANNEL(CL: TIFPSPascalCompiler); +begin + with RegClassS(cl, 'TROINDYTCPCHANNEL', 'TROINDYHTTPCHANNEL') do + begin + RegisterProperty('TARGETURL', 'STRING', iptrw); + end; +end; + +procedure SIRegisterTROINDYTCPCHANNEL(CL: TIFPSPascalCompiler); +begin + with RegClassS(cl, 'TROTRANSPORTCHANNEL', 'TROINDYTCPCHANNEL') do + begin + RegisterProperty('INDYCLIENT', 'TIdTCPClientBaseClass', iptr); + end; +end; + +procedure SIRegisterTIDTCPCLIENT(CL: TIFPSPascalCompiler); +begin + with RegClassS(cl, 'TCOMPONENT', 'TIdTCPClientBaseClass') do + begin + RegisterProperty('BOUNDPORTMAX', 'INTEGER', iptrw); + RegisterProperty('BOUNDPORTMIN', 'INTEGER', iptrw); + RegisterProperty('BOUNDIP', 'STRING', iptrw); + RegisterProperty('BOUNDPORT', 'INTEGER', iptrw); + RegisterProperty('HOST', 'STRING', iptrw); + RegisterProperty('PORT', 'INTEGER', iptrw); + end; +end; + +procedure SIRegisterRODLImports(Cl: TIFPSPascalCompiler); +begin + SIRegisterTIDTCPCLIENT(Cl); + SIRegisterTROINDYTCPCHANNEL(Cl); + SIRegisterTROINDYHTTPCHANNEL(Cl); + SIRegisterTROBINMESSAGE(Cl); + //SIRegisterTROSOAPMESSAGE(Cl); +end; + +{ TPSROIndyTCPModule } + +class procedure TPSROIndyTCPModule.CompImp(comp: TIFPSPascalCompiler); +begin + SIRegisterTIDTCPCLIENT(Comp); + SIRegisterTROINDYTCPCHANNEL(Comp); +end; + +class procedure TPSROIndyTCPModule.ExecImp(exec: TIFPSExec; + ri: TIFPSRuntimeClassImporter); +begin + RIRegisterTIDTCPCLIENT(ri); + RIRegisterTROINDYTCPCHANNEL(ri); +end; + +{ TPSROIndyHTTPModule } + +class procedure TPSROIndyHTTPModule.CompImp(comp: TIFPSPascalCompiler); +begin + if Comp.FindClass('TROINDYTCPCHANNEL') = nil then + TPSROIndyTCPModule.CompImp(Comp); + SIRegisterTROINDYHTTPCHANNEL(Comp); +end; + +class procedure TPSROIndyHTTPModule.ExecImp(exec: TIFPSExec; + ri: TIFPSRuntimeClassImporter); +begin + if ri.FindClass('TROINDYTCPCHANNEL') = nil then + TPSROIndyTCPModule.ExecImp(exec, ri); + RIRegisterTROINDYHTTPCHANNEL(ri); +end; + +{ TPSROSoapModule } + +{class procedure TPSROSoapModule.CompImp(comp: TIFPSPascalCompiler); +begin + SIRegisterTROSOAPMESSAGE(comp); +end; + +class procedure TPSROSoapModule.ExecImp(exec: TIFPSExec; + ri: TIFPSRuntimeClassImporter); +begin + RIRegisterTROSOAPMESSAGE(ri); +end;} + +{ TPSROBinModule } + +class procedure TPSROBinModule.CompImp(comp: TIFPSPascalCompiler); +begin + SIRegisterTROBINMESSAGE(Comp); +end; + +class procedure TPSROBinModule.ExecImp(exec: TIFPSExec; + ri: TIFPSRuntimeClassImporter); +begin + RIRegisterTROBINMESSAGE(ri); +end; + +end. diff --git a/Units/PascalScript/uROPSServerLink.pas b/Units/PascalScript/uROPSServerLink.pas new file mode 100644 index 0000000..9501a29 --- /dev/null +++ b/Units/PascalScript/uROPSServerLink.pas @@ -0,0 +1,1231 @@ +unit uROPSServerLink; + +interface +uses + SysUtils, Classes, uPSCompiler, uPSUtils, uPSRuntime, + uROServer, uROClient, uRODL{$IFDEF WIN32}, + Windows{$ELSE}, Types{$ENDIF}, uROTypes, uROClientIntf, + uROSerializer, uPSComponent; + +type + + TPSROModule = class + protected + class procedure ExecImp(exec: TPSExec; ri: TPSRuntimeClassImporter); virtual; + class procedure CompImp(comp: TPSPascalCompiler); virtual; + end; + TPSROModuleClass = class of TPSROModule; + TPSRemObjectsSdkPlugin = class; + TPSROModuleLoadEvent = procedure (Sender: TPSRemObjectsSdkPlugin) of object; + + TPSRemObjectsSdkPlugin = class(TPSPlugin) + private + FRodl: TRODLLibrary; + FModules: TList; + FOnLoadModule: TPSROModuleLoadEvent; + + FEnableIndyTCP: Boolean; + FEnableIndyHTTP: Boolean; + FEnableBinary: Boolean; + function GetHaveRodl: Boolean; + function MkStructName(Struct: TRODLStruct): string; + public + procedure CompileImport1(CompExec: TPSScript); override; + procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override; + protected + procedure Loaded; override; + public + + procedure RODLLoadFromFile(const FileName: string); + + procedure RODLLoadFromResource; + + procedure RODLLoadFromStream(S: TStream); + + procedure ClearRodl; + + property HaveRodl: Boolean read GetHaveRodl; + + constructor Create(AOwner: TComponent); override; + + destructor Destroy; override; + + + procedure ReloadModules; + + procedure RegisterModule(Module: TPSROModuleClass); + published + property OnLoadModule: TPSROModuleLoadEvent read FOnLoadModule write FOnLoadModule; + + property EnableIndyTCP: Boolean read FEnableIndyTCP write FEnableIndyTCP default true; + + property EnableIndyHTTP: Boolean read FEnableIndyHTTP write FEnableIndyHTTP default true; + + property EnableBinary: Boolean read FEnableBinary write FEnableBinary default true; + end; + +implementation +uses + uRODLToXML, uROPSImports; + +procedure SIRegisterTROTRANSPORTCHANNEL(CL: TPSPascalCompiler); +Begin +With cl.AddClassN(cl.FindClass('TComponent'), 'TROTRANSPORTCHANNEL') do + begin + end; +end; + +procedure SIRegisterTROMESSAGE(CL: TPSPascalCompiler); +Begin +With cl.AddClassN(cl.FindClass('TComponent'),'TROMESSAGE') do + begin + RegisterProperty('MESSAGENAME', 'STRING', iptrw); + RegisterProperty('INTERFACENAME', 'STRING', iptrw); + end; +end; + +procedure TROMESSAGEINTERFACENAME_W(Self: TROMESSAGE; const T: STRING); +begin Self.INTERFACENAME := T; end; + +procedure TROMESSAGEINTERFACENAME_R(Self: TROMESSAGE; var T: STRING); +begin T := Self.INTERFACENAME; end; + +procedure TROMESSAGEMESSAGENAME_W(Self: TROMESSAGE; const T: STRING); +begin Self.MESSAGENAME := T; end; + +procedure TROMESSAGEMESSAGENAME_R(Self: TROMESSAGE; var T: STRING); +begin T := Self.MESSAGENAME; end; + +procedure RIRegisterTROTRANSPORTCHANNEL(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TROTRANSPORTCHANNEL) do + begin + RegisterVirtualConstructor(@TROTRANSPORTCHANNEL.CREATE, 'CREATE'); + end; +end; + +procedure RIRegisterTROMESSAGE(Cl: TPSRuntimeClassImporter); +Begin +with Cl.Add(TROMESSAGE) do + begin + RegisterVirtualConstructor(@TROMESSAGE.CREATE, 'CREATE'); + RegisterPropertyHelper(@TROMESSAGEMESSAGENAME_R,@TROMESSAGEMESSAGENAME_W,'MESSAGENAME'); + RegisterPropertyHelper(@TROMESSAGEINTERFACENAME_R,@TROMESSAGEINTERFACENAME_W,'INTERFACENAME'); + end; +end; + + +(*----------------------------------------------------------------------------*) +procedure SIRegister_TROBinaryMemoryStream(CL: TPSPascalCompiler); +begin + //with RegClassS(CL,'TMemoryStream', 'TROBinaryMemoryStream') do + with CL.AddClassN(CL.FindClass('TMemoryStream'),'TROBinaryMemoryStream') do + begin + RegisterMethod('Constructor Create2( const iString : Ansistring);'); + RegisterMethod('Constructor Create;'); + RegisterMethod('Procedure Assign( iSource : TStream)'); + RegisterMethod('Function Clone : TROBinaryMemoryStream'); + RegisterMethod('Procedure LoadFromString( const iString : Ansistring)'); + RegisterMethod('Procedure LoadFromHexString( const iString : Ansistring)'); + RegisterMethod('Function ToString : AnsiString'); + RegisterMethod('Function ToHexString : Ansistring'); + RegisterMethod('Function ToReadableString : Ansistring'); + RegisterMethod('Function WriteAnsiString( AString : AnsiString) : integer'); + RegisterProperty('CapacityIncrement', 'integer', iptrw); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure SIRegister_uROClasses(CL: TPSPascalCompiler); +begin + SIRegister_TROBinaryMemoryStream(CL); +end; + +(* === run-time registration functions === *) +(*----------------------------------------------------------------------------*) +procedure TROBinaryMemoryStreamCapacityIncrement_W(Self: TROBinaryMemoryStream; const T: integer); +begin Self.CapacityIncrement := T; end; + +(*----------------------------------------------------------------------------*) +procedure TROBinaryMemoryStreamCapacityIncrement_R(Self: TROBinaryMemoryStream; var T: integer); +begin T := Self.CapacityIncrement; end; + +(*----------------------------------------------------------------------------*) +Function TROBinaryMemoryStreamCreate_P(Self: TClass; CreateNewInstance: Boolean):TObject; +Begin Result := TROBinaryMemoryStream.Create; END; + +(*----------------------------------------------------------------------------*) +Function TROBinaryMemoryStreamCreate2_P(Self: TClass; CreateNewInstance: Boolean; const iString : Ansistring):TObject; +Begin Result := TROBinaryMemoryStream.Create(iString); END; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_TROBinaryMemoryStream(CL: TPSRuntimeClassImporter); +begin + with CL.Add(TROBinaryMemoryStream) do + begin + RegisterConstructor(@TROBinaryMemoryStreamCreate2_P, 'Create2'); + RegisterConstructor(@TROBinaryMemoryStreamCreate_P, 'Create'); + RegisterMethod(@TROBinaryMemoryStream.Assign, 'Assign'); + RegisterMethod(@TROBinaryMemoryStream.Clone, 'Clone'); + RegisterMethod(@TROBinaryMemoryStream.LoadFromString, 'LoadFromString'); + RegisterMethod(@TROBinaryMemoryStream.LoadFromHexString, 'LoadFromHexString'); + RegisterMethod(@TROBinaryMemoryStream.ToString, 'ToString'); + RegisterMethod(@TROBinaryMemoryStream.ToHexString, 'ToHexString'); + RegisterMethod(@TROBinaryMemoryStream.ToReadableString, 'ToReadableString'); + RegisterMethod(@TROBinaryMemoryStream.WriteAnsiString, 'WriteAnsiString'); + RegisterPropertyHelper(@TROBinaryMemoryStreamCapacityIncrement_R,@TROBinaryMemoryStreamCapacityIncrement_W,'CapacityIncrement'); + end; +end; + +(*----------------------------------------------------------------------------*) +procedure RIRegister_uROClasses(CL: TPSRuntimeClassImporter); +begin + RIRegister_TROBinaryMemoryStream(CL); +end; + + + +(*----------------------------------------------------------------------------*) + +type + TRoObjectInstance = class; + { } + IROClass = interface + ['{246B5804-461F-48EC-B2CA-FBB7B69B0D64}'] + function SLF: TRoObjectInstance; + end; + TRoObjectInstance = class(TInterfacedObject, IROClass) + private + FMessage: IROMessage; + FChannel: IROTransportChannel; + public + constructor Create; + function SLF: TRoObjectInstance; + property Message: IROMessage read FMessage write FMessage; + property Channel: IROTransportChannel read FChannel write FChannel; + end; + + + +function CreateProc(Caller: TPSExec; p: PIFProcRec; Global, Stack: TPSStack): Boolean; +var + temp, res: TPSVariantIFC; + Chan: TROTransportChannel; + Msg: TROMessage; + NewRes: TRoObjectInstance; +begin + res := NewTPSVariantIFC(Stack[Stack.count -1], True); + if (Res.Dta = nil) or (res.aType.BaseType <> btInterface) then + begin + Caller.CMD_Err2(erCustomError, 'RO Invoker: Invalid Parameters'); + Result := False; + exit; + end; + IUnknown(Res.Dta^) := nil; + + NewRes := TRoObjectInstance.Create; + + temp := NewTPSVariantIFC(Stack[Stack.Count -4], True); + + if (temp.aType <> nil) and (temp.Dta <> nil) and (Temp.aType.BaseType = btClass) and (TObject(Temp.Dta^) is TROTransportChannel) then + Chan := TROTransportChannel(temp.dta^) + else + Chan := nil; + temp := NewTPSVariantIFC(Stack[Stack.Count -3], True); + if (temp.aType <> nil) and (temp.Dta <> nil) and (Temp.aType.BaseType = btClass) and (TObject(Temp.Dta^) is TROMessage) then + Msg := TROMessage(temp.dta^) + else + Msg := nil; + if (msg = nil) or (chan = nil) then + begin + Chan.free; + msg.Free; + + NewRes.Free; + Result := false; + Caller.CMD_Err2(erCustomError, 'Could not create message'); + exit; + end; + + IRoClass(Res.Dta^) := NewRes; + + NewRes.Message := Msg; + NewRes.Channel := Chan; + Result := True; +end; + +function NilProc(Caller: TPSExec; p: PIFProcRec; Global, Stack: TPSStack): Boolean; +var + n: TPSVariantIFC; +begin + n := NewTPSVariantIFC(Stack[Stack.count -1], True); + if (n.Dta = nil) or (n.aType = nil) or (n.aType.BaseType <> btInterface) then + begin + Caller.CMD_Err2(erCustomError, 'RO Invoker: Cannot free'); + Result := False; + exit; + end; + IUnknown(n.Dta^) := nil; + Result := True; +end; + +type + TROStructure = class(TPersistent, IROCustomStreamableType, IROCustomStreamableStruct) + private + FVar: TPSVariantIFC; + FExec: TPSExec; + protected + function GetTypeName: string; + procedure SetTypeName(const s: string); + procedure Write(Serializer: TROSerializer; const Name: string); + procedure Read(Serializer: TROSerializer; const Name: string); + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function CanImplementType(const aName: string):boolean; + procedure SetNull(b: Boolean); + function IsNull: Boolean; + public + constructor Create(aVar: TPSVariantIfc; Exec: TPSExec); + end; + TROArray = class(TROStructure, IROCustomStreamableType, IROCustomStreamableStruct, IROCustomStreamableArray) + protected + function GetCount: Longint; + procedure SetCount(l: Longint); + end; + +procedure WriteUserDefined(Exec: TPSExec; const Msg: IROMessage; const Name: string; const n: TPSVariantIfc); +var + obj: TROStructure; +begin + if n.aType.BaseType = btArray then + obj := TROArray.Create(n, exec) + else if n.aType.BaseType = btRecord then + obj := TROStructure.Create(n, exec) + else + raise Exception.Create('Unknown custom type'); + try + Msg.Write(Name, obj.ClassInfo, obj, []); + finally + obj.Free; + end; +end; + +procedure ReadUserDefined(Exec: TPSExec; const Msg: IROMessage; const Name: string; const n: TPSVariantIfc); +var + obj: TROStructure; +begin + if n.aType.BaseType = btArray then + obj := TROArray.Create(n, exec) + else if n.aType.BaseType = btRecord then + obj := TROStructure.Create(n, exec) + else + raise Exception.Create('Unknown custom type'); + try + Msg.Read(Name, obj.ClassInfo, obj, []); + finally + obj.Free; + end; +end; + +function RoProc(Caller: TPSExec; p: TIFExternalProcRec; Global, Stack: TIfList): Boolean; +var + s, s2: string; + res, n: TPSVariantIFC; + aType: TRODataType; + aMode: TRODLParamFlag; + StartOffset, I: Longint; + __request, __response : TMemoryStream; + Inst: TRoObjectInstance; + +begin + s := p.Decl; + + if s[1] = #255 then + begin + n := NewTPSVariantIFC(Stack[Stack.Count -1], True); + res.Dta := nil; + res.aType := nil; + StartOffset := Stack.Count -2; + end + else + begin + n := NewTPSVariantIFC(Stack[Stack.Count -2], True); + res := NewTPSVariantIFC(Stack[Stack.Count -1], True); + StartOffset := Stack.Count -3; + end; + + if (n.Dta = nil) or (N.aType = nil) or (n.aType.BaseType <> btInterface) or (Longint(n.Dta^) = 0) then + begin + Caller.CMD_Err2(erCustomError, 'RO Invoker: Invalid Parameters'); + Result := False; + exit; + end; + + Inst := IROClass(n.dta^).Slf; + Delete(s, 1, 1); + i := StartOffset; + try + Inst.SLF.Message.InitializeRequestMessage(Inst.Channel, '', Copy(p.Name,1,pos('.', p.Name) -1), Copy(p.Name, pos('.', p.Name)+1, MaxInt)); + while Length(s) > 0 do + begin + s2 := copy(s, 2, ord(s[1])); + aMode := TRODLParamFlag(ord(s[length(s2)+2])); + aType := TRODataType(ord(s[length(s2)+3])); + Delete(s, 1, length(s2)+3); + n := NewTPSVariantIFC(Stack[i], True); + Dec(I); + if ((aMode = fIn) or (aMode = fInOut)) and (n.Dta <> nil) then + begin + case aType of + rtInteger: Inst.Message.Write(s2, TypeInfo(Integer), Integer(n.Dta^), []); + rtDateTime: Inst.Message.Write(s2, TypeInfo(DateTime), Double(n.Dta^), []); + rtDouble: Inst.Message.Write(s2, TypeInfo(Double), Double(n.Dta^), []); + rtCurrency: Inst.Message.Write(s2, TypeInfo(Double), Double(n.Dta^), []); + rtWideString: Inst.Message.Write(s2, TypeInfo(WideString), WideString(n.Dta^), []); + rtString: Inst.Message.Write(s2, TypeInfo(String), String(n.Dta^), []); + rtInt64: Inst.Message.Write(s2, TypeInfo(Int64), Int64(n.Dta^), []); + rtBoolean: Inst.Message.Write(s2, TypeInfo(Boolean), Byte(n.Dta^), []); + rtUserDefined: WriteUserDefined(Caller, Inst.Message, s2, n); + end; + end; + end; + __request := TMemoryStream.Create; + __response := TMemoryStream.Create; + try + Inst.Message.WriteToStream(__request); + Inst.Channel.Dispatch(__request, __response); + Inst.Message.ReadFromStream(__response); + finally + __request.Free; + __response.Free; + end; + s := p.Decl; + Delete(s, 1, 1); + i := StartOffset; + while Length(s) > 0 do + begin + s2 := copy(s, 2, ord(s[1])); + aMode := TRODLParamFlag(ord(s[length(s2)+2])); + aType := TRODataType(ord(s[length(s2)+3])); + Delete(s, 1, length(s2)+3); + n := NewTPSVariantIFC(Stack[i], True); + Dec(I); + if ((aMode = fOut) or (aMode = fInOut)) and (n.Dta <> nil) then + begin + case aType of + rtInteger: Inst.Message.Read(s2, TypeInfo(Integer), Longint(n.Dta^), []); + rtDateTime: Inst.Message.Read(s2, TypeInfo(DateTime), double(n.dta^), []); + rtDouble: Inst.Message.Read(s2, TypeInfo(Double), double(n.dta^), []); + rtCurrency: Inst.Message.Read(s2, TypeInfo(Double), double(n.dta^), []); + rtWideString: Inst.Message.Read(s2, TypeInfo(WideString), widestring(n.Dta^), []); + rtString: Inst.Message.Read(s2, TypeInfo(String), string(n.dta^), []); + rtInt64: Inst.Message.Read(s2, TypeInfo(Int64), Int64(n.Dta^), []); + rtBoolean: Inst.Message.Read(s2, TypeInfo(Boolean), Boolean(n.Dta^), []); + rtUserDefined: ReadUserDefined(Caller, Inst.Message, s2, n); + end; + end; + end; + aType := TRODataType(p.Decl[1]); + case aType of + rtInteger: Inst.Message.Read('Result', TypeInfo(Integer), Longint(res.Dta^), []); + rtDateTime: Inst.Message.Read('Result', TypeInfo(DateTime), Double(res.dta^), []); + rtDouble: Inst.Message.Read('Result', TypeInfo(Double), Double(res.Dta^), []); + rtCurrency: Inst.Message.Read('Result', TypeInfo(Double), double(res.Dta^), []); + rtWideString: Inst.Message.Read('Result', TypeInfo(WideString), WideString(res.Dta^), []); + rtString: Inst.Message.Read('Result', TypeInfo(String), String(res.Dta^), []); + rtInt64: Inst.Message.Read('Result', TypeInfo(Int64), Int64(res.dta^), []); + rtBoolean: Inst.Message.Read('Result', TypeInfo(Boolean), Boolean(res.dta^), []); + rtUserDefined: ReadUserDefined(Caller, Inst.Message, 'Result', res); + end; + except + on e: Exception do + begin + Caller.CMD_Err2(erCustomError, e.Message); + Result := False; + exit; + end; + end; + Result := True; +end; + +function SProcImport(Sender: TPSExec; p: TIFExternalProcRec; Tag: Pointer): Boolean; +var + s: string; +begin + s := p.Decl; + Delete(s, 1, pos(':', s)); + if s[1] = '-' then + p.ProcPtr := @NilProc + else if s[1] = '!' then + begin + P.ProcPtr := @CreateProc; + p.Decl := Copy(s, 2, MaxInt); + end else + begin + Delete(s, 1, 1); + p.Name := Copy(S,1,pos('!', s)-1); + Delete(s, 1, pos('!', s)); + p.Decl := s; + p.ProcPtr := @RoProc; + end; + Result := True; +end; + + +type + TMYComp = class(TPSPascalCompiler); + TRoClass = class(TPSExternalClass) + private + FService: TRODLService; + FNilProcNo: Cardinal; + FCompProcno: Cardinal; + function CreateParameterString(l: TRODLOperation): string; + function GetDT(DataType: string): TRODataType; + procedure MakeDeclFor(Dest: TPSParametersDecl; l: TRODLOperation); + public + constructor Create(Se: TPSPascalCompiler; Service: TRODLService; Const Typeno: TPSType); + + function SelfType: TPSType; override; + function Func_Find(const Name: tbtstring; var Index: Cardinal): Boolean; override; + function Func_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; override; + function SetNil(var ProcNo: Cardinal): Boolean; override; + + function ClassFunc_Find(const Name: tbtstring; var Index: Cardinal): Boolean; override; + function ClassFunc_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; override; + function IsCompatibleWith(Cl: TPSExternalClass): Boolean; override; + end; + +{ TROPSLink } +procedure TPSRemObjectsSdkPlugin.RODLLoadFromFile(const FileName: string); +var + f: TFileStream; +begin + f := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone); + try + RODLLoadFromStream(f); + finally + f.Free; + end; +end; + +procedure TPSRemObjectsSdkPlugin.RODLLoadFromResource; +var + rs: TResourceStream; +begin + rs := TResourceStream.Create(HInstance, 'RODLFILE', RT_RCDATA); + try + RODLLoadFromStream(rs); + finally + rs.Free; + end; +end; + +procedure TPSRemObjectsSdkPlugin.RODLLoadFromStream(S: TStream); +begin + FreeAndNil(FRodl); + with TXMLToRODL.Create do + begin + try + FRodl := Read(S); + finally + Free; + end; + end; +end; + + +destructor TPSRemObjectsSdkPlugin.Destroy; +begin + FreeAndNil(FRodl); + FModules.Free; + inherited Destroy; +end; + +{ TRoClass } + +constructor TRoClass.Create(Se: TPSPascalCompiler; Service: TRODLService; Const Typeno: TPSType); +begin + inherited Create(SE, TypeNo); + FService := Service; + FNilProcNo := Cardinal(-1); + FCompProcNo := Cardinal(-1); +end; + +function TRoClass.GetDT(DataType: string): TRODataType; +begin + DataType := LowerCase(DataType); + if DataType = 'integer' then + Result := rtInteger + else if DataType = 'datetime' then + Result := rtDateTime + else if DataType = 'double' then + Result := rtDouble + else if DataType = 'currency' then + Result := rtCurrency + else if DataType = 'widestring' then + Result := rtWidestring + else if DataType = 'string' then + Result := rtString + else if DataType = 'int64' then + Result := rtInt64 + else if DataType = 'boolean' then + Result := rtBoolean + else if DataType = 'variant' then + Result := rtVariant + else if DataType = 'binary' then + Result := rtBinary + else + Result := rtUserDefined; +end; + +function TRoClass.CreateParameterString(l: TRODLOperation): string; +var + i: Longint; +begin + if L.Result = nil then + begin + Result := #$FF; + end else + begin + Result := Chr(Ord(GetDT(l.Result.DataType))); + end; + for i := 0 to l.Count -1 do + begin + if l.Items[i].Flag = fResult then Continue; + Result := Result + Chr(Length(l.Items[i].Info.Name))+ l.Items[i].Info.Name + Chr(Ord(l.Items[i].Flag)) + Chr(Ord(GetDT(l.Items[i].DataType))); + end; +end; + +procedure TRoClass.MakeDeclFor(Dest: TPSParametersDecl; l: TRODLOperation); +var + i: Longint; + dd: TPSParameterDecl; +begin + if l.Result <> nil then + begin + Dest.Result := TMyComp(SE).at2ut(SE.FindType(l.Result.DataType)); + end; + for i := 0 to l.Count -1 do + begin + if l.Items[i].Flag = fResult then Continue; + dd := Dest.AddParam; + if l.Items[i].Flag = fIn then + dd.mode := pmIn + else + dd.Mode := pmInOut; + dd.OrgName := l.Items[i].Info.Name; + dd.aType := TMyComp(SE).at2ut(SE.FindType(l.Items[i].DataType)); + end; +end; + +function TRoClass.Func_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; +var + h, i: Longint; + s, e: string; + P: TPSProcedure; + p2: TPSExternalProcedure; +begin + s := 'roclass:_'+FService.Info.Name + '.' + FService.Default.Items[Index].Info.Name; + h := MakeHash(s); + for i := 0 to TMyComp(SE).FProcs.Count -1 do + begin + P := TMyComp(SE).FProcs[i]; + if (p is TPSExternalProcedure) then + begin + p2 := TPSExternalProcedure(p); + if (p2.RegProc.NameHash = h) and (Copy(p2.RegProc.ImportDecl, 1, pos(tbtchar('!'), p2.RegProc.ImportDecl)) = s) then + begin + Procno := I; + Result := True; + Exit; + end; + end; + end; + e := CreateParameterString(FService.Default.Items[Index]); + s := s + '!' + e; + ProcNo := TMyComp(SE).AddUsedFunction2(P2); + p2.RegProc := TPSRegProc.Create; + TMYComp(SE).FRegProcs.Add(p2.RegProc); + p2.RegProc.Name := ''; + p2.RegProc.ExportName := True; + MakeDeclFor(p2.RegProc.Decl, FService.Default.Items[Index]); + p2.RegProc.ImportDecl := s; + Result := True; +end; + +function TRoClass.Func_Find(const Name: tbtstring; var Index: Cardinal): Boolean; +var + i: Longint; +begin + for i := 0 to FService.Default.Count -1 do + begin + if CompareText(FService.Default.Items[i].Info.Name, Name) = 0 then + begin + Index := i; + Result := True; + Exit; + end; + end; + Result := False; +end; + +const + PSClassType = '!ROClass'; + MyGuid: TGuid = '{CADCCF37-7FA0-452E-971D-65DA691F7648}'; + +function TRoClass.SelfType: TPSType; +begin + Result := SE.FindType(PSClassType); + if Result = nil then + begin + Result := se.AddInterface(se.FindInterface('IUnknown'), MyGuid, PSClassType).aType; + end; +end; + +function TRoClass.SetNil(var ProcNo: Cardinal): Boolean; +var + P: TPSExternalProcedure; +begin + if FNilProcNo <> Cardinal(-1) then + ProcNo:= FNilProcNo + else + begin + ProcNo := TMyComp(SE).AddUsedFunction2(P); + p.RegProc := TPSRegProc.Create; + TMyComp(SE).FRegProcs.Add(p.RegProc); + p.RegProc.Name := ''; + p.RegProc.ExportName := True; + with p.RegProc.Decl.AddParam do + begin + OrgName := 'VarNo'; + aType := TMYComp(Se).at2ut(SelfType); + end; + p.RegProc.ImportDecl := 'roclass:-'; + FNilProcNo := Procno; + end; + Result := True; +end; + +function TRoClass.ClassFunc_Call(Index: Cardinal; + var ProcNo: Cardinal): Boolean; +var + P: TPSExternalProcedure; +begin + if FCompProcNo <> Cardinal(-1) then + begin + Procno := FCompProcNo; + Result := True; + Exit; + end; + ProcNo := TMyComp(SE).AddUsedFunction2(P); + p.RegProc := TPSRegProc.Create; + TMyComp(SE).FRegProcs.Add(p.RegProc); + p.RegProc.ExportName := True; + p.RegProc.Decl.Result := TMyComp(SE).at2ut(SelfType); + with p.RegProc.Decl.AddParam do + begin + Orgname := 'Message'; + aType :=TMyComp(SE).at2ut(SE.FindType('TROMESSAGE')); + end; + with p.RegProc.Decl.AddParam do + begin + Orgname := 'Channel'; + aType :=TMyComp(SE).at2ut(SE.FindType('TROTRANSPORTCHANNEL')); + end; + p.RegProc.ImportDecl := 'roclass:!'; + FCompProcNo := Procno; + Result := True; +end; + +function TRoClass.ClassFunc_Find(const Name: tbtstring; + var Index: Cardinal): Boolean; +begin + if Name = 'CREATE' then + begin + Result := True; + Index := 0; + end else + result := False; +end; + +function TRoClass.IsCompatibleWith(Cl: TPSExternalClass): Boolean; +begin + Result := Cl is TRoClass; +end; + +{ TRoObjectInstance } + +function TRoObjectInstance.SLF: TRoObjectInstance; +begin + Result := Self; +end; + +constructor TRoObjectInstance.Create; +begin + FRefCount := 1; +end; + + +function TPSRemObjectsSdkPlugin.MkStructName(Struct: TRODLStruct): string; +var + i: Longint; +begin + Result := '!ROStruct!'+Struct.Info.Name+ ','; + for i := 0 to Struct.Count -1 do + begin + Result := Result + Struct.Items[i].Info.Name+ ','; + end; +end; + +function CompareStructItem(const S1, S2: TRODLTypedEntity): Integer; +begin + Result := CompareText(S1.Info.Name, S2.Info.Name); +end; + +procedure SortStruct(struct: TRODLStruct; First, Last: Longint); +var + l, r, Pivot: Integer; +begin + while First < Last do + begin + Pivot := (First + Last) div 2; + l := First - 1; + r := Last + 1; + repeat + repeat inc(l); until CompareStructItem(Struct.Items[l], Struct.Items[Pivot]) >= 0; + repeat dec(r); until CompareStructItem(Struct.Items[r], Struct.Items[Pivot]) <= 0; + if l >= r then break; + Struct.Exchange(l, r); + until false; + if First < r then SortStruct(Struct, First, r); + First := r+1; + end; +end; + +procedure TPSRemObjectsSdkPlugin.CompileImport1(CompExec: TPSScript); +var + i, i1: Longint; + Enum: TRODLEnum; + TempType: TPSType; + Struct: TRODLStruct; + Arr: TRODLArray; + RecType: TPSRecordFieldTypeDef; + Service: TRODLService; +begin + if FRODL = nil then exit; + if CompExec.Comp.FindType('TDateTime') = nil then + raise Exception.Create('Please register the DateUtils library first'); + if CompExec.Comp.FindType('TStream') = nil then + raise Exception.Create('Please register the sysutils/classes library first'); + SIRegisterTROTRANSPORTCHANNEL(CompExec.Comp); + SIRegisterTROMESSAGE(CompExec.Comp); + SIRegister_uROClasses(CompExec.Comp); + CompExec.Comp.AddTypeCopyN('Binary', 'TROBinaryMemoryStream'); + if CompExec.Comp.FindType('DateTime') = nil then + CompExec.Comp.AddTypeCopyN('DateTime', 'TDateTime'); + if CompExec.Comp.FindType('Currency') = nil then + CompExec.Comp.AddTypeCopyN('Currency', 'Double'); // for now + for i := 0 to FRodl.EnumCount -1 do + begin + Enum := FRodl.Enums[i]; + TempType := CompExec.Comp.AddType(Enum.Info.Name, btEnum); + for i1 := 0 to Enum.Count -1 do + begin + CompExec.Comp.AddConstant(Enum.Items[i1].Info.Name, TempType).SetUInt(i1); + end; + end; + for i := 0 to FRodl.StructCount -1 do + begin + Struct := FRodl.Structs[i]; + SortStruct(Struct, 0, Struct.Count-1); + TempType := CompExec.Comp.AddType('', btRecord); + TempType.ExportName := True; + TempType.Name := MkStructName(Struct); + for i1 := 0 to Struct.Count -1 do + begin + RecType := TPSRecordType(TempType).AddRecVal; + RecType.FieldOrgName := Struct.Items[i1].Info.Name; + RecType.aType := CompExec.Comp.FindType(Struct.Items[i1].DataType); + if RecType.aType = nil then begin + Arr := fRodl.FindArray(Struct.Items[i1].DataType); + if Arr <> nil then begin + RecType.aType := CompExec.Comp.AddType(Arr.Info.Name, btArray); + TPSArrayType(RecType.aType).ArrayTypeNo := CompExec.Comp.FindType(Arr.ElementType); + end; + end; + end; + CompExec.Comp.AddTypeCopy(Struct.Info.Name, TempType); + end; + for i := 0 to FRodl.ArrayCount -1 do + begin + Arr := FRodl.Arrays[i]; + TempType := CompExec.Comp.FindType(Arr.Info.Name); + if TempType <> nil then begin + if not (TempType is TPSArrayType) then begin + CompExec.Comp.MakeError('ROPS', ecDuplicateIdentifier, Arr.Info.Name); + end; + end else begin + TempType := CompExec.Comp.AddType(Arr.Info.Name, btArray); + end; + TPSArrayType(TempType).ArrayTypeNo := CompExec.Comp.FindType(Arr.ElementType); + end; + for i := 0 to FRodl.ServiceCount -1 do + begin + Service := FRodl.Services[i]; + TempType := CompExec.Comp.AddType(Service.Info.Name, btExtClass); + TPSUndefinedClassType(TempType).ExtClass := TRoClass.Create(CompExec.Comp, Service, TempType); + end; + for i := 0 to FModules.Count -1 do + TPSROModuleClass(FModules[i]).CompImp(CompExec.Comp); +end; + +function TPSRemObjectsSdkPlugin.GetHaveRodl: Boolean; +begin + Result := FRodl <> nil; +end; + +procedure TPSRemObjectsSdkPlugin.ClearRodl; +begin + FRodl.Free; + FRodl := nil; +end; + +procedure TPSRemObjectsSdkPlugin.ExecImport1(CompExec: TPSScript; + const ri: TPSRuntimeClassImporter); +var + i: Longint; +begin + if FRODL = nil then exit; + CompExec.Exec.AddSpecialProcImport('roclass', SProcImport, nil); + RIRegisterTROTRANSPORTCHANNEL(ri); + RIRegisterTROMESSAGE(ri); + RIRegister_TROBinaryMemoryStream(ri); + for i := 0 to FModules.Count -1 do + TPSROModuleClass(FModules[i]).ExecImp(CompExec.Exec, ri); +end; + +constructor TPSRemObjectsSdkPlugin.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FModules := TList.Create; + //FEnableSOAP := True; + FEnableBinary := True; + FEnableIndyTCP := True; + FEnableIndyHTTP := True; +end; + +procedure TPSRemObjectsSdkPlugin.Loaded; +begin + inherited Loaded; + ReloadModules; +end; + +procedure TPSRemObjectsSdkPlugin.RegisterModule( + Module: TPSROModuleClass); +begin + FModules.Add(Module); +end; + +procedure TPSRemObjectsSdkPlugin.ReloadModules; +begin + FModules.Clear; + if FEnableIndyTCP then RegisterModule(TPSROIndyTCPModule); + if FEnableIndyHTTP then RegisterModule(TPSROIndyHTTPModule); + //if FEnableSOAP then RegisterModule(TPSROSoapModule); + if FEnableBinary then RegisterModule(TPSROBinModule); + if assigned(FOnLoadModule) then + FOnLoadModule(Self); +end; + +{ TPSROModule } + +class procedure TPSROModule.CompImp(comp: TPSPascalCompiler); +begin + // do nothing +end; + +class procedure TPSROModule.ExecImp(exec: TPSExec; + ri: TPSRuntimeClassImporter); +begin + // do nothing +end; + +procedure IntRead(Exec: TPSExec; Serializer: TROSerializer; + const Name: string; aVar: TPSVariantIFC; arridx: Longint); +var + i: Longint; + s, s2: string; + r: TROStructure; +begin + case aVar.aType.BaseType of + btS64: Serializer.Read(Name, TypeInfo(int64), Int64(avar.Dta^), arridx); + btu32: Serializer.Read(Name, TypeInfo(cardinal), Cardinal(avar.Dta^), arridx); + bts32: Serializer.Read(Name, TypeInfo(longint), Longint(avar.Dta^), arridx); + btu16: Serializer.Read(Name, TypeInfo(word), Word(aVar.Dta^), arridx); + btS16: Serializer.Read(Name, TypeInfo(smallint), Smallint(aVar.Dta^), arridx); + btu8: Serializer.Read(Name, TypeInfo(byte), Byte(aVar.Dta^), arridx); + btS8: Serializer.Read(Name, TypeInfo(shortint), Shortint(aVar.Dta^), arridx); + btDouble: + begin + if aVar.aType.ExportName = 'TDATETIME' then + Serializer.Read(Name, TypeInfo(datetime), Double(avar.Dta^), arridx) + else + Serializer.Read(Name, TypeInfo(double), Double(aVar.Dta^), arridx); + end; + btSingle: Serializer.Read(Name, TypeInfo(single), Single(avar.Dta^), arridx); + btExtended: Serializer.Read(Name, TypeInfo(extended), Extended(avar.dta^), arridx); + btWideString: Serializer.Read(Name, TypeInfo(widestring), widestring(avar.dta^), arridx); + btString: Serializer.Read(Name, TypeInfo(string), string(avar.dta^), arridx); + btArray: + begin + if (TPSTypeRec_Array(avar.aType).ArrayType.BaseType = btRecord) then + begin + for i := 0 to PSDynArrayGetLength(Pointer(aVar.Dta^), aVar.aType) -1 do + begin + r := TROStructure.Create(PSGetArrayField(avar, i), Exec); + try + Serializer.Read(Name, typeinfo(TROArray), r, i); + finally + r.Free; + end; + end; + end else if (TPSTypeRec_Array(avar.aType).ArrayType.BaseType = btArray) then + begin + for i := 0 to PSDynArrayGetLength(Pointer(aVar.Dta^), aVar.aType) -1 do + begin + r := TROArray.Create(PSGetArrayField(avar, i), Exec); + try + Serializer.Read(Name, typeinfo(TROArray), r, i); + finally + r.Free; + end; + end; + end else begin + for i := 0 to PSDynArrayGetLength(Pointer(aVar.Dta^), aVar.aType) -1 do + begin + IntRead(Exec, Serializer, Name, PSGetArrayField(avar, i), i); + end; + end; + end; + btRecord: + begin + s := avar.aType.ExportName; + if copy(s,1, 10) <> '!ROStruct!' then + raise Exception.Create('Invalid structure: '+s); + Delete(s,1,pos(',',s)); + for i := 0 to TPSTypeRec_Record(aVar.aType).FieldTypes.Count -1 do + begin + s2 := copy(s,1,pos(',',s)-1); + delete(s,1,pos(',',s)); + if (TPSTypeRec(TPSTypeRec_Record(aVar.aType).FieldTypes[i]).BaseType = btRecord) then + begin + + r := TROStructure.Create(PSGetRecField(aVar, i), Exec); + try + Serializer.Read(s2, typeinfo(TROStructure), r, -1); + finally + r.Free; + end; + end else if (TPSTypeRec(TPSTypeRec_Record(aVar.aType).FieldTypes[i]).BaseType = btArray) then + begin + r := TROArray.Create(PSGetRecField(aVar, i), Exec); + try + Serializer.Read(s2, typeinfo(TROArray), r, -1); + finally + r.Free; + end; + end else + IntRead(Exec, Serializer, s2, PSGetRecField(aVar, i), -1); + end; + end; + else + raise Exception.Create('Unable to read type'); + + end; +end; + +procedure IntWrite(Exec: TPSExec; Serializer: TROSerializer; + const Name: string; aVar: TPSVariantIFC; arridx: Longint); +var + i: Longint; + s, s2: string; + r: TROStructure; +begin + case aVar.aType.BaseType of + btS64: Serializer.Write(Name, TypeInfo(int64), Int64(avar.Dta^), arridx); + btu32: Serializer.Write(Name, TypeInfo(cardinal), Cardinal(avar.Dta^), arridx); + bts32: Serializer.Write(Name, TypeInfo(longint), Longint(avar.Dta^), arridx); + btu16: Serializer.Write(Name, TypeInfo(word), Word(avar.Dta^), arridx); + btS16: Serializer.Write(Name, TypeInfo(smallint), Smallint(aVar.Dta^), arridx); + btu8: Serializer.Write(Name, TypeInfo(byte), Byte(aVar.Dta^), arridx); + btS8: Serializer.Write(Name, TypeInfo(shortint), ShortInt(aVar.Dta^), arridx); + btDouble: + begin + if aVar.aType.ExportName = 'TDATETIME' then + Serializer.Write(Name, TypeInfo(datetime), Double(aVar.Dta^), arridx) + else + Serializer.Write(Name, TypeInfo(double), Double(aVar.Dta^), arridx); + end; + btSingle: Serializer.Write(Name, TypeInfo(single), Single(aVar.Dta^), arridx); + btExtended: Serializer.Write(Name, TypeInfo(extended), Extended(aVar.Dta^), arridx); + btWideString: Serializer.Write(Name, TypeInfo(widestring), WideString(aVar.Dta^), arridx); + btString: Serializer.Write(Name, TypeInfo(string), String(aVar.Dta^), arridx); + btArray: + begin + if (TPSTypeRec_Array(avar.aType).ArrayType.BaseType = btRecord) then + begin + for i := 0 to PSDynArrayGetLength(Pointer(aVar.Dta^), aVar.aType) -1 do + begin + r := TROStructure.Create(PSGetArrayField(aVar, i), Exec); + try + Serializer.Write(Name, typeinfo(TROArray), r, i); + finally + r.Free; + end; + end; + end else if (TPSTypeRec_Array(avar.aType).ArrayType.BaseType = btArray) then + begin + for i := 0 to PSDynArrayGetLength(Pointer(aVar.Dta^), aVar.aType) -1 do + begin + r := TROArray.Create(PSGetArrayField(aVar, i), Exec); + try + Serializer.Write(Name, typeinfo(TROArray), r, i); + finally + r.Free; + end; + end; + end else begin + for i := 0 to PSDynArrayGetLength(Pointer(aVar.Dta^), aVar.aType) -1 do + begin + IntWrite(Exec, Serializer, Name, PSGetArrayField(aVar, i), i); + end; + end; + end; + btRecord: + begin + s := avar.aType.ExportName; + if copy(s,1, 10) <> '!ROStruct!' then + raise Exception.Create('Invalid structure: '+s); + Delete(s,1,pos(',',s)); + for i := 0 to TPSTypeRec_Record(aVar.aType).FieldTypes.Count -1 do + begin + s2 := copy(s,1,pos(',',s)-1); + delete(s,1,pos(',',s)); + if (TPSTypeRec(TPSTypeRec_Record(aVar.aType).FieldTypes[i]).BaseType = btRecord) then + begin + r := TROStructure.Create(PSGetRecField(aVar, i), Exec); + try + Serializer.Write(s2, typeinfo(TROStructure), r, -1); + finally + r.Free; + end; + end else if (TPSTypeRec(TPSTypeRec_Record(aVar.aType).FieldTypes[i]).BaseType = btArray) then + begin + r := TROArray.Create(PSGetRecField(aVar, i), Exec); + try + Serializer.Write(s2, typeinfo(TROArray), r, -1); + finally + r.Free; + end; + end else + IntWrite(Exec, Serializer, s2, PSGetRecField(aVar, i), -1); + end; + end; + else + raise Exception.Create('Unable to read type'); + + end; +end; + +{ TROStructure } + +constructor TROStructure.Create(aVar: TPSVariantIfc; Exec: TPSExec); +begin + inherited Create; + FVar := aVar; + FExec := Exec; +end; + +function TROStructure.IsNull: Boolean; +begin + Result := False; +end; + +function TROStructure.QueryInterface(const IID: TGUID; + out Obj): HResult; +begin + if GetInterface(IID, Obj) then + Result := 0 + else + Result := E_NOINTERFACE; +end; + +procedure TROStructure.Read(Serializer: TROSerializer; + const Name: string); +begin + IntRead(FExec, Serializer, Name, FVar, -1); +end; + +procedure TROStructure.SetNull(b: Boolean); +begin + // null not supported +end; + +function TROStructure.GetTypeName: string; +var + s: string; +begin + s := fvar.atype.ExportName; + delete(s,1,1); + delete(s,1,pos('!', s)); + result := copy(s,1,pos(',',s)-1); +end; + +procedure TROStructure.Write(Serializer: TROSerializer; + const Name: string); +begin + IntWrite(FExec, Serializer, Name, FVar, -1); +end; + + +function TROStructure._AddRef: Integer; +begin + // do nothing + Result := 1; +end; + +function TROStructure._Release: Integer; +begin + // do nothing + Result := 1; +end; + +function TROStructure.CanImplementType(const aName: string): boolean; +begin + if SameText(aName, Self.GetTypeName) then + Result := True + else + Result := False; +end; + +procedure TROStructure.SetTypeName(const s: string); +begin + // Do nothing +end; + +{ TROArray } + +function TROArray.GetCount: Longint; +begin + + // we should have an array in pVar now so assume that's true + Result := PSDynArrayGetLength(Pointer(fVar.Dta^), fvar.aType); +end; + +procedure TROArray.SetCount(l: Integer); +begin + PSDynArraySetLength(Pointer(fVAr.Dta^), fVar.aType, l); +end; + +end. diff --git a/Units/PascalScript/x64.inc b/Units/PascalScript/x64.inc new file mode 100644 index 0000000..5150142 --- /dev/null +++ b/Units/PascalScript/x64.inc @@ -0,0 +1,513 @@ +{ implementation of x64 abi } +//procedure DebugBreak; external 'Kernel32.dll'; +const + EmptyPchar: array[0..0] of char = #0; +{$ASMMODE INTEL} + +{$IFDEF WINDOWS} +procedure x64call( + Address: Pointer; + out _RAX: IPointer; + _RCX, _RDX, _R8, _R9: IPointer; + var _XMM0: Double; + _XMM1, _XMM2, _XMM3: Double; + aStack: Pointer; aItems: Integer); assembler; nostackframe; +asm +(* Registers: + RCX: Address + RDX: *_RAX + R8: _RCX + R9: _RDX + + fpc inserts an 20h emty space +*) + push ebp + mov ebp,esp +// call debugbreak + push rcx // address + push rdx // _rax + push r8 // _rcx + push r9 // _rdx + mov rcx, aItems + mov rdx, aStack + jmp @compareitems +@work: + push [rdx] + dec rcx + sub rdx,8 +@compareitems: + or rcx, rcx + jnz @work + + // copy registers + movd xmm0,[_XMM0] + movd xmm1,_XMM1 + movd xmm2,_XMM2 + movd xmm3,_XMM3 + mov RAX, [rbp-8] + mov RCX, [rbp-24] + mov RDX, [rbp-32] + mov R8, _R8 + mov R9, _R9 + + // weird thing on windows, it needs 32 bytes in the CALLEE side to do whatever in + sub RSP, 32 + + call RAX + + add RSP, 32 // undo the damage done earlier + + // copy result back + mov RDX, [rbp-16] + mov [RDX], RAX + movd [_XMM0],xmm0 + + pop r9 + pop r8 + pop rdx + pop rcx + leave + ret +end; +{$ELSE} +procedure x64call( + Address: Pointer; + out _RAX: IPointer; + _RDI, _RSI, _RDX, _RCX, _R8, _R9: IPointer; + var _XMM0: Double; + _XMM1, _XMM2, _XMM3, _XMM4, _XMM5, _XMM6, _XMM7: Double; + aStack: Pointer; aItems: Integer); assembler; nostackframe; + + +asm +(* Registers: + RDI: Address + RSI: _RAX + RDX: _RDI + RCX: _RSI + R8: _RDX + R9: _RCX + + +*) + push ebp + mov ebp,esp + push rdi // address + push rsi // _rax + push rdx // _rdi + push rcx // _rsi + push r8 // _rdx + push r9 // _rcx + mov rcx, aItems + mov rdx, aStack + jmp @compareitems +@work: + push [rdx] + dec rcx + sub rdx,8 +@compareitems: + or rcx, rcx + jnz @work + + // copy registers + movd xmm0,[_XMM0] + movd xmm1,_XMM1 + movd xmm2,_XMM2 + movd xmm3,_XMM3 + movd xmm4,_XMM4 + movd xmm5,_XMM5 + movd xmm6,_XMM6 + movd xmm7,_XMM7 + mov RAX, [rbp-8] + mov RDI, [rbp-24] + mov RSI, [rbp-32] + mov RDX, [rbp-40] + mov RCX, [rbp-48] + mov R8, _R8 + mov R9, _R9 + + // weird thing on windows, it needs 32 bytes in the CALLEE side to do whatever in; not sure about linux + //sub RSP, 32 + + call RAX + + // add RSP, 32 // undo the damage done earlier + + // copy result back + mov RDX, [rbp-16] + mov [RDX], RAX + movd [_XMM0],xmm0 + + pop r9 + pop r8 + pop rdx + pop rcx + pop rsi + pop rdi + leave + ret +end; +{$ENDIF} + +function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean; +var + Stack: array of Byte; + _RAX, +{$IFDEF WINDOWS} + _RCX, _RDX, _R8, _R9: IPointer; + _XMM0, _XMM1, _XMM2, _XMM3: Double; +{$ELSE} + _RDI, _RSI, _RDX, _RCX, _R8, _R9: IPointer; + _XMM0, _XMM1, _XMM2, _XMM3, _XMM4, _XMM5, _XMM6, _XMM7: Double; + RegUsageFloat: Byte; +{$ENDIF} + RegUsage: Byte; + CallData: TPSList; + I: Integer; + pp: ^Byte; + + function rp(p: PPSVariantIFC): PPSVariantIFC; + begin + if p = nil then + begin + result := nil; + exit; + end; + if p.aType.BaseType = btPointer then + begin + p^.aType := Pointer(Pointer(IPointer(p^.dta) + PointerSize)^); + p^.Dta := Pointer(p^.dta^); + end; + Result := p; + end; +{$IFDEF WINDOWS} + procedure StoreReg(data: IPointer); overload; + var p: Pointer; + begin + case RegUsage of + 0: begin inc(RegUsage); _RCX:=Data; end; + 1: begin inc(RegUsage); _RDX:=Data; end; + 2: begin inc(RegUsage); _R8:=Data; end; + 3: begin inc(RegUsage); _R9:=Data; end; + else begin + SetLength(Stack, Length(Stack)+8); + p := @Stack[LEngth(Stack)-8]; + IPointer(p^) := data; + end; + end; + end; + {$ELSE} + procedure StoreReg(data: IPointer); overload; + var p: Pointer; + begin + case RegUsage of + 0: begin inc(RegUsage); _RDI:=Data; end; + 1: begin inc(RegUsage); _RSI:=Data; end; + 2: begin inc(RegUsage); _RDX:=Data; end; + 3: begin inc(RegUsage); _RCX:=Data; end; + 4: begin inc(RegUsage); _R8:=Data; end; + 5: begin inc(RegUsage); _R9:=Data; end; + else begin + SetLength(Stack, Length(Stack)+8); + p := @Stack[LEngth(Stack)-8]; + IPointer(p^) := data; + end; + end; + end; +{$ENDIF} + + procedure StoreStack(const aData; Len: Integer); + var + p: Pointer; + begin + if Len > 8 then + if Length(Stack) mod 16 <> 0 then begin + SetLength(Stack, Length(Stack)+ (16-(Length(Stack) mod 16))); + end; + SetLength(Stack, Length(Stack)+Len); + p := @Stack[Length(Stack)-Len]; + Move(aData, p^, Len); + end; + +{$IFDEF WINDOWS} + procedure StoreReg(data: Double); overload; + var p: Pointer; + begin + case RegUsage of + 0: begin inc(RegUsage); _XMM0:=Data; end; + 1: begin inc(RegUsage); _XMM1:=Data; end; + 2: begin inc(RegUsage); _XMM2:=Data; end; + 3: begin inc(RegUsage); _XMM3:=Data; end; + else begin + SetLength(Stack, Length(Stack)+8); + p := @Stack[LEngth(Stack)-8]; + Double(p^) := data; + end; + end; + end; + {$ELSE} + procedure StoreReg(data: Double); overload; + var p: Pointer; + begin + case RegUsageFloat of + 0: begin inc(RegUsageFloat); _XMM0:=Data; end; + 1: begin inc(RegUsageFloat); _XMM1:=Data; end; + 2: begin inc(RegUsageFloat); _XMM2:=Data; end; + 3: begin inc(RegUsageFloat); _XMM3:=Data; end; + 4: begin inc(RegUsageFloat); _XMM4:=Data; end; + 5: begin inc(RegUsageFloat); _XMM5:=Data; end; + 6: begin inc(RegUsageFloat); _XMM6:=Data; end; + 7: begin inc(RegUsageFloat); _XMM7:=Data; end; + else begin + SetLength(Stack, Length(Stack)+8); + p := @Stack[LEngth(Stack)-8]; + Double(p^) := data; + end; + end; + end; + {$ENDIF} + function GetPtr(fVar: PPSVariantIFC): Boolean; + var + varPtr: Pointer; + //UseReg: Boolean; + //tempstr: tbtstring; + p: Pointer; + begin + Result := False; + if FVar = nil then exit; + if fVar.VarParam then + begin + case fvar.aType.BaseType of + btArray: + begin + if Copy(fvar.aType.ExportName, 1, 10) = '!OPENARRAY' then + begin + p := CreateOpenArray(True, Self, FVar); + if p = nil then exit; + CallData.Add(p); + StoreReg(IPointer(POpenArray(p)^.Data)); + StoreReg(IPointer(POpenArray(p)^.ItemCount -1)); + Result := True; + Exit; + end else begin + varptr := fvar.Dta; +// Exit; + end; + end; + btVariant, + btSet, + btStaticArray, + btRecord, + btInterface, + btClass, + {$IFNDEF PS_NOWIDESTRING} btUnicodeString, btWideString, btWideChar, {$ENDIF} btU8, btS8, btU16, + btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency + {$IFNDEF PS_NOINT64}, bts64{$ENDIF}: + begin + Varptr := fvar.Dta; + end; + else begin + exit; //invalid type + end; + end; {case} + + StoreReg(IPointer(VarPtr)); + end else begin +// UseReg := True; + case fVar^.aType.BaseType of + btSet: + begin + case TPSTypeRec_Set(fvar.aType).aByteSize of + 1: StoreReg(IPointer(byte(fvar.dta^))); + 2: StoreReg(IPointer(word(fvar.dta^))); + 3, 4: StoreReg(IPointer(cardinal(fvar.dta^))); + 5,6,7,8: StoreReg(IPointer(fVar.Dta^)); + else + StoreReg(IPointer(fvar.Dta)); + end; + end; + btArray: + begin + if Copy(fvar^.aType.ExportName, 1, 10) = '!OPENARRAY' then + begin + p := CreateOpenArray(False, SElf, FVar); + if p =nil then exit; + CallData.Add(p); + StoreReg(IPointer(POpenArray(p)^.Data)); + StoreReg(IPointer(POpenArray(p)^.ItemCount -1)); + Result := True; + exit; + end else begin + StoreReg(IPointer(FVar.Dta^)); + end; + end; + btVariant + , btStaticArray, btRecord: + begin + StoreReg(IPointer(fVar.Dta)); + end; + btExtended, btDouble: {8 bytes} begin + StoreReg(double(fvar.dta^)); + end; + btCurrency: {8 bytes} begin + StoreReg(IPointer(fvar.dta^)); + end; + btSingle: {4 bytes} begin + StoreReg(single(fvar.dta^)); + end; + + btChar, + btU8, + btS8: begin + StoreReg(IPointer(byte(fVar^.dta^))); + end; + btWideChar, + btu16, btS16: begin + StoreReg(IPointer(word(fVar^.dta^))); + end; + btu32, bts32: begin + StoreReg(IPointer(cardinal(fVar^.dta^))); + end; + btPchar: + begin + if pointer(fvar^.dta^) = nil then + StoreReg(IPointer(@EmptyPchar)) + else + StoreReg(IPointer(fvar^.dta^)); + end; + btclass, btinterface, btString: + begin + StoreReg(IPointer(fvar^.dta^)); + end; + btWideString: begin + StoreReg(IPointer(fvar^.dta^)); + end; + btUnicodeString: begin + StoreReg(IPointer(fvar^.dta^)); + end; + + btProcPtr: + begin + GetMem(p, PointerSize2); + TMethod(p^) := MKMethod(Self, Longint(FVar.Dta^)); + StoreStack(p^, Pointersize2); + FreeMem(p); + end; + + bts64: + begin + StoreReg(IPointer(int64(fvar^.dta^))); + end; + end; {case} + end; + Result := True; + end; +begin + InnerfuseCall := False; + if Address = nil then + exit; // need address + SetLength(Stack, 0); + CallData := TPSList.Create; + res := rp(res); + if res <> nil then + res.VarParam := true; + try +{$IFNDEF WINDOWS} + _RSI := 0; + _RDI := 0; + _XMM4 := 0; + _XMM5 := 0; + _XMM6 := 0; + _XMM7 := 0; + RegUsageFloat := 0; +{$ENDIF} + _RCX := 0; + _RDX := 0; + _R8 := 0; + _R9 := 0; + _XMM0 := 0; + _XMM1 := 0; + _XMM2 := 0; + _XMM3 := 0; + RegUsage := 0; + if assigned(_Self) then begin + RegUsage := 1; + _RCX := IPointer(_Self); + end; + for I := 0 to Params.Count - 1 do + begin + if not GetPtr(rp(Params[I])) then Exit; + end; + + if assigned(res) then begin + case res^.aType.BaseType of + {$IFDEF x64_string_result_as_varparameter} + btstring, btWideString, btUnicodeString, + {$ENDIF} + btInterface, btArray, btrecord, btVariant, btStaticArray: GetPtr(res); + btSet: + begin + if TPSTypeRec_Set(res.aType).aByteSize > PointerSize then GetPtr(res); + end; + end; + if Stack = nil then pp := nil else pp := @Stack[Length(Stack) -8]; +{$IFDEF WINDOWS} + x64call(Address, _RAX, _RCX, _RDX, _R8, _R9, _XMM0, _XMM1, _XMM2, _XMM3, pp, Length(Stack) div 8); +{$ELSE} + x64call(Address, _RAX, _RDI, _RSI, _RDX, _RCX, _R8, _R9,_XMM0,_XMM1, _XMM2, _XMM3, _XMM4, _XMM5, _XMM6, _XMM7, pp, Length(Stack) div 8); +{$ENDIF} + case res^.aType.BaseType of + btSet: + begin + case TPSTypeRec_Set(res.aType).aByteSize of + 1: byte(res.Dta^) := _RAX; + 2: word(res.Dta^) := _RAX; + 3, + 4: Longint(res.Dta^) := _RAX; + 5,6,7,8: IPointer(res.dta^) := _RAX; + end; + end; + btSingle: tbtsingle(res.Dta^) := _XMM0; + btDouble: tbtdouble(res.Dta^) := _XMM0; + btExtended: tbtextended(res.Dta^) := _XMM0; + btchar,btU8, btS8: tbtu8(res.dta^) := _RAX; + btWideChar, btu16, bts16: tbtu16(res.dta^) := _RAX; + btClass : IPointer(res.dta^) := _RAX; + btu32,bts32: tbtu32(res.dta^) := _RAX; + btPChar: pansichar(res.dta^) := Pansichar(_RAX); + bts64: tbts64(res.dta^) := Int64(_RAX); + btCurrency: tbtCurrency(res.Dta^) := Int64(_RAX); + btInterface, + btVariant, + {$IFDEF x64_string_result_as_varparameter} + btWidestring,btUnicodestring, btstring , + {$ENDIF} + btStaticArray, btArray, btrecord:; + {$IFNDEF x64_string_result_as_varparameter} + btUnicodeString, btWideString, btstring: Int64(res.dta^) := _RAX; + {$ENDIF} + else + exit; + end; + end else begin + if Stack = nil then pp := nil else pp := @Stack[Length(Stack) -8]; +{$IFDEF WINDOWS} + x64call(Address, _RAX, _RCX, _RDX, _R8, _R9, _XMM0, _XMM1, _XMM2, _XMM3, pp, Length(Stack) div 8); +{$ELSE} + x64call(Address, _RAX, _RDI, _RSI, _RDX, _RCX, _R8, _R9,_XMM0,_XMM1, _XMM2, _XMM3, _XMM4, _XMM5, _XMM6, _XMM7, pp, Length(Stack) div 8); +{$ENDIF} + end; + Result := True; + finally + for i := CallData.Count -1 downto 0 do + begin + pp := CallData[i]; + case pp^ of + 0: DestroyOpenArray(Self, Pointer(pp)); + end; + end; + CallData.Free; + end; +end; + + diff --git a/Units/PascalScript/x86.inc b/Units/PascalScript/x86.inc new file mode 100644 index 0000000..baa7641 --- /dev/null +++ b/Units/PascalScript/x86.inc @@ -0,0 +1,739 @@ +{ implementation of x86 abi } +{$ifdef FPC} +{$define PS_ARRAY_ON_STACK} +{$endif} +function RealFloatCall_Register(p: Pointer; + _EAX, _EDX, _ECX: Cardinal; + StackData: Pointer; + StackDataLen: Longint // stack length are in 4 bytes. (so 1 = 4 bytes) + ): Extended; Stdcall; // make sure all things are on stack +var + E: Extended; +begin + asm + mov ecx, stackdatalen + jecxz @@2 + mov eax, stackdata + @@1: + mov edx, [eax] + push edx + sub eax, 4 + dec ecx + or ecx, ecx + jnz @@1 + @@2: + mov eax,_EAX + mov edx,_EDX + mov ecx,_ECX + call p + fstp tbyte ptr [e] + end; + Result := E; +end; + +function RealFloatCall_Other(p: Pointer; + StackData: Pointer; + StackDataLen: Longint // stack length are in 4 bytes. (so 1 = 4 bytes) + ): Extended; Stdcall; // make sure all things are on stack +var + E: Extended; +begin + asm + mov ecx, stackdatalen + jecxz @@2 + mov eax, stackdata + @@1: + mov edx, [eax] + push edx + sub eax, 4 + dec ecx + or ecx, ecx + jnz @@1 + @@2: + call p + fstp tbyte ptr [e] + end; + Result := E; +end; + +function RealFloatCall_CDecl(p: Pointer; + StackData: Pointer; + StackDataLen: Longint // stack length are in 4 bytes. (so 1 = 4 bytes) + ): Extended; Stdcall; // make sure all things are on stack +var + E: Extended; +begin + asm + mov ecx, stackdatalen + jecxz @@2 + mov eax, stackdata + @@1: + mov edx, [eax] + push edx + sub eax, 4 + dec ecx + or ecx, ecx + jnz @@1 + @@2: + call p + fstp tbyte ptr [e] + @@5: + mov ecx, stackdatalen + jecxz @@2 + @@6: + pop edx + dec ecx + or ecx, ecx + jnz @@6 + end; + Result := E; +end; + +function RealCall_Register(p: Pointer; + _EAX, _EDX, _ECX: Cardinal; + StackData: Pointer; + StackDataLen: Longint; // stack length are in 4 bytes. (so 1 = 4 bytes) + ResultLength: Longint; ResEDX: Pointer): Longint; Stdcall; // make sure all things are on stack +var + r: Longint; +begin + asm + mov ecx, stackdatalen + jecxz @@2 + mov eax, stackdata + @@1: + mov edx, [eax] + push edx + sub eax, 4 + dec ecx + or ecx, ecx + jnz @@1 + @@2: + mov eax,_EAX + mov edx,_EDX + mov ecx,_ECX + call p + mov ecx, resultlength + cmp ecx, 0 + je @@5 + cmp ecx, 1 + je @@3 + cmp ecx, 2 + je @@4 + mov r, eax + jmp @@5 + @@3: + xor ecx, ecx + mov cl, al + mov r, ecx + jmp @@5 + @@4: + xor ecx, ecx + mov cx, ax + mov r, ecx + @@5: + mov ecx, resedx + jecxz @@6 + mov [ecx], edx + @@6: + end; + Result := r; +end; + +function RealCall_Other(p: Pointer; + StackData: Pointer; + StackDataLen: Longint; // stack length are in 4 bytes. (so 1 = 4 bytes) + ResultLength: Longint; ResEDX: Pointer): Longint; Stdcall; // make sure all things are on stack +var + r: Longint; +begin + asm + mov ecx, stackdatalen + jecxz @@2 + mov eax, stackdata + @@1: + mov edx, [eax] + push edx + sub eax, 4 + dec ecx + or ecx, ecx + jnz @@1 + @@2: + call p + mov ecx, resultlength + cmp ecx, 0 + je @@5 + cmp ecx, 1 + je @@3 + cmp ecx, 2 + je @@4 + mov r, eax + jmp @@5 + @@3: + xor ecx, ecx + mov cl, al + mov r, ecx + jmp @@5 + @@4: + xor ecx, ecx + mov cx, ax + mov r, ecx + @@5: + mov ecx, resedx + jecxz @@6 + mov [ecx], edx + @@6: + end; + Result := r; +end; + +function RealCall_CDecl(p: Pointer; + StackData: Pointer; + StackDataLen: Longint; // stack length are in 4 bytes. (so 1 = 4 bytes) + ResultLength: Longint; ResEDX: Pointer): Longint; Stdcall; // make sure all things are on stack +var + r: Longint; +begin + asm + mov ecx, stackdatalen + jecxz @@2 + mov eax, stackdata + @@1: + mov edx, [eax] + push edx + sub eax, 4 + dec ecx + or ecx, ecx + jnz @@1 + @@2: + call p + mov ecx, resultlength + cmp ecx, 0 + je @@5 + cmp ecx, 1 + je @@3 + cmp ecx, 2 + je @@4 + mov r, eax + jmp @@5 + @@3: + xor ecx, ecx + mov cl, al + mov r, ecx + jmp @@5 + @@4: + xor ecx, ecx + mov cx, ax + mov r, ecx + @@5: + mov ecx, stackdatalen + jecxz @@7 + @@6: + pop eax + dec ecx + or ecx, ecx + jnz @@6 + mov ecx, resedx + jecxz @@7 + mov [ecx], edx + @@7: + end; + Result := r; +end; + +const + EmptyPchar: array[0..0] of char = #0; + +function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean; +var + Stack: ansistring; + I: Longint; + RegUsage: Byte; + CallData: TPSList; + pp: ^Byte; + IsConstructor: Boolean; + + EAX, EDX, ECX: Longint; + + function rp(p: PPSVariantIFC): PPSVariantIFC; + begin + if p = nil then + begin + result := nil; + exit; + end; + if p.aType.BaseType = btPointer then + begin + p^.aType := Pointer(Pointer(IPointer(p^.dta) + 4)^); + p^.Dta := Pointer(p^.dta^); + end; + Result := p; + end; + + function GetPtr(fVar: PPSVariantIFC): Boolean; + var + varPtr: Pointer; + UseReg: Boolean; + tempstr: tbtstring; + p: Pointer; + begin + Result := False; + if FVar = nil then exit; + if fVar.VarParam then + begin + case fvar.aType.BaseType of + btArray: + begin + if Copy(fvar.aType.ExportName, 1, 10) = '!OPENARRAY' then + begin + p := CreateOpenArray(True, Self, FVar); + if p = nil then exit; + CallData.Add(p); + case RegUsage of + 0: begin EAX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end; + 1: begin EDX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end; + 2: begin ECX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end; + else begin + Stack := StringOfChar(AnsiChar(#0),4) + Stack; + Pointer((@Stack[1])^) := POpenArray(p)^.Data; + end; + end; + case RegUsage of + 0: begin EAX := Longint(POpenArray(p)^.ItemCount - 1); Inc(RegUsage); end; + 1: begin EDX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end; + 2: begin ECX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end; + else begin + Stack := StringOfChar(AnsiChar(#0),4) + Stack; + Longint((@Stack[1])^) := POpenArray(p)^.ItemCount -1; + end; + end; + Result := True; + Exit; + end else begin + {$IFDEF PS_DYNARRAY} + varptr := fvar.Dta; + {$ELSE} + Exit; + {$ENDIF} + end; + end; + btVariant, + btSet, + btStaticArray, + btRecord, + btInterface, + btClass, + {$IFNDEF PS_NOWIDESTRING} btUnicodeString, btWideString, btWideChar, {$ENDIF} btU8, btS8, btU16, + btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency + {$IFNDEF PS_NOINT64}, bts64{$ENDIF}: + begin + Varptr := fvar.Dta; + end; + else begin + exit; //invalid type + end; + end; {case} + case RegUsage of + 0: begin EAX := Longint(VarPtr); Inc(RegUsage); end; + 1: begin EDX := Longint(VarPtr); Inc(RegUsage); end; + 2: begin ECX := Longint(VarPtr); Inc(RegUsage); end; + else begin + Stack := StringOfChar(AnsiChar(#0),4) + Stack; + Pointer((@Stack[1])^) := VarPtr; + end; + end; + end else begin + UseReg := True; + case fVar^.aType.BaseType of + btSet: + begin + tempstr := StringOfChar(AnsiChar(#0),4); + case TPSTypeRec_Set(fvar.aType).aByteSize of + 1: Byte((@tempstr[1])^) := byte(fvar.dta^); + 2: word((@tempstr[1])^) := word(fvar.dta^); + 3, 4: cardinal((@tempstr[1])^) := cardinal(fvar.dta^); + else + pointer((@tempstr[1])^) := fvar.dta; + end; + end; + btArray: + begin + if Copy(fvar^.aType.ExportName, 1, 10) = '!OPENARRAY' then + begin + p := CreateOpenArray(False, SElf, FVar); + if p =nil then exit; + CallData.Add(p); + case RegUsage of + 0: begin EAX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end; + 1: begin EDX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end; + 2: begin ECX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end; + else begin + Stack := StringOfChar(AnsiChar(#0),4) + Stack; + Pointer((@Stack[1])^) := POpenArray(p)^.Data; + end; + end; + case RegUsage of + 0: begin EAX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end; + 1: begin EDX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end; + 2: begin ECX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end; + else begin + Stack := StringOfChar(AnsiChar(#0),4) + Stack; + Longint((@Stack[1])^) := POpenArray(p)^.ItemCount -1; + end; + end; + Result := True; + exit; + end else begin + {$IFDEF PS_DYNARRAY} + TempStr := StringOfChar(AnsiChar(#0),4); + Pointer((@TempStr[1])^) := Pointer(fvar.Dta^); + {$IFDEF PS_ARRAY_ON_STACK} + UseReg := false; + {$ENDIF} + {$ELSE} + Exit; + {$ENDIF} + end; + end; + btVariant + , btStaticArray, btRecord: + begin + TempStr := StringOfChar(AnsiChar(#0),4); + Pointer((@TempStr[1])^) := Pointer(fvar.Dta); + end; + btDouble: {8 bytes} begin + TempStr := StringOfChar(AnsiChar(#0),8); + UseReg := False; + double((@TempStr[1])^) := double(fvar.dta^); + end; + btCurrency: {8 bytes} begin + TempStr := StringOfChar(AnsiChar(#0),8); + UseReg := False; + currency((@TempStr[1])^) := currency(fvar.dta^); + end; + btSingle: {4 bytes} begin + TempStr := StringOfChar(AnsiChar(#0),4);; + UseReg := False; + Single((@TempStr[1])^) := single(fvar.dta^); + end; + + btExtended: {10 bytes} begin + UseReg := False; + TempStr:= StringOfChar(AnsiChar(#0),12); + Extended((@TempStr[1])^) := extended(fvar.dta^); + end; + btChar, + btU8, + btS8: begin + TempStr := tbtchar(fVar^.dta^) + tbtstring(StringOfChar(AnsiChar(#0),3)); + end; + {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF} + btu16, btS16: begin + TempStr := StringOfChar(AnsiChar(#0),4); + Word((@TempStr[1])^) := word(fVar^.dta^); + end; + btu32, bts32: begin + TempStr := StringOfChar(AnsiChar(#0),4); + Longint((@TempStr[1])^) := Longint(fVar^.dta^); + end; + btPchar: + begin + TempStr := StringOfChar(AnsiChar(#0),4); + if pointer(fvar^.dta^) = nil then + Pointer((@TempStr[1])^) := @EmptyPchar + else + Pointer((@TempStr[1])^) := pointer(fvar^.dta^); + end; + btclass, btinterface, btString: + begin + TempStr := StringOfChar(AnsiChar(#0),4); + Pointer((@TempStr[1])^) := pointer(fvar^.dta^); + end; + {$IFNDEF PS_NOWIDESTRING} + btWideString: begin + TempStr := StringOfChar(AnsiChar(#0),4); + Pointer((@TempStr[1])^) := pointer(fvar^.dta^); + end; + btUnicodeString: begin + TempStr := StringOfChar(AnsiChar(#0),4); + Pointer((@TempStr[1])^) := pointer(fvar^.dta^); + end; + {$ENDIF} + + btProcPtr: + begin + tempstr := StringOfChar(AnsiChar(#0),8); + TMethod((@TempStr[1])^) := MKMethod(Self, Longint(FVar.Dta^)); + UseReg := false; + end; + + {$IFNDEF PS_NOINT64}bts64: + begin + TempStr:= StringOfChar(AnsiChar(#0),8); + Int64((@TempStr[1])^) := int64(fvar^.dta^); + UseReg := False; + end;{$ENDIF} + end; {case} + if UseReg then + begin + case RegUsage of + 0: begin EAX := Longint((@Tempstr[1])^); Inc(RegUsage); end; + 1: begin EDX := Longint((@Tempstr[1])^); Inc(RegUsage); end; + 2: begin ECX := Longint((@Tempstr[1])^); Inc(RegUsage); end; + else begin + {$IFDEF FPC_OLD_FIX} + if CallingConv = cdRegister then + Stack := Stack + TempStr + else + {$ENDIF} + Stack := TempStr + Stack; + end; + end; + end else begin + {$IFDEF FPC_OLD_FIX} + if CallingConv = cdRegister then + Stack := Stack + TempStr + else + {$ENDIF} + Stack := TempStr + Stack; + end; + end; + Result := True; + end; +begin + if (Integer(CallingConv) and 64) <> 0 then begin + IsConstructor := true; + CAllingConv := TPSCallingConvention(Integer(CallingConv) and not 64); + end else IsConstructor := false; + + InnerfuseCall := False; + if Address = nil then + exit; // need address + Stack := ''; + CallData := TPSList.Create; + res := rp(res); + if res <> nil then + res.VarParam := true; + try + case CallingConv of + cdRegister: begin + EAX := 0; + EDX := 0; + ECX := 0; + RegUsage := 0; + +{$IFDEF FPC} // FIX FOR FPC constructor calls + if IsConstructor then begin + if not GetPtr(rp(Params[0])) then exit; // this goes first + RegUsage := 2; + EDX := Longint(_Self); + Params.Delete(0); + end else +{$ENDIF} + if assigned(_Self) then begin + RegUsage := 1; + EAX := Longint(_Self); + end; + + for I := 0 to Params.Count - 1 do + begin + if not GetPtr(rp(Params[I])) then Exit; + end; + + if assigned(res) then begin + case res^.aType.BaseType of + {$IFNDEF PS_NOWIDESTRING}btWideString, btUnicodeString, {$ENDIF} + btInterface, btArray, btrecord, {$IFNDEF PS_FPCSTRINGWORKAROUND}btstring, {$ENDIF}btVariant, btStaticArray: GetPtr(res); + btSet: + begin + if TPSTypeRec_Set(res.aType).aByteSize >4 then GetPtr(res); + end; + end; + case res^.aType.BaseType of + btSet: + begin + case TPSTypeRec_Set(res.aType).aByteSize of + 1: byte(res.Dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil); + 2: word(res.Dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil); + 3, + 4: Longint(res.Dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil); + else RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil) + end; + end; + btSingle: tbtsingle(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4); + btDouble: tbtdouble(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4); + btExtended: tbtextended(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4); + btchar,btU8, btS8: tbtu8(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil); + {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil); + btClass : + {$IFDEF FPC_OLD_FIX} + tbtu32(res.dta^) := RealCall_Register(Address, EDX, EAX, ECX, + @Stack[Length(Stack) - 3], Length(Stack) div 4, 4, nil); + {$ELSE} + tbtu32(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, + @Stack[Length(Stack) - 3], Length(Stack) div 4, 4, nil); + {$ENDIF} + + btu32,bts32: tbtu32(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil); + btPChar: pansichar(res.dta^) := Pansichar(RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil)); + {$IFNDEF PS_NOINT64}bts64: + begin + EAX := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX); + tbts64(res.dta^) := Int64(Cardinal(EDX)) shl 32 or Cardinal(EAX); + end; + {$ENDIF} + btCurrency: tbtCurrency(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4) / 10000; + btInterface, + btVariant, + {$IFNDEF PS_NOWIDESTRING}btWidestring,btUnicodestring, {$ENDIF} + btStaticArray, btArray, btrecord{$IFNDEF PS_FPCSTRINGWORKAROUND}, btstring {$ENDIF}: RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); + {$IFDEF PS_FPCSTRINGWORKAROUND} + btstring: begin + eax := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil); + Longint(res.dta^) := eax; + end; + {$ENDIF} + else + exit; + end; + end else + RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); + Result := True; + end; + cdPascal: begin + RegUsage := 3; + for I := 0 to Params.Count - 1 do begin + if not GetPtr(Params[i]) then Exit; + end; + if assigned(res) then begin + case res^.aType.BaseType of + {$IFNDEF PS_NOWIDESTRING}btWideString, btUnicodeString, {$ENDIF}btInterface, btArray, btrecord, btstring, btVariant: GetPtr(res); + end; + end; + if assigned(_Self) then begin + Stack := StringOfChar(AnsiChar(#0),4) +Stack; + Pointer((@Stack[1])^) := _Self; + end; + if assigned(res) then begin + case res^.aType.BaseType of + btSingle: tbtsingle(res^.Dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); + btDouble: tbtdouble(res^.Dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); + btExtended: tbtextended(res^.Dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); + btChar, btU8, btS8: tbtu8(res^.Dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil); + {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res^.Dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil); + btClass, btu32, bts32: tbtu32(res^.Dta^):= RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil); + btPChar: TBTSTRING(res^.dta^) := Pansichar(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil)); + {$IFNDEF PS_NOINT64}bts64: + begin + EAX := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX); + tbts64(res^.dta^) := Int64(EAX) shl 32 or EDX; + end; + {$ENDIF} + btVariant, + btInterface, btrecord, btstring: RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); + else + exit; + end; + end else + RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); + Result := True; + end; + cdSafeCall: begin + RegUsage := 3; + if assigned(res) then begin + GetPtr(res); + end; + for I := Params.Count - 1 downto 0 do begin + if not GetPtr(Params[i]) then Exit; + end; + if assigned(_Self) then begin + Stack := StringOfChar(AnsiChar(#0),4) +Stack; + Pointer((@Stack[1])^) := _Self; + end; + OleCheck(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil)); + Result := True; + end; + + CdCdecl: begin + RegUsage := 3; + if assigned(_Self) then begin + Stack := StringOfChar(AnsiChar(#0),4); + Pointer((@Stack[1])^) := _Self; + end; + for I := Params.Count - 1 downto 0 do begin + if not GetPtr(Params[I]) then Exit; + end; + if assigned(res) then begin + case res^.aType.BaseType of + btSingle: tbtsingle(res^.dta^) := RealFloatCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); + btDouble: tbtdouble(res^.dta^) := RealFloatCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); + btExtended: tbtextended(res^.dta^) := RealFloatCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); + btCHar, btU8, btS8: tbtu8(res^.dta^) := RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil); + {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res^.dta^) := RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil); + btClass, btu32, bts32: tbtu32(res^.dta^) := RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil); + btPChar: TBTSTRING(res^.dta^) := Pansichar(RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil)); + {$IFNDEF PS_NOINT64}bts64: + begin + EAX := RealCall_CDecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX); + tbts64(res^.Dta^) := Int64(EAX) shl 32 or EDX; + end; + {$ENDIF} + btVariant, {$IFNDEF PS_NOWIDESTRING}btUnicodeString, btWideString, {$ENDIF} + btInterface, + btArray, btrecord, btstring: begin GetPtr(res); RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); end; + else + exit; + end; + end else begin + RealCall_CDecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); + end; + Result := True; + end; + CdStdCall: begin + RegUsage := 3; + for I := Params.Count - 1 downto 0 do begin + if not GetPtr(Params[I]) then exit; + end; + if assigned(_Self) then begin + Stack := StringOfChar(AnsiChar(#0),4) + Stack; + Pointer((@Stack[1])^) := _Self; + end; + if assigned(res) then begin + case res^.aType.BaseType of + btSingle: tbtsingle(res^.dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); + btDouble: tbtdouble(res^.dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); + btExtended: tbtextended(res^.dta^):= RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); + btChar, btU8, btS8: tbtu8(res^.dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil); + {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res^.dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil); + btclass, btu32, bts32: tbtu32(res^.dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil); + btPChar: TBTSTRING(res^.dta^) := Pansichar(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil)); + {$IFNDEF PS_NOINT64}bts64: + begin + EAX := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX); + tbts64(res^.dta^) := Int64(EAX) shl 32 or EDX; + end; + {$ENDIF} + btVariant, {$IFNDEF PS_NOWIDESTRING}btUnicodeString, btWideString, {$ENDIF} + btInterface, btArray, btrecord, btstring: begin GetPtr(res); RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); end; + else + exit; + end; + end else begin + RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); + end; + Result := True; + end; + end; + finally + for i := CallData.Count -1 downto 0 do + begin + pp := CallData[i]; + case pp^ of + 0: DestroyOpenArray(Self, Pointer(pp)); + end; + end; + CallData.Free; + end; +end; + +