From afe3fdfd770647f8bec4f56e2237a5d42c7644a4 Mon Sep 17 00:00:00 2001 From: carlokok Date: Tue, 30 May 2006 14:23:25 +0000 Subject: [PATCH] re-checkin git-svn-id: http://code.remobjects.com/svn/pascalscript@1 5c9d2617-0215-0410-a2ee-e80e04d1c6d8 --- Pascal Script.ico | Bin 0 -> 22486 bytes Samples/Console/sample1.dpr | 61 + Samples/Console/sample2.dpr | 83 + Samples/Console/sample3.dpr | 80 + Samples/Console/sample4.dpr | 107 + Samples/Console/sample5.dpr | 113 + Samples/Console/sample6.dpr | 136 + Samples/Console/sample7.dpr | 145 + Samples/Console/sample8.dpr | 122 + Samples/Debug/dlgConfirmReplace.dfm | Bin 0 -> 893 bytes Samples/Debug/dlgConfirmReplace.pas | 107 + Samples/Debug/dlgReplaceText.dfm | Bin 0 -> 479 bytes Samples/Debug/dlgReplaceText.pas | 121 + Samples/Debug/dlgSearchText.dfm | Bin 0 -> 1439 bytes Samples/Debug/dlgSearchText.pas | 216 + Samples/Debug/ide.dpr | 21 + Samples/Debug/ide.res | Bin 0 -> 876 bytes Samples/Debug/ide_debugoutput.dfm | 27 + Samples/Debug/ide_debugoutput.pas | 33 + Samples/Debug/ide_editor.dfm | 296 + Samples/Debug/ide_editor.pas | 649 + Samples/Debug/readme.txt | 1 + Samples/Debug/uFrmGotoLine.dfm | Bin 0 -> 802 bytes Samples/Debug/uFrmGotoLine.pas | 79 + Samples/Import/Import.dpr | 17 + Samples/Import/Import.res | Bin 0 -> 22748 bytes Samples/Import/arraytest.rops | 22 + Samples/Import/booleantest.rops | 15 + Samples/Import/bytearray.rops | 14 + Samples/Import/casetest.rops | 12 + Samples/Import/dlltest.rops | 19 + Samples/Import/exc.ROPS | 13 + Samples/Import/exittest.rops | 14 + Samples/Import/fDwin.dfm | Bin 0 -> 615 bytes Samples/Import/fDwin.pas | 27 + Samples/Import/fMain.dfm | Bin 0 -> 1949 bytes Samples/Import/fMain.pas | 471 + Samples/Import/fortest.rops | 9 + Samples/Import/if.rops | 9 + Samples/Import/iformtest.rops | 104 + Samples/Import/importtest.rops | 16 + Samples/Import/longfortest.rops | 10 + Samples/Import/rectest.rops | 11 + Samples/Import/stringtest.rops | 8 + Samples/Import/t1.rops | 6 + Samples/Import/t10.rops | 12 + Samples/Import/t11.rops | 57 + Samples/Import/t2.rops | 6 + Samples/Import/t3.rops | 4 + Samples/Import/t4.rops | 8 + Samples/Import/t5.rops | 9 + Samples/Import/t6.rops | 22 + Samples/Import/t7.rops | 7 + Samples/Import/t8.rops | 16 + Samples/Import/t9.rops | 16 + Samples/Import/testdefine.rops | 10 + Samples/Import/testinclude.rops | 12 + Samples/Import/vartype.rops | 14 + Samples/Import/wordole.rops | 7 + Samples/Kylix/Import.dpr | 16 + Samples/Kylix/arraytest.rops | 22 + Samples/Kylix/booleantest.rops | 15 + Samples/Kylix/bytearray.rops | 9 + Samples/Kylix/casetest.rops | 12 + Samples/Kylix/exittest.rops | 14 + Samples/Kylix/fDwin.dfm | Bin 0 -> 666 bytes Samples/Kylix/fDwin.pas | 27 + Samples/Kylix/fMain.dfm | Bin 0 -> 1775 bytes Samples/Kylix/fMain.pas | 330 + Samples/Kylix/fortest.rops | 9 + Samples/Kylix/if.rops | 9 + Samples/Kylix/importtest.rops | 16 + Samples/Kylix/longfortest.rops | 10 + Samples/Kylix/rectest.rops | 11 + Samples/Kylix/vartype.rops | 14 + Samples/RO-TestApp/MegaDemo.RODL | 109 + Samples/RO-TestApp/MegaDemo.ROPS | 92 + Samples/RO-TestApp/TestApplication.dpr | 14 + Samples/RO-TestApp/TestApplication.res | Bin 0 -> 22748 bytes Samples/RO-TestApp/fMain.dfm | Bin 0 -> 1923 bytes Samples/RO-TestApp/fMain.pas | 174 + Samples/TestApp/TestApplication.dpr | 14 + Samples/TestApp/TestApplication.res | Bin 0 -> 22748 bytes Samples/TestApp/fMain.dfm | Bin 0 -> 1232 bytes Samples/TestApp/fMain.pas | 152 + Source/BuildPackages_D10.bdsgroup | 23 + Source/BuildPackages_D6.bpg | 23 + Source/BuildPackages_D7.bpg | 23 + Source/BuildPackages_D9.bdsgroup | 20 + Source/PascalScript.inc | 66 + Source/PascalScript_Core_D10.bdsproj | 177 + Source/PascalScript_Core_D10.cfg | 51 + Source/PascalScript_Core_D10.dpk | 77 + Source/PascalScript_Core_D10.res | Bin 0 -> 616 bytes Source/PascalScript_Core_D3.dof | 115 + Source/PascalScript_Core_D3.dpk | 76 + Source/PascalScript_Core_D4.dof | 114 + Source/PascalScript_Core_D4.dpk | 76 + Source/PascalScript_Core_D5.dof | 114 + Source/PascalScript_Core_D5.dpk | 76 + Source/PascalScript_Core_D6.dof | 127 + Source/PascalScript_Core_D6.dpk | 76 + Source/PascalScript_Core_D6.res | Bin 0 -> 616 bytes Source/PascalScript_Core_D6_Personal.dof | 83 + Source/PascalScript_Core_D6_Personal.dpk | 73 + Source/PascalScript_Core_D6_Personal.res | Bin 0 -> 1668 bytes Source/PascalScript_Core_D7.cfg | 47 + Source/PascalScript_Core_D7.dof | 129 + Source/PascalScript_Core_D7.dpk | 76 + Source/PascalScript_Core_D7.res | Bin 0 -> 616 bytes Source/PascalScript_Core_D9.bdsproj | 172 + Source/PascalScript_Core_D9.cfg | 47 + Source/PascalScript_Core_D9.dpk | 76 + Source/PascalScript_Core_D9.res | Bin 0 -> 620 bytes Source/PascalScript_Core_Glyphs.rc | 14 + Source/PascalScript_Core_Glyphs.res | Bin 0 -> 18328 bytes Source/PascalScript_Core_K3.dpk | 76 + Source/PascalScript_Core_K3.kof | 114 + Source/PascalScript_Core_Reg.pas | 66 + Source/PascalScript_Core_Reg_noDB.pas | 48 + Source/PascalScript_RO_D10.bdsproj | 176 + Source/PascalScript_RO_D10.cfg | 51 + Source/PascalScript_RO_D10.dpk | 45 + Source/PascalScript_RO_D10.res | Bin 0 -> 616 bytes Source/PascalScript_RO_D6.dof | 114 + Source/PascalScript_RO_D6.dpk | 43 + Source/PascalScript_RO_D6.res | Bin 0 -> 616 bytes Source/PascalScript_RO_D7.cfg | 50 + Source/PascalScript_RO_D7.dof | 130 + Source/PascalScript_RO_D7.dpk | 43 + Source/PascalScript_RO_D7.res | Bin 0 -> 612 bytes Source/PascalScript_RO_D9.bdsproj | 172 + Source/PascalScript_RO_D9.cfg | 51 + Source/PascalScript_RO_D9.dpk | 45 + Source/PascalScript_RO_D9.res | Bin 0 -> 1472 bytes Source/PascalScript_RO_Glyphs.RES | Bin 0 -> 1876 bytes Source/PascalScript_RO_Reg.pas | 34 + Source/ThirdParty/ROPS_EXTENDED.dpk | 43 + Source/ThirdParty/uPSI_Dialogs.pas | 741 + Source/ThirdParty/uPSI_IBX.pas | 2153 +++ Source/ThirdParty/uPSI_JvMail.pas | 373 + Source/ThirdParty/uPSI_Mask.pas | 187 + Source/ThirdParty/uPSI_Registry.pas | 478 + Source/ThirdParty/uPS_ExtReg.pas | 17 + Source/__Clean.bat | 3 + Source/changelog.txt | 62 + Source/eDefines.inc | 359 + Source/license.txt | 29 + Source/pascalscript.lpk | 246 + Source/pascalscript.lrs | 1001 ++ Source/pascalscript.pas | 29 + Source/readme.txt | 32 + Source/uPSC_DB.pas | 888 + Source/uPSC_buttons.pas | 87 + Source/uPSC_classes.pas | 316 + Source/uPSC_comobj.pas | 28 + Source/uPSC_controls.pas | 234 + Source/uPSC_dateutils.pas | 34 + Source/uPSC_dll.pas | 138 + Source/uPSC_extctrls.pas | 327 + Source/uPSC_forms.pas | 267 + Source/uPSC_graphics.pas | 275 + Source/uPSC_menus.pas | 214 + Source/uPSC_std.pas | 86 + Source/uPSC_stdctrls.pas | 633 + Source/uPSCompiler.pas | 14555 ++++++++++++++++ Source/uPSComponent.dcr | Bin 0 -> 17052 bytes Source/uPSComponent.pas | 1383 ++ Source/uPSComponentExt.pas | 949 + Source/uPSComponent_COM.pas | 38 + Source/uPSComponent_Controls.pas | 65 + Source/uPSComponent_DB.pas | 35 + Source/uPSComponent_Default.pas | 81 + Source/uPSComponent_Forms.pas | 65 + Source/uPSComponent_StdCtrls.pas | 65 + Source/uPSDebugger.pas | 654 + Source/uPSDisassembly.pas | 495 + Source/uPSPreProcessor.pas | 777 + Source/uPSR_DB.pas | 2070 +++ Source/uPSR_buttons.pas | 38 + Source/uPSR_classes.pas | 383 + Source/uPSR_comobj.pas | 96 + Source/uPSR_controls.pas | 247 + Source/uPSR_dateutils.pas | 63 + Source/uPSR_dll.pas | 297 + Source/uPSR_extctrls.pas | 150 + Source/uPSR_forms.pas | 260 + Source/uPSR_graphics.pas | 218 + Source/uPSR_menus.pas | 460 + Source/uPSR_std.pas | 85 + Source/uPSR_stdctrls.pas | 287 + Source/uPSRuntime.pas | 12265 +++++++++++++ Source/uPSUtils.pas | 1540 ++ Source/uROPSImports.pas | 366 + Source/uROPSServerLink.pas | 1139 ++ dunit/CompileTestExtended.pas | 147 + dunit/CompilerTestBase.pas | 137 + dunit/CompilerTestFunctions.pas | 203 + dunit/CompilerTestSimple.pas | 283 + dunit/ifps3_DUnit.dpr | 21 + dunit/ifps3_DUnit.res | Bin 0 -> 876 bytes dunit/ifps3_DUnit_Auto.dpr | 18 + dunit/ifps3_DUnit_Auto.res | Bin 0 -> 876 bytes help/Pascal Script.dox | 12499 +++++++++++++ patch.exe | Bin 0 -> 59904 bytes unit-importing/CMDimp.dpr | 38 + unit-importing/CMDimp.res | Bin 0 -> 21724 bytes unit-importing/FormSettings.dfm | 118 + unit-importing/FormSettings.pas | 47 + unit-importing/Import/Extendedreg.pas | 18 + unit-importing/Import/IFPS3_EXTENDED.dpk | 41 + unit-importing/Import/IFSIR_Dialogs.pas | 420 + unit-importing/Import/IFSI_BigIni.pas | 490 + unit-importing/Import/IFSI_Dialogs.pas | 812 + .../Import/IFSI_IBCustomDataSet.pas | 496 + unit-importing/Import/IFSI_IBDatabase.pas | 704 + unit-importing/Import/IFSI_IBQuery.pas | 225 + unit-importing/Import/IFSI_IBSQL.pas | 1043 ++ unit-importing/Import/IFSI_IBTable.pas | 302 + unit-importing/Import/IFSI_IBX.pas | 2210 +++ unit-importing/Import/IFSI_IBXreg.pas | 18 + unit-importing/Import/IFSI_IniFiles.pas | 248 + unit-importing/Import/IFSI_JvMail.pas | 424 + unit-importing/Import/IFSI_Registry.pas | 529 + unit-importing/Main.dfm | 813 + unit-importing/Main.pas | 701 + unit-importing/ParserU.pas | 2513 +++ unit-importing/ParserUtils.pas | 173 + unit-importing/TB_ReadMe.txt | 56 + unit-importing/UFrmGotoLine.dfm | Bin 0 -> 802 bytes unit-importing/UFrmGotoLine.pas | 79 + unit-importing/bigini.pas | 1454 ++ unit-importing/conv.ini | 133 + unit-importing/imp.dpr | 19 + unit-importing/imp.res | Bin 0 -> 21724 bytes unit-importing/psUnitImporter.ico | Bin 0 -> 22486 bytes unit-importing/readme.txt | 112 + 237 files changed, 83622 insertions(+) create mode 100644 Pascal Script.ico create mode 100644 Samples/Console/sample1.dpr create mode 100644 Samples/Console/sample2.dpr create mode 100644 Samples/Console/sample3.dpr create mode 100644 Samples/Console/sample4.dpr create mode 100644 Samples/Console/sample5.dpr create mode 100644 Samples/Console/sample6.dpr create mode 100644 Samples/Console/sample7.dpr create mode 100644 Samples/Console/sample8.dpr create mode 100644 Samples/Debug/dlgConfirmReplace.dfm create mode 100644 Samples/Debug/dlgConfirmReplace.pas create mode 100644 Samples/Debug/dlgReplaceText.dfm create mode 100644 Samples/Debug/dlgReplaceText.pas create mode 100644 Samples/Debug/dlgSearchText.dfm create mode 100644 Samples/Debug/dlgSearchText.pas create mode 100644 Samples/Debug/ide.dpr create mode 100644 Samples/Debug/ide.res create mode 100644 Samples/Debug/ide_debugoutput.dfm create mode 100644 Samples/Debug/ide_debugoutput.pas create mode 100644 Samples/Debug/ide_editor.dfm create mode 100644 Samples/Debug/ide_editor.pas create mode 100644 Samples/Debug/readme.txt create mode 100644 Samples/Debug/uFrmGotoLine.dfm create mode 100644 Samples/Debug/uFrmGotoLine.pas create mode 100644 Samples/Import/Import.dpr create mode 100644 Samples/Import/Import.res create mode 100644 Samples/Import/arraytest.rops create mode 100644 Samples/Import/booleantest.rops create mode 100644 Samples/Import/bytearray.rops create mode 100644 Samples/Import/casetest.rops create mode 100644 Samples/Import/dlltest.rops create mode 100644 Samples/Import/exc.ROPS create mode 100644 Samples/Import/exittest.rops create mode 100644 Samples/Import/fDwin.dfm create mode 100644 Samples/Import/fDwin.pas create mode 100644 Samples/Import/fMain.dfm create mode 100644 Samples/Import/fMain.pas create mode 100644 Samples/Import/fortest.rops create mode 100644 Samples/Import/if.rops create mode 100644 Samples/Import/iformtest.rops create mode 100644 Samples/Import/importtest.rops create mode 100644 Samples/Import/longfortest.rops create mode 100644 Samples/Import/rectest.rops create mode 100644 Samples/Import/stringtest.rops create mode 100644 Samples/Import/t1.rops create mode 100644 Samples/Import/t10.rops create mode 100644 Samples/Import/t11.rops create mode 100644 Samples/Import/t2.rops create mode 100644 Samples/Import/t3.rops create mode 100644 Samples/Import/t4.rops create mode 100644 Samples/Import/t5.rops create mode 100644 Samples/Import/t6.rops create mode 100644 Samples/Import/t7.rops create mode 100644 Samples/Import/t8.rops create mode 100644 Samples/Import/t9.rops create mode 100644 Samples/Import/testdefine.rops create mode 100644 Samples/Import/testinclude.rops create mode 100644 Samples/Import/vartype.rops create mode 100644 Samples/Import/wordole.rops create mode 100644 Samples/Kylix/Import.dpr create mode 100644 Samples/Kylix/arraytest.rops create mode 100644 Samples/Kylix/booleantest.rops create mode 100644 Samples/Kylix/bytearray.rops create mode 100644 Samples/Kylix/casetest.rops create mode 100644 Samples/Kylix/exittest.rops create mode 100644 Samples/Kylix/fDwin.dfm create mode 100644 Samples/Kylix/fDwin.pas create mode 100644 Samples/Kylix/fMain.dfm create mode 100644 Samples/Kylix/fMain.pas create mode 100644 Samples/Kylix/fortest.rops create mode 100644 Samples/Kylix/if.rops create mode 100644 Samples/Kylix/importtest.rops create mode 100644 Samples/Kylix/longfortest.rops create mode 100644 Samples/Kylix/rectest.rops create mode 100644 Samples/Kylix/vartype.rops create mode 100644 Samples/RO-TestApp/MegaDemo.RODL create mode 100644 Samples/RO-TestApp/MegaDemo.ROPS create mode 100644 Samples/RO-TestApp/TestApplication.dpr create mode 100644 Samples/RO-TestApp/TestApplication.res create mode 100644 Samples/RO-TestApp/fMain.dfm create mode 100644 Samples/RO-TestApp/fMain.pas create mode 100644 Samples/TestApp/TestApplication.dpr create mode 100644 Samples/TestApp/TestApplication.res create mode 100644 Samples/TestApp/fMain.dfm create mode 100644 Samples/TestApp/fMain.pas create mode 100644 Source/BuildPackages_D10.bdsgroup create mode 100644 Source/BuildPackages_D6.bpg create mode 100644 Source/BuildPackages_D7.bpg create mode 100644 Source/BuildPackages_D9.bdsgroup create mode 100644 Source/PascalScript.inc create mode 100644 Source/PascalScript_Core_D10.bdsproj create mode 100644 Source/PascalScript_Core_D10.cfg create mode 100644 Source/PascalScript_Core_D10.dpk create mode 100644 Source/PascalScript_Core_D10.res create mode 100644 Source/PascalScript_Core_D3.dof create mode 100644 Source/PascalScript_Core_D3.dpk create mode 100644 Source/PascalScript_Core_D4.dof create mode 100644 Source/PascalScript_Core_D4.dpk create mode 100644 Source/PascalScript_Core_D5.dof create mode 100644 Source/PascalScript_Core_D5.dpk create mode 100644 Source/PascalScript_Core_D6.dof create mode 100644 Source/PascalScript_Core_D6.dpk create mode 100644 Source/PascalScript_Core_D6.res create mode 100644 Source/PascalScript_Core_D6_Personal.dof create mode 100644 Source/PascalScript_Core_D6_Personal.dpk create mode 100644 Source/PascalScript_Core_D6_Personal.res create mode 100644 Source/PascalScript_Core_D7.cfg create mode 100644 Source/PascalScript_Core_D7.dof create mode 100644 Source/PascalScript_Core_D7.dpk create mode 100644 Source/PascalScript_Core_D7.res create mode 100644 Source/PascalScript_Core_D9.bdsproj create mode 100644 Source/PascalScript_Core_D9.cfg create mode 100644 Source/PascalScript_Core_D9.dpk create mode 100644 Source/PascalScript_Core_D9.res create mode 100644 Source/PascalScript_Core_Glyphs.rc create mode 100644 Source/PascalScript_Core_Glyphs.res create mode 100644 Source/PascalScript_Core_K3.dpk create mode 100644 Source/PascalScript_Core_K3.kof create mode 100644 Source/PascalScript_Core_Reg.pas create mode 100644 Source/PascalScript_Core_Reg_noDB.pas create mode 100644 Source/PascalScript_RO_D10.bdsproj create mode 100644 Source/PascalScript_RO_D10.cfg create mode 100644 Source/PascalScript_RO_D10.dpk create mode 100644 Source/PascalScript_RO_D10.res create mode 100644 Source/PascalScript_RO_D6.dof create mode 100644 Source/PascalScript_RO_D6.dpk create mode 100644 Source/PascalScript_RO_D6.res create mode 100644 Source/PascalScript_RO_D7.cfg create mode 100644 Source/PascalScript_RO_D7.dof create mode 100644 Source/PascalScript_RO_D7.dpk create mode 100644 Source/PascalScript_RO_D7.res create mode 100644 Source/PascalScript_RO_D9.bdsproj create mode 100644 Source/PascalScript_RO_D9.cfg create mode 100644 Source/PascalScript_RO_D9.dpk create mode 100644 Source/PascalScript_RO_D9.res create mode 100644 Source/PascalScript_RO_Glyphs.RES create mode 100644 Source/PascalScript_RO_Reg.pas create mode 100644 Source/ThirdParty/ROPS_EXTENDED.dpk create mode 100644 Source/ThirdParty/uPSI_Dialogs.pas create mode 100644 Source/ThirdParty/uPSI_IBX.pas create mode 100644 Source/ThirdParty/uPSI_JvMail.pas create mode 100644 Source/ThirdParty/uPSI_Mask.pas create mode 100644 Source/ThirdParty/uPSI_Registry.pas create mode 100644 Source/ThirdParty/uPS_ExtReg.pas create mode 100644 Source/__Clean.bat create mode 100644 Source/changelog.txt create mode 100644 Source/eDefines.inc create mode 100644 Source/license.txt create mode 100644 Source/pascalscript.lpk create mode 100644 Source/pascalscript.lrs create mode 100644 Source/pascalscript.pas create mode 100644 Source/readme.txt create mode 100644 Source/uPSC_DB.pas create mode 100644 Source/uPSC_buttons.pas create mode 100644 Source/uPSC_classes.pas create mode 100644 Source/uPSC_comobj.pas create mode 100644 Source/uPSC_controls.pas create mode 100644 Source/uPSC_dateutils.pas create mode 100644 Source/uPSC_dll.pas create mode 100644 Source/uPSC_extctrls.pas create mode 100644 Source/uPSC_forms.pas create mode 100644 Source/uPSC_graphics.pas create mode 100644 Source/uPSC_menus.pas create mode 100644 Source/uPSC_std.pas create mode 100644 Source/uPSC_stdctrls.pas create mode 100644 Source/uPSCompiler.pas create mode 100644 Source/uPSComponent.dcr create mode 100644 Source/uPSComponent.pas create mode 100644 Source/uPSComponentExt.pas create mode 100644 Source/uPSComponent_COM.pas create mode 100644 Source/uPSComponent_Controls.pas create mode 100644 Source/uPSComponent_DB.pas create mode 100644 Source/uPSComponent_Default.pas create mode 100644 Source/uPSComponent_Forms.pas create mode 100644 Source/uPSComponent_StdCtrls.pas create mode 100644 Source/uPSDebugger.pas create mode 100644 Source/uPSDisassembly.pas create mode 100644 Source/uPSPreProcessor.pas create mode 100644 Source/uPSR_DB.pas create mode 100644 Source/uPSR_buttons.pas create mode 100644 Source/uPSR_classes.pas create mode 100644 Source/uPSR_comobj.pas create mode 100644 Source/uPSR_controls.pas create mode 100644 Source/uPSR_dateutils.pas create mode 100644 Source/uPSR_dll.pas create mode 100644 Source/uPSR_extctrls.pas create mode 100644 Source/uPSR_forms.pas create mode 100644 Source/uPSR_graphics.pas create mode 100644 Source/uPSR_menus.pas create mode 100644 Source/uPSR_std.pas create mode 100644 Source/uPSR_stdctrls.pas create mode 100644 Source/uPSRuntime.pas create mode 100644 Source/uPSUtils.pas create mode 100644 Source/uROPSImports.pas create mode 100644 Source/uROPSServerLink.pas create mode 100644 dunit/CompileTestExtended.pas create mode 100644 dunit/CompilerTestBase.pas create mode 100644 dunit/CompilerTestFunctions.pas create mode 100644 dunit/CompilerTestSimple.pas create mode 100644 dunit/ifps3_DUnit.dpr create mode 100644 dunit/ifps3_DUnit.res create mode 100644 dunit/ifps3_DUnit_Auto.dpr create mode 100644 dunit/ifps3_DUnit_Auto.res create mode 100644 help/Pascal Script.dox create mode 100644 patch.exe create mode 100644 unit-importing/CMDimp.dpr create mode 100644 unit-importing/CMDimp.res create mode 100644 unit-importing/FormSettings.dfm create mode 100644 unit-importing/FormSettings.pas create mode 100644 unit-importing/Import/Extendedreg.pas create mode 100644 unit-importing/Import/IFPS3_EXTENDED.dpk create mode 100644 unit-importing/Import/IFSIR_Dialogs.pas create mode 100644 unit-importing/Import/IFSI_BigIni.pas create mode 100644 unit-importing/Import/IFSI_Dialogs.pas create mode 100644 unit-importing/Import/IFSI_IBCustomDataSet.pas create mode 100644 unit-importing/Import/IFSI_IBDatabase.pas create mode 100644 unit-importing/Import/IFSI_IBQuery.pas create mode 100644 unit-importing/Import/IFSI_IBSQL.pas create mode 100644 unit-importing/Import/IFSI_IBTable.pas create mode 100644 unit-importing/Import/IFSI_IBX.pas create mode 100644 unit-importing/Import/IFSI_IBXreg.pas create mode 100644 unit-importing/Import/IFSI_IniFiles.pas create mode 100644 unit-importing/Import/IFSI_JvMail.pas create mode 100644 unit-importing/Import/IFSI_Registry.pas create mode 100644 unit-importing/Main.dfm create mode 100644 unit-importing/Main.pas create mode 100644 unit-importing/ParserU.pas create mode 100644 unit-importing/ParserUtils.pas create mode 100644 unit-importing/TB_ReadMe.txt create mode 100644 unit-importing/UFrmGotoLine.dfm create mode 100644 unit-importing/UFrmGotoLine.pas create mode 100644 unit-importing/bigini.pas create mode 100644 unit-importing/conv.ini create mode 100644 unit-importing/imp.dpr create mode 100644 unit-importing/imp.res create mode 100644 unit-importing/psUnitImporter.ico create mode 100644 unit-importing/readme.txt diff --git a/Pascal Script.ico b/Pascal Script.ico new file mode 100644 index 0000000000000000000000000000000000000000..21ee9b76fff9d87652b4511d0c88910de6814fcb GIT binary patch literal 22486 zcmeHPcW@iU_ut^eiG@mJt8j`e+cL5hC$>dG0x=1uLx2!kfB?bt4yM-`YO+AuJH!_XNRhdN&v`0elW+0)9a^GPl-{FTcnXY2OuzR%mYukD_Nm>^0; zCL?g4BJT4Gaj+1gx;p#&6e0WpA*N2Xe?N4R5Kl)%wtcm@FC|2xQn$zNX!rVNx_z}c zbfOSP?;=DRePRf)FFqVcU1j!7{XYT!^Mk9jv{aOpl?k8EC(6sqMK~N5mSu^`%1ZE6 zEmEnJm_B{FXl!g0>#et*m@{XNm^W{pSg>G$*mToP#gAYRBzE3;XR&0- z60zr=dx~YtmWloL+fN*L;DO@MLk|^49d(pA_Sj>^i6@>YPCfNhamE>Eh%?VTQ=EJ5 zx#GeLFBF$ucA2>H$}7dS*Ip}byzxeH>#etnJMOqc+;h)8;(-Sq5RW|ahC;`*z? z_rR3WDcREF5vNG39=*D1fs&Ftq_*SzNUD5fq>5k zT3}F@C~+ZR6EyM!qcO{hhQk#V!JyBhNYLJLQUq0VUpO9*$6{7AOAr7BhY%&cd;&Db zRRQanNaP5D!2md$LJA@B2r2?T{EOArl7K_xSR$MD5C%&Y`|-uBxJ_V;pn#LW#GFEN zQh-}4JA#b?yx5m5CJjOH$>z9%ia?EEK{~v$6DLZ7HbFdS6R7sSXbwY=Q=KKSA=vF9 z=wLK#vxE`idIahQn|p%jX$o0Vs!`4M^;SR$4^M(wDOpOFpiC8b;`8N3sK88GnOfC< zARhMl61BCpiRy$k1uB6N0(g#xN~)A8+E=79O;LVX-B9cEg;Qz-=#$dEK$r{!^Z?b+ zl<@4?nWoxkEY;A^fT=@!V2DAPNDxrElpR38nO0Q9=YSy7)YR12I6V>YB~lzAPIUzV zWT8gzQLbzsuBe}*2r_8jFg*~k>Pev5qyJ!5`2y6{3bqe7&P99jM1rs{Twl-j)NYIr zw6!%DgyNNYRQow|=VF8m37Q&XfnYrdQgN;sTorKrO1-%lN(FulZ@8f%00yuGZK|IR zf`rE=sL<=dXSWBzhKhh3VFa|VoeqKo)*DBt(CZ=BKH6dvWTg}gq!4Y?SEDrv)RH3x zv`3&4#ZN6D$iy2dC13~!5{)20d#-3-*j{l~G}k^lyQQTi6Rt(vLeRlrqOqZ2I%Zl? zusv5?6aq#67%AGcfbFd;XtZwvL9MOdo~T~aKG-n^O3`Tjf(2+Fo(`#krC_j{^MLk> z0`0k`V=*dUTqHmcN95E3xz=NZ*|RIq9`gV>DUR#~l!!;s9t)s>(=itW)gZ8{F|ifF z7+Hu>!$DCI<#bu`Ae9gLjP@27S}+IgseHJCN`u*44MDpXhB{60(2|lNYr~BfENC*4M|_J;G#lRg<84L5?7&trV+jPu=k8?uDQRTD6Lx zWkFW?l(urkL6_82dt%w{af^{4p;*c%zyOU6)vykjhr#Azx*~|pC50l$V&IBvh*PS8 ztnthe*#uU73#CNRHU?;GeOOIIesidW8UZs+)yNTK>Z6!95ICD-7zG--5>GYF-Vg)K zZc4?W8fu~q-!h1z)&gj%H?P5&2EkyP{GZfJV+gysR=#3U1e6cjrw5?6*5-FP=M3oRA z1ECNg69S5pSu<^*ipJ{N8!TSL*xmx*PrXqEC*e?%-!7f7f^L ztNGV>6h7e6c-0;Fl^i;B!wI~jLnS{D2KYM~w(>4JCs5W>U3Q*YjiEQeCzq!p zhs|B!QRk_XCr=hw_9{=M7D5A5o|;G`1dME6o(fl0G*8`Wr=7%ZyX_{HE?t_-Qx7`m zAaVHNhv(&~r<`(%%2PW#JH;+t>25kLI!gZS~s zAH}Lwt5kma*I$2$fByL=Cx$gYtdYPP3D^=)iO9r>=OHUL*ud`vGlLC+esMT_l!nhBU^&d1`jHL3yYym8yg!J!MJ`L2ytL z3C)~qH)xCn({-tYm$FuZvY$sXbF&Q+{)Tj24P@={*pkF-))9z%Urj zr5W(m&C@(&QqVbnC`+wwY!FGL8#0-hsf2>*ScE`<7FGz*D2F^^yCVoHi#_C^9UQ1G zS(C-2zmuybtIz>qLi1IxCO8+LB$G)|S63%6 zr2^A}dcGZ>V73IZ1XV}hdh4yl_SC@uKfmOXOT;zTTqCZ({(7NflDqG|Tikcwed4jl9#iqii!Z(?dV71t ztFOK)-gx5;6_33C{`=zd&p#L6e*3NX?z`{AFTeaE{zCk*=2|0xH4+$u1fr8Bm8|8} zgpo22J$=bqwiyq3BXKJdn(8fE3;C9q=Jf}sO|v3X%StD)#ngz`>yO8+vPos0(zQe~ zn2uU;t14br>YeH@@lLZEXQb;w$*Qtae`spiTA^eUzKGP;c*>?mLY|UHGLvqcF|Do^ zm2E5Hom3THuVzMLRl3gW4aF`0q*Np`gXWo|_#>XEh}O(%no(Dms;#Mthv=swGiI%a zItWIo@~|#Y8%Z{)FQ$33jwBkbN+zwT{wj?yRTT+MvkmtD@a0P6kG;Uw37g1Ip^MLY z`9a%Npdl^oYzCiw@tGj1@jv=VsoS{!SA`3?V>`-!T_~sY!7)jcA|&j#g!_`HMo74E ziF(Zd{A3S`Jj-F*7q7kc+Pd^K?mP|GA@*Ve>#n!x1c`GH66YZ#&P9wE0}=p<{$+D>v%+DnX~#VDjRnI-8*S8# zvmFD}0bo#ipfMmem7SfP@~pGYk~q5|Pd)Y2)xtpea6KVU$l0aU!GKD5GvqS>3=$Zm z#z4J3`skx2&X-8k@8o&soj0x+sEhO)+O|3{beVcx=x69>ptZHN4;Uop*u+5nM*OdI z=7I|@SZxd(gL6w=)a#1+MBh;W!?0@_YjOD|n`|P1LAqfub&2bAEc3wmtf{GS^>MUK z`(5Rtk+;h)K zoO>M=2I!!|z&^UVx`tpl{`li_F@oDX(C-Wvd(%ca^67rq_zupQi2-|}5__Vf!qDE{ zuIx7L_nmj%IRpcBQpetIIS}pkaQOpcBxg+kzOzI7DUAVVjb(p-|EMs~4(WJ_e#41@ z>!MH&M7u=WJzV}kdS_i@@4ff#;JPs}U>{nJ76a|A_S3{d+iGIq8rS)Q+dR;I50?Yc zA3N(B%a$$c00y=8H3saV%due4{((L~+g6Q%xsF>Nr*(#lRp<4D?$j zhMt}t?CgsZ6Upkg@qjXo0t?Z6*@{E>%2+g8p) zAq+b9KKtymhr}9O(~M&ZVHhqK<@nB8C2GcPls{s_<@9|f2I`54fwD0%P?vCyNM3c- zRr2!7FIO?A8G920=YhJ!^?>t8Isf2>fwaWHd7v(FJ#fw$x6&@rHn`MVtH?iM{bsf^ zG2p!$iFadi7(V#m1J$RA!HoIL*jvwoUJu$XY5!1c9`t(9^$22Mjf{5IQE%-d@A^9A zkVE>N7_f(#hk{Ej9cmBX!{?1^ilcn!w*ZG zqmy{=OT`k5i?E+98EY^H;+m#iqHU#rppVlwlxv1DAJ>Z3B?Ci;$-Dj;7}^;Fni#Op zE`R&&H&+a%j~i{gYn9IR01VuJ$dkS1pLf`aJ|_mo1OGJ!&WD?y#yZZ^ zdy{wme8dq)Gy}tc69e<#{|W%ki*Au52e|S&tl&d!azSw+v@ZWX3RI5`~l}| zB;$XbKR7T9a381`pT(X5!*aKI(6I*nv@_Ni$vn{Z(vC82FXE@Uhcaf~HLmP>7_z1{ z2FBi;d)joy-t=)_ef3pd4)o4D?1R$E^*uZ8Z}SfkA?<}>p+ zXI(?*KrS&~7vksELgW3L-)CcQ<_~!}&@j3*z?w1Y-fj2<{!RWy+c(xjEAo(5%tJ@E zHq()IS;@##=^9>jINw^PmDMdws?8`FPy5wHqpf!dKBpzD3C8}obs_jP#& z3wsaCu?IA6wg&GZHseLaZZpRR4-!1&YK|rk#{PIe&K|Xm2`q?E(+MCySyq5F426*7P zpApFdV>F|lHvk?~en}pyN06tgMB%D0Z&ojnienCFCH^{SW+#??e4~Xpp zh-(IPjLcY*weyQFzF5^{SaTUE4~(z5ugra!k@A4}q=)&1j&Zqf#@fYbcp!e(MD(5{ z^~TAAn?68x?YbUg^1#|E=Yq0j9?ja6n;ckM;+P{?7fL5hy@UP)5UUL^-Xsr<+uV5I zK6atGAfKFbb6wCzur|cC%e`(>AI!Chn6aIGb6my(9UUDiW_RPE&|J9L2hwYuq&|>8 z(>`b!V2`7paVvRXtc$;8liOQoACw96T+S`m8Qv|-lLPBQZuUX1P0a(>g}F9qClT{h z>HS$^$NPtBZ<+Z6V?X9~tgEu#!n~DorVf}qFb{FFQKo&+JWvMu3=VBI#%$AZ7uOcv zea!KI_aarj8ShG}eGBfta&02cQ~Riz2k!A{8)eGD%|6gZnf?NCN5_&SOVmCDWzQV8 z7!RBy)|y#wVl9R|&^ED_&+O3fW2S^=Tdu3-{=pgf%z3Z(5WG*3YPu)CbK2*9&WbP9B)Mx$$87Zp4B;^e5zj z=Q8k)Nl_k%nRy&*e3}R9qvX)t?LWL{HCc7T)U>7 zL`;i_TkyTDR$W`B9Jt4;dB8j2YX6LD{G^jk%E^I#h<2BBlnHG$Wn%8}(EfA(h4C4A zWgKPLs4kAJFYwl*d0;&f@0RCyVEs$4i{b2p)=9lKwT)um4*O80$L1YankgU61L?+# z2c9K0*9GHhb8P)HcxWGQ9?n1id}XhUb-}n=&AT4gyn}}>lLyX)sSl%>3!b}ktP94~ zd2%<$);~LWpiXjK=(Sml2fR0^Vi?8}j&;$Gwb!i281C+z3vC~0qi7rPxBisBpwFV; zr0?eXF0eLxAcul7FT@LYpibu2h30|lO#3YDyLAl1^C|`p1BiRt3-v$J?`a=Q8>Rh4 z5gz)$Lp$T@k&ZEvcC^*7HLZ{XeO4EJcQ$_LW*n7`<%ZQSb1d0w|9O={@9cJ>ijn=8 zWJP~Qd)8Yf^xB`?ySu1y1TYTY-R)52p_P*z@9kED5`SxCqPi9R54p}_*za!oa>g_G zTO%s2MNHd=e6y_(G4g-_V$dGuhKxlS59*wiwwbXR`rvy@d_N;^yu&m=_g4(YJChoqNhWn~a=y!0ZF|znk`ezK}62?St6|b(ehA;0!&_BWXT}1^U!X zA3{IFK6qw^yz~5m?t}bO9`tdvx6HlR2jv0Z$yi_F-D2gp7#lJ^VSd4VTK2)16*5(^ zgvOGUM<0A}53w>H!h6YTUl{K!s~Cyi@d(3%#a82VK zXvse4pV$ZKv`m>Zac;5Z2N-j4Z-{#lnh)|#KG+8_vk%4#dR{oU)DMi)!~7ZVPAgl* zJd1rWzTzG?`=CtO2i8?irj#*d3ct9V@ebo6($WTT47R1ubj}Os3bj_HW7JdFu`1?o zS6_X#^6NZ@NL$Sq4u3OM;vH~xHWKfLtK5>fC_~Bvy5341fIaMBAKW8id_pXghf}7+ zqJ1uOyqmQ8qHkdzoC{)c_Cft%K9SY2KCTx{tM8f*%7ZfHys$sYgL6mh@I75zFPg@A nr#vWA&I{+3`avC|o>JGH?N_0vk-W32={i|^#b+gJt)TsXtII2B literal 0 HcmV?d00001 diff --git a/Samples/Console/sample1.dpr b/Samples/Console/sample1.dpr new file mode 100644 index 0000000..65b3cb2 --- /dev/null +++ b/Samples/Console/sample1.dpr @@ -0,0 +1,61 @@ +program sample1; + +uses + uPSCompiler, uPSRuntime; + +function ScriptOnUses(Sender: TPSPascalCompiler; const Name: string): Boolean; +{ the OnUses callback function is called for each "uses" in the script. + It's always called with the parameter 'SYSTEM' at the top of the script. + For example: uses ii1, ii2; + This will call this function 3 times. First with 'SYSTEM' then 'II1' and then 'II2'. +} +begin + if Name = 'SYSTEM' then + begin + Result := True; + end else + Result := False; +end; + +procedure ExecuteScript(const Script: string); +var + Compiler: TPSPascalCompiler; + { TPSPascalCompiler is the compiler part of the scriptengine. This will + translate a Pascal script into a compiled form the executer understands. } + Exec: TPSExec; + { TPSExec is the executer part of the scriptengine. It uses the output of + the compiler to run a script. } + Data: string; +begin + Compiler := TPSPascalCompiler.Create; // create an instance of the compiler. + Compiler.OnUses := ScriptOnUses; // assign the OnUses event. + if not Compiler.Compile(Script) then // Compile the Pascal script into bytecode. + begin + Compiler.Free; + // You could raise an exception here. + Exit; + end; + + Compiler.GetOutput(Data); // Save the output of the compiler in the string Data. + Compiler.Free; // After compiling the script, there is no need for the compiler anymore. + + Exec := TPSExec.Create; // Create an instance of the executer. + if not Exec.LoadData(Data) then // Load the data from the Data string. + begin + { For some reason the script could not be loaded. This is usually the case when a + library that has been used at compile time isn't registered at runtime. } + Exec.Free; + // You could raise an exception here. + Exit; + end; + + Exec.RunScript; // Run the script. + Exec.Free; // Free the executer. +end; + +const + Script = 'var s: string; begin s := ''Test''; S := s + ''ing;''; end.'; + +begin + ExecuteScript(Script); +end. diff --git a/Samples/Console/sample2.dpr b/Samples/Console/sample2.dpr new file mode 100644 index 0000000..2c30cac --- /dev/null +++ b/Samples/Console/sample2.dpr @@ -0,0 +1,83 @@ +program sample2; + +uses + uPSCompiler, + uPSRuntime, + + Dialogs + + ; + +procedure MyOwnFunction(const Data: string); +begin + // Do something with Data + ShowMessage(Data); +end; + +function ScriptOnUses(Sender: TPSPascalCompiler; const Name: string): Boolean; +{ the OnUses callback function is called for each "uses" in the script. + It's always called with the parameter 'SYSTEM' at the top of the script. + For example: uses ii1, ii2; + This will call this function 3 times. First with 'SYSTEM' then 'II1' and then 'II2'. +} +begin + if Name = 'SYSTEM' then + begin + Sender.AddDelphiFunction('procedure MyOwnFunction(Data: string)'); + { This will register the function to the script engine. Now it can be used from + within the script.} + + Result := True; + end else + Result := False; +end; + +procedure ExecuteScript(const Script: string); +var + Compiler: TPSPascalCompiler; + { TPSPascalCompiler is the compiler part of the scriptengine. This will + translate a Pascal script into a compiled form the executer understands. } + Exec: TPSExec; + { TPSExec is the executer part of the scriptengine. It uses the output of + the compiler to run a script. } + Data: string; +begin + Compiler := TPSPascalCompiler.Create; // create an instance of the compiler. + Compiler.OnUses := ScriptOnUses; // assign the OnUses event. + if not Compiler.Compile(Script) then // Compile the Pascal script into bytecode. + begin + Compiler.Free; + // You could raise an exception here. + Exit; + end; + + Compiler.GetOutput(Data); // Save the output of the compiler in the string Data. + Compiler.Free; // After compiling the script, there is no need for the compiler anymore. + + Exec := TPSExec.Create; // Create an instance of the executer. + Exec.RegisterDelphiFunction(@MyOwnFunction, 'MYOWNFUNCTION', cdRegister); + { This will register the function to the executer. The first parameter is a + pointer to the function. The second parameter is the name of the function (in uppercase). + And the last parameter is the calling convention (usually Register). } + + if not Exec.LoadData(Data) then // Load the data from the Data string. + begin + { For some reason the script could not be loaded. This is usually the case when a + library that has been used at compile time isn't registered at runtime. } + Exec.Free; + // You could raise an exception here. + Exit; + end; + + Exec.RunScript; // Run the script. + Exec.Free; // Free the executer. +end; + + + +const + Script = 'var s: string; begin s := ''Test''; S := s + ''ing;''; MyOwnFunction(s); end.'; + +begin + ExecuteScript(Script); +end. diff --git a/Samples/Console/sample3.dpr b/Samples/Console/sample3.dpr new file mode 100644 index 0000000..0ca3df1 --- /dev/null +++ b/Samples/Console/sample3.dpr @@ -0,0 +1,80 @@ +program sample3; + +uses + uPSC_dll, + uPSR_dll, + uPSCompiler, + uPSRuntime; + +function ScriptOnUses(Sender: TPSPascalCompiler; const Name: string): Boolean; +{ the OnUses callback function is called for each "uses" in the script. + It's always called with the parameter 'SYSTEM' at the top of the script. + For example: uses ii1, ii2; + This will call this function 3 times. First with 'SYSTEM' then 'II1' and then 'II2'. +} +begin + if Name = 'SYSTEM' then + begin + Sender.OnExternalProc := @DllExternalProc; + { Assign the dll library to the script engine. This function can be found in the uPSC_dll.pas file. + When you have assigned this, it's possible to do this in the script: + + Function FindWindow(c1, c2: PChar): Cardinal; external 'FindWindow@user32.dll stdcall'; + + The syntax for the external string is 'functionname@dllname callingconvention'. + } + + Result := True; + end else + Result := False; +end; + +procedure ExecuteScript(const Script: string); +var + Compiler: TPSPascalCompiler; + { TPSPascalCompiler is the compiler part of the scriptengine. This will + translate a Pascal script into a compiled form the executer understands. } + Exec: TPSExec; + { TPSExec is the executer part of the scriptengine. It uses the output of + the compiler to run a script. } + Data: string; +begin + Compiler := TPSPascalCompiler.Create; // create an instance of the compiler. + Compiler.OnUses := ScriptOnUses; // assign the OnUses event. + if not Compiler.Compile(Script) then // Compile the Pascal script into bytecode. + begin + Compiler.Free; + // You could raise an exception here. + Exit; + end; + + Compiler.GetOutput(Data); // Save the output of the compiler in the string Data. + Compiler.Free; // After compiling the script, there is no need for the compiler anymore. + + Exec := TPSExec.Create; // Create an instance of the executer. + + RegisterDLLRuntime(Exec); + { Register the DLL runtime library. This can be found in the uPSR_dll.pas file.} + + if not Exec.LoadData(Data) then // Load the data from the Data string. + begin + { For some reason the script could not be loaded. This is usually the case when a + library that has been used at compile time isn't registered at runtime. } + Exec.Free; + // You could raise an exception here. + Exit; + end; + + Exec.RunScript; // Run the script. + Exec.Free; // Free the executer. +end; + + +const + Script = + 'function MessageBox(hWnd: Longint; lpText, lpCaption: PChar; uType: Longint): Longint; external ''MessageBoxA@user32.dll stdcall'';'#13#10 + + 'var s: string; begin s := ''Test''; MessageBox(0, s, ''Caption Here!'', 0);end.'; + +begin + ExecuteScript(Script); +end. diff --git a/Samples/Console/sample4.dpr b/Samples/Console/sample4.dpr new file mode 100644 index 0000000..1c7e052 --- /dev/null +++ b/Samples/Console/sample4.dpr @@ -0,0 +1,107 @@ +program sample4; + +uses + uPSCompiler, + uPSRuntime, + uPSC_std, + uPSC_controls, + uPSC_stdctrls, + uPSC_forms, + uPSR_std, + uPSR_controls, + uPSR_stdctrls, + uPSR_forms, + forms + + ; + +function ScriptOnUses(Sender: TPSPascalCompiler; const Name: string): Boolean; +{ the OnUses callback function is called for each "uses" in the script. + It's always called with the parameter 'SYSTEM' at the top of the script. + For example: uses ii1, ii2; + This will call this function 3 times. First with 'SYSTEM' then 'II1' and then 'II2'. +} +begin + if Name = 'SYSTEM' then + begin + SIRegister_Std(Sender); + { This will register the declarations of these classes: + TObject, TPersistent, TComponent. This can be found + in the uPSC_std.pas unit. } + + SIRegister_Controls(Sender); + { This will register the declarations of these classes: + TControl, TWinControl, TFont, TStrings, TStringList, TCanvas, TGraphicControl. This can be found + in the uPSC_controls.pas unit. } + + SIRegister_Forms(Sender); + { This will register: TScrollingWinControl, TCustomForm, TForm and TApplication. uPSC_forms.pas unit. } + + SIRegister_stdctrls(Sender); + { This will register: TButtonContol, TButton, TCustomCheckbox, TCheckBox, TCustomEdit, TEdit, TCustomMemo, TMemo, + TCustomLabel and TLabel. Can be found in the uPSC_stdctrls.pas unit. } + + Result := True; + end else + Result := False; +end; + +procedure ExecuteScript(const Script: string); +var + Compiler: TPSPascalCompiler; + { TPSPascalCompiler is the compiler part of the scriptengine. This will + translate a Pascal script into a compiled form the executer understands. } + Exec: TPSExec; + { TPSExec is the executer part of the scriptengine. It uses the output of + the compiler to run a script. } + Data: string; + CI: TPSRuntimeClassImporter; +begin + Compiler := TPSPascalCompiler.Create; // create an instance of the compiler. + Compiler.OnUses := ScriptOnUses; // assign the OnUses event. + if not Compiler.Compile(Script) then // Compile the Pascal script into bytecode. + begin + Compiler.Free; + // You could raise an exception here. + Exit; + end; + + Compiler.GetOutput(Data); // Save the output of the compiler in the string Data. + Compiler.Free; // After compiling the script, there is no need for the compiler anymore. + + CI := TPSRuntimeClassImporter.Create; + { Create an instance of the runtime class importer.} + + RIRegister_Std(CI); // uPSR_std.pas unit. + RIRegister_stdctrls(CI); // uPSR_stdctrls.pas unit. + RIRegister_Controls(CI); // uPSR_controls.pas unit. + RIRegister_Forms(CI); // uPSR_forms.pas unit. + + Exec := TPSExec.Create; // Create an instance of the executer. + + RegisterClassLibraryRuntime(Exec, CI); + // Assign the runtime class importer to the executer. + + if not Exec.LoadData(Data) then // Load the data from the Data string. + begin + { For some reason the script could not be loaded. This is usually the case when a + library that has been used at compile time isn't registered at runtime. } + Exec.Free; + // You could raise an exception here. + Exit; + end; + + Exec.RunScript; // Run the script. + Exec.Free; // Free the executer. + CI.Free; // Free the runtime class importer. +end; + + + +const + Script = + 'var f: TForm; i: Longint; begin f := TForm.CreateNew(nil,0); f.Show; for i := 0 to 1000000 do; f.Hide; f.free; end.'; + +begin + ExecuteScript(Script); +end. diff --git a/Samples/Console/sample5.dpr b/Samples/Console/sample5.dpr new file mode 100644 index 0000000..cefa69f --- /dev/null +++ b/Samples/Console/sample5.dpr @@ -0,0 +1,113 @@ +program sample5; + +uses + uPSCompiler, + uPSRuntime, + uPSC_std, + uPSC_controls, + uPSC_stdctrls, + uPSC_forms, + uPSR_std, + uPSR_controls, + uPSR_stdctrls, + uPSR_forms, + forms + + ; + +function ScriptOnUses(Sender: TPSPascalCompiler; const Name: string): Boolean; +{ the OnUses callback function is called for each "uses" in the script. + It's always called with the parameter 'SYSTEM' at the top of the script. + For example: uses ii1, ii2; + This will call this function 3 times. First with 'SYSTEM' then 'II1' and then 'II2'. +} +begin + if Name = 'SYSTEM' then + begin + SIRegister_Std(Sender); + { This will register the declarations of these classes: + TObject, TPersisent. This can be found + in the uPSC_std.pas unit. } + SIRegister_Controls(Sender); + { This will register the declarations of these classes: + TControl, TWinControl, TFont, TStrings, TStringList, TGraphicControl. This can be found + in the uPSC_controls.pas unit. } + + SIRegister_Forms(Sender); + { This will register: TScrollingWinControl, TCustomForm, TForm and TApplication. uPSC_forms.pas unit. } + + SIRegister_stdctrls(Sender); + { This will register: TButtonContol, TButton, TCustomCheckbox, TCheckBox, TCustomEdit, TEdit, TCustomMemo, TMemo, + TCustomLabel and TLabel. Can be found in the uPSC_stdctrls.pas unit. } + + AddImportedClassVariable(Sender, 'Application', 'TApplication'); + // Registers the application variable to the script engine. + + Result := True; + end else + Result := False; +end; + +procedure ExecuteScript(const Script: string); +var + Compiler: TPSPascalCompiler; + { TPSPascalCompiler is the compiler part of the scriptengine. This will + translate a Pascal script into a compiled form the executer understands. } + Exec: TPSExec; + { TPSExec is the executer part of the scriptengine. It uses the output of + the compiler to run a script. } + Data: string; + CI: TPSRuntimeClassImporter; +begin + Compiler := TPSPascalCompiler.Create; // create an instance of the compiler. + Compiler.OnUses := ScriptOnUses; // assign the OnUses event. + if not Compiler.Compile(Script) then // Compile the Pascal script into bytecode. + begin + Compiler.Free; + // You could raise an exception here. + Exit; + end; + + Compiler.GetOutput(Data); // Save the output of the compiler in the string Data. + Compiler.Free; // After compiling the script, there is no need for the compiler anymore. + + CI := TPSRuntimeClassImporter.Create; + { Create an instance of the runtime class importer.} + + RIRegister_Std(CI); // uPSR_std.pas unit. + RIRegister_Controls(CI); // uPSR_controls.pas unti. + RIRegister_stdctrls(CI); // uPSR_stdctrls.pas unit. + RIRegister_Forms(CI); // uPSR_forms.pas unit. + + Exec := TPSExec.Create; // Create an instance of the executer. + + RegisterClassLibraryRuntime(Exec, CI); + // Assign the runtime class importer to the executer. + + if not Exec.LoadData(Data) then // Load the data from the Data string. + begin + { For some reason the script could not be loaded. This is usually the case when a + library that has been used at compile time isn't registered at runtime. } + Exec.Free; + // You could raise an exception here. + Exit; + end; + + SetVariantToClass(Exec.GetVarNo(Exec.GetVar('APPLICATION')), Application); + // This will set the script's Application variable to the real Application variable. + + Exec.RunScript; // Run the script. + Exec.Free; // Free the executer. + CI.Free; // Free the runtime class importer. +end; + + + + +const + Script = + 'var f: TForm; i: Longint; begin f := TForm.CreateNew(f, 0); f.Show; while f.Visible do Application.ProcessMessages; F.free; end.'; + +begin + ExecuteScript(Script); +end. diff --git a/Samples/Console/sample6.dpr b/Samples/Console/sample6.dpr new file mode 100644 index 0000000..86e9c13 --- /dev/null +++ b/Samples/Console/sample6.dpr @@ -0,0 +1,136 @@ +program sample6; + +uses + uPSCompiler, + uPSUtils, + uPSRuntime, + + Dialogs + + ; + +procedure MyOwnFunction(const Data: string); +begin + // Do something with Data + ShowMessage(Data); +end; + +function ScriptOnExportCheck(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure; const ProcDecl: string): Boolean; +{ + The OnExportCheck callback function is called for each function in the script + (Also for the main proc, with '!MAIN' as a Proc^.Name). ProcDecl contains the + result type and parameter types of a function using this format: + ProcDecl: ResultType + ' ' + Parameter1 + ' ' + Parameter2 + ' '+Parameter3 + ..... + Parameter: ParameterType+TypeName + ParameterType is @ for a normal parameter and ! for a var parameter. + A result type of 0 means no result. +} +begin + if Proc.Name = 'TEST' then // Check if the proc is the Test proc we want. + begin + if not ExportCheck(Sender, Proc, [0, btString], [pmIn]) then // Check if the proc has the correct params. + begin + { Something is wrong, so cause an error at the declaration position of the proc. } + Sender.MakeError('', ecTypeMismatch, ''); + Result := False; + Exit; + end; + Result := True; + end else Result := True; +end; + +function ScriptOnUses(Sender: TPSPascalCompiler; const Name: string): Boolean; +{ the OnUses callback function is called for each "uses" in the script. + It's always called with the parameter 'SYSTEM' at the top of the script. + For example: uses ii1, ii2; + This will call this function 3 times. First with 'SYSTEM' then 'II1' and then 'II2'. +} +begin + if Name = 'SYSTEM' then + begin + Sender.AddDelphiFunction('procedure MyOwnFunction(Data: string)'); + { This will register the function to the script engine. Now it can be used from within the script. } + + Result := True; + end else + Result := False; +end; + +procedure ExecuteScript(const Script: string); +var + Compiler: TPSPascalCompiler; + { TPSPascalCompiler is the compiler part of the scriptengine. This will + translate a Pascal script into a compiled form the executer understands. } + Exec: TPSExec; + { TPSExec is the executer part of the scriptengine. It uses the output of + the compiler to run a script. } + Data: string; + + N: PIfVariant; + { The variant in which we are going to store the parameter } + ParamList: TIfList; + { The parameter list} +begin + Compiler := TPSPascalCompiler.Create; // create an instance of the compiler. + Compiler.OnUses := ScriptOnUses; // assign the OnUses event. + + Compiler.OnExportCheck := ScriptOnExportCheck; // Assign the onExportCheck event. + + if not Compiler.Compile(Script) then // Compile the Pascal script into bytecode. + begin + Compiler.Free; + // You could raise an exception here. + Exit; + end; + + Compiler.GetOutput(Data); // Save the output of the compiler in the string Data. + Compiler.Free; // After compiling the script, there is no need for the compiler anymore. + + Exec := TPSExec.Create; // Create an instance of the executer. + + Exec.RegisterDelphiFunction(@MyOwnFunction, 'MYOWNFUNCTION', cdRegister); + { This will register the function to the executer. The first parameter is the executer. The second parameter is a + pointer to the function. The third parameter is the name of the function (in uppercase). And the last parameter is the + calling convention (usually Register). } + + if not Exec.LoadData(Data) then // Load the data from the Data string. + begin + { For some reason the script could not be loaded. This is usually the case when a + library that has been used at compile time isn't registered at runtime. } + Exec.Free; + // You could raise an exception here. + Exit; + end; + + ParamList := TIfList.Create; // Create the parameter list + + N := CreateHeapVariant(Exec.FindType2(btString)); + { Create a variant for the string parameter } + if n = nil then + begin + { Something is wrong. Exit here } + ParamList.Free; + Exec.Free; + Exit; + end; + VSetString(n, 'Test Parameter!'); + // Put something in the string parameter. + + ParamList.Add(n); // Add it to the parameter list. + + Exec.RunProc(ParamList, Exec.GetProc('TEST')); + { This will call the test proc that was exported before } + + FreePIFVariantList(ParamList); // Cleanup the parameters (This will also free N) + + Exec.Free; // Free the executer. +end; + + + +const + Script = 'procedure test(s: string); begin MyOwnFunction(''Test is called: ''+s);end; begin end.'; + +begin + ExecuteScript(Script); +end. diff --git a/Samples/Console/sample7.dpr b/Samples/Console/sample7.dpr new file mode 100644 index 0000000..2c470d2 --- /dev/null +++ b/Samples/Console/sample7.dpr @@ -0,0 +1,145 @@ +program sample7; + +uses + uPSCompiler, + uPSRuntime, + uPSUtils, + + Dialogs + + ; + +procedure MyOwnFunction(const Data: string); +begin + // Do something with Data + ShowMessage(Data); +end; + +function ScriptOnExportCheck(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure; const ProcDecl: string): Boolean; +{ + The OnExportCheck callback function is called for each function in the script + (Also for the main proc, with '!MAIN' as a Proc^.Name). ProcDecl contains the + result type and parameter types of a function using this format: + ProcDecl: ResultType + ' ' + Parameter1 + ' ' + Parameter2 + ' '+Parameter3 + ..... + Parameter: ParameterType+TypeName + ParameterType is @ for a normal parameter and ! for a var parameter. + A result type of 0 means no result. +} +begin + if Proc.Name = 'TEST' then // Check if the proc is the Test proc we want. + begin + if ProcDecl <> '0 @TSTRINGARRAY' then // Check if the proc has the correct params. + begin + { Something is wrong, so cause an error. } + Sender.MakeError('', ecTypeMismatch, ''); + Result := False; + Exit; + end; + { Export the proc; This is needed because PS doesn't store the name of a + function by default } + Result := True; + end else Result := True; +end; + +function ScriptOnUses(Sender: TPSPascalCompiler; const Name: string): Boolean; +{ the OnUses callback function is called for each "uses" in the script. + It's always called with the parameter 'SYSTEM' at the top of the script. + For example: uses ii1, ii2; + This will call this function 3 times. First with 'SYSTEM' then 'II1' and then 'II2'. +} +begin + if Name = 'SYSTEM' then + begin + + Sender.AddDelphiFunction('procedure MyOwnFunction(Data: string)'); + { This will register the function to the script engine. Now it can be used from within the script. } + + Sender.AddTypeS('TSTRINGARRAY', 'array of string').ExportName := True; + { Add the type to the script engine (and export it) } + + Result := True; + end else + Result := False; +end; + +type + TStringArr = array[0..1] of string; + +procedure ExecuteScript(const Script: string); +var + Compiler: TPSPascalCompiler; + { TPSPascalCompiler is the compiler part of the scriptengine. This will + translate a Pascal script into a compiled form the executer understands. } + Exec: TPSExec; + { TPSExec is the executer part of the scriptengine. It uses the output of + the compiler to run a script. } + Data: string; + + N: PIfVariant; + { The variant in which we are going to store the parameter } + ParamList: TIfList; + { The parameter list} +begin + Compiler := TPSPascalCompiler.Create; // create an instance of the compiler. + Compiler.OnUses := ScriptOnUses; // assign the OnUses event. + + Compiler.OnExportCheck := ScriptOnExportCheck; // Assign the onExportCheck event. + + if not Compiler.Compile(Script) then // Compile the Pascal script into bytecode. + begin + Compiler.Free; + // You could raise an exception here. + Exit; + end; + + Compiler.GetOutput(Data); // Save the output of the compiler in the string Data. + Compiler.Free; // After compiling the script, there is no need for the compiler anymore. + + Exec := TPSExec.Create; // Create an instance of the executer. + + Exec.RegisterDelphiFunction(@MyOwnFunction, 'MYOWNFUNCTION', cdRegister); + + if not Exec.LoadData(Data) then // Load the data from the Data string. + begin + { For some reason the script could not be loaded. This is usually the case when a + library that has been used at compile time isn't registered at runtime. } + Exec.Free; + // You could raise an exception here. + Exit; + end; + + ParamList := TIfList.Create; // Create the parameter list + + n := CreateHeapVariant(Exec.GetTypeNo(Exec.GetType('TSTRINGARRAY'))); + { Create a variant for the array parameter } + if n = nil then + begin + { Something is wrong. Exit here } + ParamList.Free; + Exec.Free; + Exit; + end; + + PSDynArraySetLength(PPSVariantDynamicArray(n).Data, PPSVariantDynamicArray(n).VI.FType, 2); // Put two items in the array + TStringArr(PPSVariantDynamicArray(n).Data^)[0] := 'First item'; + TStringArr(PPSVariantDynamicArray(n).Data^)[1] := 'Second item'; + // Put something in the string parameter. + + ParamList.Add(n); // Add it to the parameter list. + + Exec.RunProc(ParamList, Exec.GetProc('TEST')); + { This will call the test proc that was exported before } + + FreePIFVariantList(ParamList); // Cleanup the parameters (This will also free N) + + Exec.Free; // Free the executer. +end; + + + +const + Script = 'procedure test(s: tstringarray); var i: Longint; begin for i := 0 to GetArrayLength(S) -1 do MyOwnFunction(''Test is called: ''+s[i]);end; begin end.'; + +begin + ExecuteScript(Script); +end. diff --git a/Samples/Console/sample8.dpr b/Samples/Console/sample8.dpr new file mode 100644 index 0000000..8f2342b --- /dev/null +++ b/Samples/Console/sample8.dpr @@ -0,0 +1,122 @@ +program sample8; + +uses + uPSCompiler, + uPSRuntime, + uPSUtils, + + Dialogs + + ; + +procedure MyOwnFunction(const Data: string); +begin + // Do something with Data + ShowMessage(Data); +end; + +function ScriptOnExportCheck(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure; const ProcDecl: string): Boolean; +{ + The OnExportCheck callback function is called for each function in the script + (Also for the main proc, with '!MAIN' as a Proc^.Name). ProcDecl contains the + result type and parameter types of a function using this format: + ProcDecl: ResultType + ' ' + Parameter1 + ' ' + Parameter2 + ' '+Parameter3 + ..... + Parameter: ParameterType+TypeName + ParameterType is @ for a normal parameter and ! for a var parameter. + A result type of 0 means no result. +} +begin + if Proc.Name = 'TEST' then // Check if the proc is the Test proc we want. + begin + if not ExportCheck(Sender, Proc, [btString, btString], [pmIn]) then // Check if the proc has the correct params. + begin + { Something is wrong, so cause an error. } + Sender.MakeError('', ecTypeMismatch, ''); + Result := False; + Exit; + end; + Result := True; + end else Result := True; +end; + +function ScriptOnUses(Sender: TPSPascalCompiler; const Name: string): Boolean; +{ the OnUses callback function is called for each "uses" in the script. + It's always called with the parameter 'SYSTEM' at the top of the script. + For example: uses ii1, ii2; + This will call this function 3 times. First with 'SYSTEM' then 'II1' and then 'II2'. +} +begin + if Name = 'SYSTEM' then + begin + + Sender.AddDelphiFunction('procedure MyOwnFunction(Data: string)'); + { This will register the function to the script engine. Now it can be used from within the script. } + + + Result := True; + end else + Result := False; +end; + +type + TTestFunction = function (const s: string): string of object; + // Header of the test function, added of object. + +procedure ExecuteScript(const Script: string); +var + Compiler: TPSPascalCompiler; + { TPSPascalCompiler is the compiler part of the scriptengine. This will + translate a Pascal script into a compiled form the executer understands. } + Exec: TPSExec; + { TPSExec is the executer part of the scriptengine. It uses the output of + the compiler to run a script. } + Data: string; + + TestFunc: TTestFunction; +begin + Compiler := TPSPascalCompiler.Create; // create an instance of the compiler. + Compiler.OnUses := ScriptOnUses; // assign the OnUses event. + + Compiler.OnExportCheck := ScriptOnExportCheck; // Assign the onExportCheck event. + + Compiler.AllowNoBegin := True; + Compiler.AllowNoEnd := True; // AllowNoBegin and AllowNoEnd allows it that begin and end are not required in a script. + + if not Compiler.Compile(Script) then // Compile the Pascal script into bytecode. + begin + Compiler.Free; + // You could raise an exception here. + Exit; + end; + + Compiler.GetOutput(Data); // Save the output of the compiler in the string Data. + Compiler.Free; // After compiling the script, there is no need for the compiler anymore. + + Exec := TPSExec.Create; // Create an instance of the executer. + + Exec.RegisterDelphiFunction(@MyOwnFunction, 'MYOWNFUNCTION', cdRegister); + + if not Exec.LoadData(Data) then // Load the data from the Data string. + begin + { For some reason the script could not be loaded. This is usually the case when a + library that has been used at compile time isn't registered at runtime. } + Exec.Free; + // You could raise an exception here. + Exit; + end; + + TestFunc := TTestFunction(Exec.GetProcAsMethodN('Test')); + if @TestFunc <> nil then + ShowMessage('Result from TestFunc(''test indata''): '+TestFunc('test indata')); + + Exec.Free; // Free the executer. +end; + + + +const + Script = 'function test(s: string): string; begin MyOwnFunction(''Test Called with param: ''+s); Result := ''Test Result: ''+s; end;'; + +begin + ExecuteScript(Script); +end. diff --git a/Samples/Debug/dlgConfirmReplace.dfm b/Samples/Debug/dlgConfirmReplace.dfm new file mode 100644 index 0000000000000000000000000000000000000000..2ae701ededbcb8930368901d137356aeb8fe96fd GIT binary patch literal 893 zcmaizKabil7{*O<Jp=E(Y^Sga`d`G>PxfZReAXP&yypzDhA?n_TP{ zaG+!b{hUy~efhV^n+a^B{S(0)w_IcHA0M1;bCo0#Un zl#J((A^ZWs5F$XbbtDW_wacZKpZy_h0kPK*>X0%L$oU+kD zTJKLeTFttNpk8xI*&8o9N}lB3!Sj|X;-w%5A1T&&PqyIb?>mF&Xhg>#tnf?-5pvVs zQA*AlnPlb78i}VRxRl(VC9f~{cGLX`h1-V>Ia28dQ@$p20fj0o$4g13GqO-+;VO&d zYkn~N<^TA0cgC-%ZbhwCR9{gsVJo1TYyZ&C&ib=)$L#Vi2Ph}5Jgmw?wSEq#RfQAL b(&zbKJ{NwV@(CpmyM)p!lSXBtelGMIXf+gE literal 0 HcmV?d00001 diff --git a/Samples/Debug/dlgConfirmReplace.pas b/Samples/Debug/dlgConfirmReplace.pas new file mode 100644 index 0000000..cbbc6ca --- /dev/null +++ b/Samples/Debug/dlgConfirmReplace.pas @@ -0,0 +1,107 @@ +{------------------------------------------------------------------------------- +The contents of this file are subject to the Mozilla Public License +Version 1.1 (the "License"); you may not use this file except in compliance +with the License. You may obtain a copy of the License at +http://www.mozilla.org/MPL/ + +Software distributed under the License is distributed on an "AS IS" basis, +WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for +the specific language governing rights and limitations under the License. + +The Original Code is: dlgConfirmReplace.dpr, released 2000-06-23. + +The Original Code is part of the SearchReplaceDemo project, written by +Michael Hieke for the SynEdit component suite. +All Rights Reserved. + +Contributors to the SynEdit project are listed in the Contributors.txt file. + +Alternatively, the contents of this file may be used under the terms of the +GNU General Public License Version 2 or later (the "GPL"), in which case +the provisions of the GPL are applicable instead of those above. +If you wish to allow use of your version of this file only under the terms +of the GPL and not to allow others to use your version of this file +under the MPL, indicate your decision by deleting the provisions above and +replace them with the notice and other provisions required by the GPL. +If you do not delete the provisions above, a recipient may use your version +of this file under either the MPL or the GPL. + +$Id: dlgConfirmReplace.pas,v 1.2 2000/11/22 08:37:05 mghie Exp $ + +You may retrieve the latest version of this file at the SynEdit home page, +located at http://SynEdit.SourceForge.net + +Known Issues: +-------------------------------------------------------------------------------} + +unit dlgConfirmReplace; + +{$I SynEdit.inc} + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, ExtCtrls; + +type + TConfirmReplaceDialog = class(TForm) + btnReplace: TButton; + lblConfirmation: TLabel; + btnSkip: TButton; + btnCancel: TButton; + btnReplaceAll: TButton; + Image1: TImage; + procedure FormCreate(Sender: TObject); + procedure FormDestroy(Sender: TObject); + public + procedure PrepareShow(AEditorRect: TRect; X, Y1, Y2: integer; + AReplaceText: string); + end; + +var + ConfirmReplaceDialog: TConfirmReplaceDialog; + +implementation + +{$R *.DFM} + +resourcestring + SAskReplaceText = 'Replace this occurence of "%s"?'; + +{ TConfirmReplaceDialog } + +procedure TConfirmReplaceDialog.FormCreate(Sender: TObject); +begin + Image1.Picture.Icon.Handle := LoadIcon(0, IDI_QUESTION); +end; + +procedure TConfirmReplaceDialog.FormDestroy(Sender: TObject); +begin + ConfirmReplaceDialog := nil; +end; + +procedure TConfirmReplaceDialog.PrepareShow(AEditorRect: TRect; + X, Y1, Y2: integer; AReplaceText: string); +var + nW, nH: integer; +begin + lblConfirmation.Caption := Format(SAskReplaceText, [AReplaceText]); + nW := AEditorRect.Right - AEditorRect.Left; + nH := AEditorRect.Bottom - AEditorRect.Top; + + if nW <= Width then + X := AEditorRect.Left - (Width - nW) div 2 + else begin + if X + Width > AEditorRect.Right then + X := AEditorRect.Right - Width; + end; + if Y2 > AEditorRect.Top + MulDiv(nH, 2, 3) then + Y2 := Y1 - Height - 4 + else + Inc(Y2, 4); + SetBounds(X, Y2, Width, Height); +end; + +end. + diff --git a/Samples/Debug/dlgReplaceText.dfm b/Samples/Debug/dlgReplaceText.dfm new file mode 100644 index 0000000000000000000000000000000000000000..aa43ce86ba995fccf5aa913d4ab3175822c72ff9 GIT binary patch literal 479 zcmZXR%}&BV6ooHSC=>z3#Jw9$+!2@Vp!`T|(gr8dCDZoWPBL_wVTin!kKh~l488!q zfcA%qkExL%CZ032C*%3hac3|%d#?ddZ#vkWQ;J)?z*MjR$D9cn z^^bmTH_QRWwk2+8OZx?mxfg`}^dk{@%0LEiAc!pIa&I@)M0lZLMo_aP^Y zH#nHq{~%U|*enT99AOOri`sJK%PeR&@b@k9os`X&#q6uHx$y~A^^5jg= 10 then + break; + if i > 0 then + Result := Result + #13#10; + Result := Result + cbReplaceText.Items[i]; + end; +end; + +procedure TTextReplaceDialog.SetReplaceText(Value: string); +begin + cbReplaceText.Text := Value; +end; + +procedure TTextReplaceDialog.SetReplaceTextHistory(Value: string); +begin + cbReplaceText.Items.Text := Value; +end; + +procedure TTextReplaceDialog.FormCloseQuery(Sender: TObject; + var CanClose: Boolean); +var + s: string; + i: integer; +begin + inherited; + if ModalResult = mrOK then begin + s := cbReplaceText.Text; + if s <> '' then begin + i := cbReplaceText.Items.IndexOf(s); + if i > -1 then begin + cbReplaceText.Items.Delete(i); + cbReplaceText.Items.Insert(0, s); + cbReplaceText.Text := s; + end else + cbReplaceText.Items.Insert(0, s); + end; + end; +end; + +end. + + \ No newline at end of file diff --git a/Samples/Debug/dlgSearchText.dfm b/Samples/Debug/dlgSearchText.dfm new file mode 100644 index 0000000000000000000000000000000000000000..17e5674e7e2f538258cf1c02c585a52b897acc04 GIT binary patch literal 1439 zcmaKsKXcPC7{(R5vE%${o0cA{r@+)JcTC(dBu>)in&J|h3maAJH?gmZm6H{kPAnZ+ zS@;ATGaresz`z8u{4XtB7oTP6d4BKnO7fpNa^1mu*BNvt)>(hl9owhqWdE*;kb5~i zX}d0LxC5AZK|jQVF7_XO*cro|t9M9s=}P^E8a>K*N)c^@#TBZg0&wjjA&q+2=B5hF8C!G^lc(UzVo@Ua`;hKFsl&aHDZSeM}}0i-A%p l-9=M#cSE>aIP!p`gx~3p@IM4CU1k)d?87~XQbLlJ{srW%z{&ss literal 0 HcmV?d00001 diff --git a/Samples/Debug/dlgSearchText.pas b/Samples/Debug/dlgSearchText.pas new file mode 100644 index 0000000..c55ecb9 --- /dev/null +++ b/Samples/Debug/dlgSearchText.pas @@ -0,0 +1,216 @@ +{------------------------------------------------------------------------------- +The contents of this file are subject to the Mozilla Public License +Version 1.1 (the "License"); you may not use this file except in compliance +with the License. You may obtain a copy of the License at +http://www.mozilla.org/MPL/ + +Software distributed under the License is distributed on an "AS IS" basis, +WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for +the specific language governing rights and limitations under the License. + +The Original Code is: dlgSearchText.pas, released 2000-06-23. + +The Original Code is part of the SearchReplaceDemo project, written by +Michael Hieke for the SynEdit component suite. +All Rights Reserved. + +Contributors to the SynEdit project are listed in the Contributors.txt file. + +Alternatively, the contents of this file may be used under the terms of the +GNU General Public License Version 2 or later (the "GPL"), in which case +the provisions of the GPL are applicable instead of those above. +If you wish to allow use of your version of this file only under the terms +of the GPL and not to allow others to use your version of this file +under the MPL, indicate your decision by deleting the provisions above and +replace them with the notice and other provisions required by the GPL. +If you do not delete the provisions above, a recipient may use your version +of this file under either the MPL or the GPL. + +$Id: dlgSearchText.pas,v 1.3 2002/08/01 05:44:05 etrusco Exp $ + +You may retrieve the latest version of this file at the SynEdit home page, +located at http://SynEdit.SourceForge.net + +Known Issues: +-------------------------------------------------------------------------------} + +unit dlgSearchText; + +{$I SynEdit.inc} + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, ExtCtrls; + +type + TTextSearchDialog = class(TForm) + Label1: TLabel; + cbSearchText: TComboBox; + rgSearchDirection: TRadioGroup; + gbSearchOptions: TGroupBox; + cbSearchCaseSensitive: TCheckBox; + cbSearchWholeWords: TCheckBox; + cbSearchFromCursor: TCheckBox; + cbSearchSelectedOnly: TCheckBox; + btnOK: TButton; + btnCancel: TButton; + cbRegularExpression: TCheckBox; + procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); + private + function GetSearchBackwards: boolean; + function GetSearchCaseSensitive: boolean; + function GetSearchFromCursor: boolean; + function GetSearchInSelection: boolean; + function GetSearchText: string; + function GetSearchTextHistory: string; + function GetSearchWholeWords: boolean; + procedure SetSearchBackwards(Value: boolean); + procedure SetSearchCaseSensitive(Value: boolean); + procedure SetSearchFromCursor(Value: boolean); + procedure SetSearchInSelection(Value: boolean); + procedure SetSearchText(Value: string); + procedure SetSearchTextHistory(Value: string); + procedure SetSearchWholeWords(Value: boolean); + procedure SetSearchRegularExpression(const Value: boolean); + function GetSearchRegularExpression: boolean; + public + property SearchBackwards: boolean read GetSearchBackwards + write SetSearchBackwards; + property SearchCaseSensitive: boolean read GetSearchCaseSensitive + write SetSearchCaseSensitive; + property SearchFromCursor: boolean read GetSearchFromCursor + write SetSearchFromCursor; + property SearchInSelectionOnly: boolean read GetSearchInSelection + write SetSearchInSelection; + property SearchText: string read GetSearchText write SetSearchText; + property SearchTextHistory: string read GetSearchTextHistory + write SetSearchTextHistory; + property SearchWholeWords: boolean read GetSearchWholeWords + write SetSearchWholeWords; + property SearchRegularExpression: boolean read GetSearchRegularExpression + write SetSearchRegularExpression; + end; + +implementation + +{$R *.DFM} + +{ TTextSearchDialog } + +function TTextSearchDialog.GetSearchBackwards: boolean; +begin + Result := rgSearchDirection.ItemIndex = 1; +end; + +function TTextSearchDialog.GetSearchCaseSensitive: boolean; +begin + Result := cbSearchCaseSensitive.Checked; +end; + +function TTextSearchDialog.GetSearchFromCursor: boolean; +begin + Result := cbSearchFromCursor.Checked; +end; + +function TTextSearchDialog.GetSearchInSelection: boolean; +begin + Result := cbSearchSelectedOnly.Checked; +end; + +function TTextSearchDialog.GetSearchRegularExpression: boolean; +begin + Result := cbRegularExpression.Checked; +end; + +function TTextSearchDialog.GetSearchText: string; +begin + Result := cbSearchText.Text; +end; + +function TTextSearchDialog.GetSearchTextHistory: string; +var + i: integer; +begin + Result := ''; + for i := 0 to cbSearchText.Items.Count - 1 do begin + if i >= 10 then + break; + if i > 0 then + Result := Result + #13#10; + Result := Result + cbSearchText.Items[i]; + end; +end; + +function TTextSearchDialog.GetSearchWholeWords: boolean; +begin + Result := cbSearchWholeWords.Checked; +end; + +procedure TTextSearchDialog.SetSearchBackwards(Value: boolean); +begin + rgSearchDirection.ItemIndex := Ord(Value); +end; + +procedure TTextSearchDialog.SetSearchCaseSensitive(Value: boolean); +begin + cbSearchCaseSensitive.Checked := Value; +end; + +procedure TTextSearchDialog.SetSearchFromCursor(Value: boolean); +begin + cbSearchFromCursor.Checked := Value; +end; + +procedure TTextSearchDialog.SetSearchInSelection(Value: boolean); +begin + cbSearchSelectedOnly.Checked := Value; +end; + +procedure TTextSearchDialog.SetSearchText(Value: string); +begin + cbSearchText.Text := Value; +end; + +procedure TTextSearchDialog.SetSearchTextHistory(Value: string); +begin + cbSearchText.Items.Text := Value; +end; + +procedure TTextSearchDialog.SetSearchWholeWords(Value: boolean); +begin + cbSearchWholeWords.Checked := Value; +end; + +procedure TTextSearchDialog.SetSearchRegularExpression( + const Value: boolean); +begin + cbRegularExpression.Checked := Value; +end; + +{ event handlers } + +procedure TTextSearchDialog.FormCloseQuery(Sender: TObject; + var CanClose: Boolean); +var + s: string; + i: integer; +begin + if ModalResult = mrOK then begin + s := cbSearchText.Text; + if s <> '' then begin + i := cbSearchText.Items.IndexOf(s); + if i > -1 then begin + cbSearchText.Items.Delete(i); + cbSearchText.Items.Insert(0, s); + cbSearchText.Text := s; + end else + cbSearchText.Items.Insert(0, s); + end; + end; +end; + +end. + + \ No newline at end of file diff --git a/Samples/Debug/ide.dpr b/Samples/Debug/ide.dpr new file mode 100644 index 0000000..93083e9 --- /dev/null +++ b/Samples/Debug/ide.dpr @@ -0,0 +1,21 @@ +program ide; + +uses + Forms, + ide_editor in 'ide_editor.pas' {editor}, + ide_debugoutput in 'ide_debugoutput.pas' {debugoutput}, + uFrmGotoLine in 'uFrmGotoLine.pas' {frmGotoLine}, + dlgSearchText in 'dlgSearchText.pas' {TextSearchDialog}, + dlgConfirmReplace in 'dlgConfirmReplace.pas' {ConfirmReplaceDialog}, + dlgReplaceText in 'dlgReplaceText.pas' {TextReplaceDialog}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(Teditor, editor); + Application.CreateForm(Tdebugoutput, debugoutput); + Application.CreateForm(TfrmGotoLine, frmGotoLine); + Application.CreateForm(TConfirmReplaceDialog, ConfirmReplaceDialog); + Application.Run; +end. diff --git a/Samples/Debug/ide.res b/Samples/Debug/ide.res new file mode 100644 index 0000000000000000000000000000000000000000..a80858393190b78573e3a8e964b75e01337cf1b1 GIT binary patch literal 876 zcmZuw!D`e{6g`;)3`FV_g?85=l-8YwECpL>QC!&mgOp|~gXHZrr3(XD^jD^2Biv0~ z`5QtvE@xN4;`Q8@WSoMRIeGWIbMAeQ_vQh>j8N^t^j`d&jCx2<;I--WaWtBqGMN#F zM1WzMHUEza;15;R5BxGEDs){(!8T!o_5;8Dz7$EeX)&ehBaxhut$18FHnHL`mT!)B zpss6?>wnxEGDOG6!(1cnHKNyLIZTjecvBST<)L@fO`A>j%CacVJWr@koGad!A6MKt zH&2UmUl7-ld0q|;MDlIQqmGg9^?q=HZRb*#roJ9A7r1is{dNB3mh!G&54OOZ4Sz>H zw}xB$E`7EbIFDp2b#7M%9yjfDlBP%o19|49(ZGhr6B!J(*nuV@^1=If=roW6tsUr%_nXEYDeJ+zJ}zBDJ*ENaSn7`(QK!U-XoBWO_1g$cV)PRiHYe3snuv z@KTo>(B(sXUdA~1WdL>zcWd~=oH#J>?`7E0i_0sm^t*O + AddedKeystrokes = < + item + Command = ecContextHelp + ShortCut = 16496 + end> + end + object messages: TListBox + Left = 0 + Top = 315 + Width = 688 + Height = 81 + Align = alBottom + ItemHeight = 16 + TabOrder = 1 + OnDblClick = messagesDblClick + end + object StatusBar: TStatusBar + Left = 0 + Top = 396 + Width = 688 + Height = 19 + Panels = < + item + Width = 50 + end> + end + object ce: TPSScriptDebugger + CompilerOptions = [] + OnCompile = ceCompile + OnExecute = ceExecute + OnAfterExecute = ceAfterExecute + Plugins = < + item + Plugin = IFPS3CE_DateUtils1 + end + item + Plugin = IFPS3CE_Std1 + end + item + Plugin = IFPS3CE_Controls1 + end + item + Plugin = IFPS3CE_StdCtrls1 + end + item + Plugin = IFPS3CE_Forms1 + end + item + Plugin = IFPS3DllPlugin1 + end + item + Plugin = IFPS3CE_ComObj1 + end> + MainFileName = 'Unnamed' + UsePreProcessor = True + OnNeedFile = ceNeedFile + OnIdle = ceIdle + OnLineInfo = ceLineInfo + OnBreakpoint = ceBreakpoint + Left = 592 + Top = 112 + end + object IFPS3DllPlugin1: TPSDllPlugin + Left = 560 + Top = 112 + end + object pashighlighter: TSynPasSyn + Left = 592 + Top = 64 + end + object PopupMenu1: TPopupMenu + Left = 592 + Top = 16 + object BreakPointMenu: TMenuItem + Caption = '&Set/Clear Breakpoint' + ShortCut = 116 + OnClick = BreakPointMenuClick + end + end + object MainMenu1: TMainMenu + Left = 592 + Top = 160 + object File1: TMenuItem + Caption = '&File' + object New1: TMenuItem + Caption = '&New' + ShortCut = 16462 + OnClick = New1Click + end + object N3: TMenuItem + Caption = '-' + end + object Open1: TMenuItem + Caption = '&Open...' + ShortCut = 16463 + OnClick = Open1Click + end + object Save1: TMenuItem + Caption = '&Save' + ShortCut = 16467 + OnClick = Save1Click + end + object Saveas1: TMenuItem + Caption = 'Save &as...' + OnClick = Saveas1Click + end + object N4: TMenuItem + Caption = '-' + end + object Exit1: TMenuItem + Caption = '&Exit' + OnClick = Exit1Click + end + end + object Search1: TMenuItem + Caption = '&Search' + object Find1: TMenuItem + Caption = '&Find...' + OnClick = Find1Click + end + object Replace1: TMenuItem + Caption = '&Replace...' + OnClick = Replace1Click + end + object Searchagain1: TMenuItem + Caption = '&Search again' + OnClick = Searchagain1Click + end + object N6: TMenuItem + Caption = '-' + end + object Gotolinenumber1: TMenuItem + Caption = '&Go to...' + OnClick = Gotolinenumber1Click + end + end + object Run1: TMenuItem + Caption = '&Run' + object Syntaxcheck1: TMenuItem + Caption = 'Syntax &check' + OnClick = Syntaxcheck1Click + end + object Decompile1: TMenuItem + Caption = '&Decompile...' + OnClick = Decompile1Click + end + object N5: TMenuItem + Caption = '-' + end + object StepOver1: TMenuItem + Caption = '&Step Over' + ShortCut = 119 + OnClick = StepOver1Click + end + object StepInto1: TMenuItem + Caption = 'Step &Into' + ShortCut = 118 + OnClick = StepInto1Click + end + object N1: TMenuItem + Caption = '-' + end + object Pause1: TMenuItem + Caption = '&Pause' + OnClick = Pause1Click + end + object Reset1: TMenuItem + Caption = 'R&eset' + ShortCut = 16497 + OnClick = Reset1Click + end + object N2: TMenuItem + Caption = '-' + end + object Run2: TMenuItem + Caption = '&Run' + ShortCut = 120 + OnClick = Run2Click + end + end + end + object SaveDialog1: TSaveDialog + DefaultExt = 'ROPS' + Filter = 'ROPS Files|*.ROPS' + Options = [ofHideReadOnly, ofPathMustExist, ofEnableSizing] + Left = 200 + Top = 104 + end + object OpenDialog1: TOpenDialog + DefaultExt = 'ROPS' + Filter = 'ROPS Files|*.ROPS' + Options = [ofHideReadOnly, ofPathMustExist, ofFileMustExist, ofEnableSizing] + Left = 168 + Top = 104 + end + object IFPS3CE_Controls1: TPSImport_Controls + EnableStreams = True + EnableGraphics = True + EnableControls = True + Left = 328 + Top = 40 + end + object IFPS3CE_DateUtils1: TPSImport_DateUtils + Left = 328 + Top = 72 + end + object IFPS3CE_Std1: TPSImport_Classes + EnableStreams = True + EnableClasses = True + Left = 328 + Top = 104 + end + object IFPS3CE_Forms1: TPSImport_Forms + EnableForms = True + EnableMenus = True + Left = 328 + Top = 136 + end + object IFPS3CE_StdCtrls1: TPSImport_StdCtrls + EnableExtCtrls = True + EnableButtons = True + Left = 328 + Top = 168 + end + object IFPS3CE_ComObj1: TPSImport_ComObj + Left = 328 + Top = 200 + end + object SynEditSearch: TSynEditSearch + Left = 136 + Top = 216 + end + object SynEditRegexSearch: TSynEditRegexSearch + Left = 168 + Top = 216 + end +end diff --git a/Samples/Debug/ide_editor.pas b/Samples/Debug/ide_editor.pas new file mode 100644 index 0000000..14fcdce --- /dev/null +++ b/Samples/Debug/ide_editor.pas @@ -0,0 +1,649 @@ +//Version: 31Jan2005 + +unit ide_editor; + +interface + +uses + Windows, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, Menus, ExtCtrls, StdCtrls, ComCtrls, + SynEdit, SynEditTypes, SynHighlighterPas, + uPSComponent_COM, uPSComponent_StdCtrls, uPSComponent_Forms, + uPSComponent_Default, uPSComponent_Controls, + uPSRuntime, uPSDisassembly, uPSUtils, + uPSComponent, uPSDebugger, SynEditRegexSearch, + SynEditSearch, SynEditMiscClasses, SynEditHighlighter; + +type + Teditor = class(TForm) + ce: TPSScriptDebugger; + IFPS3DllPlugin1: TPSDllPlugin; + pashighlighter: TSynPasSyn; + ed: TSynEdit; + PopupMenu1: TPopupMenu; + BreakPointMenu: TMenuItem; + MainMenu1: TMainMenu; + File1: TMenuItem; + Run1: TMenuItem; + StepOver1: TMenuItem; + StepInto1: TMenuItem; + N1: TMenuItem; + Reset1: TMenuItem; + N2: TMenuItem; + Run2: TMenuItem; + Exit1: TMenuItem; + messages: TListBox; + Splitter1: TSplitter; + SaveDialog1: TSaveDialog; + OpenDialog1: TOpenDialog; + N3: TMenuItem; + N4: TMenuItem; + New1: TMenuItem; + Open1: TMenuItem; + Save1: TMenuItem; + Saveas1: TMenuItem; + StatusBar: TStatusBar; + Decompile1: TMenuItem; + N5: TMenuItem; + IFPS3CE_Controls1: TPSImport_Controls; + IFPS3CE_DateUtils1: TPSImport_DateUtils; + IFPS3CE_Std1: TPSImport_Classes; + IFPS3CE_Forms1: TPSImport_Forms; + IFPS3CE_StdCtrls1: TPSImport_StdCtrls; + IFPS3CE_ComObj1: TPSImport_ComObj; + Pause1: TMenuItem; + SynEditSearch: TSynEditSearch; + SynEditRegexSearch: TSynEditRegexSearch; + Search1: TMenuItem; + Find1: TMenuItem; + Replace1: TMenuItem; + Searchagain1: TMenuItem; + N6: TMenuItem; + Gotolinenumber1: TMenuItem; + Syntaxcheck1: TMenuItem; + procedure edSpecialLineColors(Sender: TObject; Line: Integer; var Special: Boolean; var FG, BG: TColor); + procedure BreakPointMenuClick(Sender: TObject); + procedure ceLineInfo(Sender: TObject; const FileName: String; Position, Row, Col: Cardinal); + procedure Exit1Click(Sender: TObject); + procedure StepOver1Click(Sender: TObject); + procedure StepInto1Click(Sender: TObject); + procedure Reset1Click(Sender: TObject); + procedure ceIdle(Sender: TObject); + procedure Run2Click(Sender: TObject); + procedure ceExecute(Sender: TPSScript); + procedure ceAfterExecute(Sender: TPSScript); + procedure ceCompile(Sender: TPSScript); + procedure New1Click(Sender: TObject); + procedure Open1Click(Sender: TObject); + procedure Save1Click(Sender: TObject); + procedure Saveas1Click(Sender: TObject); + procedure edStatusChange(Sender: TObject; Changes: TSynStatusChanges); + procedure Decompile1Click(Sender: TObject); + function ceNeedFile(Sender: TObject; const OrginFileName: String; var FileName, Output: String): Boolean; + procedure ceBreakpoint(Sender: TObject; const FileName: String; Position, Row, Col: Cardinal); + procedure Pause1Click(Sender: TObject); + procedure messagesDblClick(Sender: TObject); + procedure Gotolinenumber1Click(Sender: TObject); + procedure Find1Click(Sender: TObject); + procedure Searchagain1Click(Sender: TObject); + procedure Replace1Click(Sender: TObject); + procedure Syntaxcheck1Click(Sender: TObject); + procedure edDropFiles(Sender: TObject; X, Y: Integer; + AFiles: TStrings); + private + FSearchFromCaret: boolean; + FActiveLine: Longint; + FResume: Boolean; + FActiveFile: string; + function Compile: Boolean; + function Execute: Boolean; + + procedure Writeln(const s: string); + procedure Readln(var s: string); + procedure SetActiveFile(const Value: string); + + procedure DoSearchReplaceText(AReplace: boolean; ABackwards: boolean); + procedure ShowSearchReplaceDialog(AReplace: boolean); + + property aFile: string read FActiveFile write SetActiveFile; + public + function SaveCheck: Boolean; + end; + +var + editor: Teditor; + +implementation + +uses + ide_debugoutput, + uFrmGotoLine, + dlgSearchText, dlgReplaceText, dlgConfirmReplace; + +{$R *.dfm} + +const + isRunningOrPaused = [isRunning, isPaused]; + +// options - to be saved to the registry +var + gbSearchBackwards: boolean; + gbSearchCaseSensitive: boolean; + gbSearchFromCaret: boolean; + gbSearchSelectionOnly: boolean; + gbSearchTextAtCaret: boolean; + gbSearchWholeWords: boolean; + gbSearchRegex: boolean; + gsSearchText: string; + gsSearchTextHistory: string; + gsReplaceText: string; + gsReplaceTextHistory: string; + +resourcestring + STR_TEXT_NOTFOUND = 'Text not found'; + STR_UNNAMED = 'Unnamed'; + STR_SUCCESSFULLY_COMPILED = 'Succesfully compiled'; + STR_SUCCESSFULLY_EXECUTED = 'Succesfully executed'; + STR_RUNTIME_ERROR='[Runtime error] %s(%d:%d), bytecode(%d:%d): %s'; //Birb + STR_FORM_TITLE = 'Editor'; + STR_FORM_TITLE_RUNNING = 'Editor - Running'; + STR_INPUTBOX_TITLE = 'Script'; + STR_DEFAULT_PROGRAM = 'Program test;'#13#10'begin'#13#10'end.'; + STR_NOTSAVED = 'File has not been saved, save now?'; + +procedure Teditor.DoSearchReplaceText(AReplace: boolean; ABackwards: boolean); +var + Options: TSynSearchOptions; +begin + Statusbar.SimpleText := ''; + if AReplace then + Options := [ssoPrompt, ssoReplace, ssoReplaceAll] + else + Options := []; + if ABackwards then + Include(Options, ssoBackwards); + if gbSearchCaseSensitive then + Include(Options, ssoMatchCase); + if not fSearchFromCaret then + Include(Options, ssoEntireScope); + if gbSearchSelectionOnly then + Include(Options, ssoSelectedOnly); + if gbSearchWholeWords then + Include(Options, ssoWholeWord); + if gbSearchRegex then + ed.SearchEngine := SynEditRegexSearch + else + ed.SearchEngine := SynEditSearch; + if ed.SearchReplace(gsSearchText, gsReplaceText, Options) = 0 then + begin + MessageBeep(MB_ICONASTERISK); + Statusbar.SimpleText := STR_TEXT_NOTFOUND; + if ssoBackwards in Options then + ed.BlockEnd := ed.BlockBegin + else + ed.BlockBegin := ed.BlockEnd; + ed.CaretXY := ed.BlockBegin; + end; + + if ConfirmReplaceDialog <> nil then + ConfirmReplaceDialog.Free; +end; + +procedure Teditor.ShowSearchReplaceDialog(AReplace: boolean); +var + dlg: TTextSearchDialog; +begin + Statusbar.SimpleText := ''; + if AReplace then + dlg := TTextReplaceDialog.Create(Self) + else + dlg := TTextSearchDialog.Create(Self); + with dlg do try + // assign search options + SearchBackwards := gbSearchBackwards; + SearchCaseSensitive := gbSearchCaseSensitive; + SearchFromCursor := gbSearchFromCaret; + SearchInSelectionOnly := gbSearchSelectionOnly; + // start with last search text + SearchText := gsSearchText; + if gbSearchTextAtCaret then begin + // if something is selected search for that text + if ed.SelAvail and (ed.BlockBegin.Line = ed.BlockEnd.Line) //Birb (fix at SynEdit's SearchReplaceDemo) + then + SearchText := ed.SelText + else + SearchText := ed.GetWordAtRowCol(ed.CaretXY); + end; + SearchTextHistory := gsSearchTextHistory; + if AReplace then with dlg as TTextReplaceDialog do begin + ReplaceText := gsReplaceText; + ReplaceTextHistory := gsReplaceTextHistory; + end; + SearchWholeWords := gbSearchWholeWords; + if ShowModal = mrOK then begin + gbSearchBackwards := SearchBackwards; + gbSearchCaseSensitive := SearchCaseSensitive; + gbSearchFromCaret := SearchFromCursor; + gbSearchSelectionOnly := SearchInSelectionOnly; + gbSearchWholeWords := SearchWholeWords; + gbSearchRegex := SearchRegularExpression; + gsSearchText := SearchText; + gsSearchTextHistory := SearchTextHistory; + if AReplace then with dlg as TTextReplaceDialog do begin + gsReplaceText := ReplaceText; + gsReplaceTextHistory := ReplaceTextHistory; + end; + fSearchFromCaret := gbSearchFromCaret; + if gsSearchText <> '' then begin + DoSearchReplaceText(AReplace, gbSearchBackwards); + fSearchFromCaret := TRUE; + end; + end; + finally + dlg.Free; + end; +end; + +procedure Teditor.edSpecialLineColors(Sender: TObject; Line: Integer; + var Special: Boolean; var FG, BG: TColor); +begin + if ce.HasBreakPoint(ce.MainFileName, Line) then + begin + Special := True; + if Line = FActiveLine then + begin + BG := clWhite; + FG := clRed; + end else + begin + FG := clWhite; + BG := clRed; + end; + end else + if Line = FActiveLine then + begin + Special := True; + FG := clWhite; + bg := clBlue; + end else Special := False; +end; + +procedure Teditor.BreakPointMenuClick(Sender: TObject); +var + Line: Longint; +begin + Line := Ed.CaretY; + if ce.HasBreakPoint(ce.MainFileName, Line) then + ce.ClearBreakPoint(ce.MainFileName, Line) + else + ce.SetBreakPoint(ce.MainFileName, Line); + ed.Refresh; +end; + +procedure Teditor.ceLineInfo(Sender: TObject; const FileName: String; Position, Row, + Col: Cardinal); +begin + if (ce.Exec.DebugMode <> dmRun) and (ce.Exec.DebugMode <> dmStepOver) then + begin + FActiveLine := Row; + if (FActiveLine < ed.TopLine +2) or (FActiveLine > Ed.TopLine + Ed.LinesInWindow -2) then + begin + Ed.TopLine := FActiveLine - (Ed.LinesInWindow div 2); + end; + ed.CaretY := FActiveLine; + ed.CaretX := 1; + + ed.Refresh; + end + else + Application.ProcessMessages; +end; + +procedure Teditor.Exit1Click(Sender: TObject); +begin + Reset1Click(nil); //terminate any running script + if SaveCheck then //check if script changed and not yet saved + Close; +end; + +procedure Teditor.StepOver1Click(Sender: TObject); +begin + if ce.Exec.Status in isRunningOrPaused then + ce.StepOver + else + begin + if Compile then + begin + ce.StepInto; + Execute; + end; + end; +end; + +procedure Teditor.StepInto1Click(Sender: TObject); +begin + if ce.Exec.Status in isRunningOrPaused then + ce.StepInto + else + begin + if Compile then + begin + ce.StepInto; + Execute; + end; + end; +end; + +procedure Teditor.Pause1Click(Sender: TObject); +begin + if ce.Exec.Status = isRunning then + begin + ce.Pause; + ce.StepInto; + end; +end; + +procedure Teditor.Reset1Click(Sender: TObject); +begin + if ce.Exec.Status in isRunningOrPaused then + ce.Stop; +end; + +function Teditor.Compile: Boolean; +var + i: Longint; +begin + ce.Script.Assign(ed.Lines); + Result := ce.Compile; + messages.Clear; + for i := 0 to ce.CompilerMessageCount -1 do + begin + Messages.Items.Add(ce.CompilerMessages[i].MessageToString); + end; + if Result then + Messages.Items.Add(STR_SUCCESSFULLY_COMPILED); +end; + +procedure Teditor.ceIdle(Sender: TObject); +begin + Application.ProcessMessages; //Birb: don't use Application.HandleMessage here, else GUI will be unrensponsive if you have a tight loop and won't be able to use Run/Reset menu action + if FResume then + begin + FResume := False; + ce.Resume; + FActiveLine := 0; + ed.Refresh; + end; +end; + +procedure Teditor.Run2Click(Sender: TObject); +begin + if CE.Running then + begin + FResume := True + end else + begin + if Compile then + Execute; + end; +end; + +procedure Teditor.ceExecute(Sender: TPSScript); +begin + ce.SetVarToInstance('SELF', Self); + ce.SetVarToInstance('APPLICATION', Application); + Caption := STR_FORM_TITLE_RUNNING; +end; + +procedure Teditor.ceAfterExecute(Sender: TPSScript); +begin + Caption := STR_FORM_TITLE; + FActiveLine := 0; + ed.Refresh; +end; + +function Teditor.Execute: Boolean; +begin + debugoutput.Output.Clear; + if CE.Execute then + begin + Messages.Items.Add(STR_SUCCESSFULLY_EXECUTED); + Result := True; + end else + begin + messages.Items.Add(Format(STR_RUNTIME_ERROR, [extractFileName(aFile), ce.ExecErrorRow,ce.ExecErrorCol,ce.ExecErrorProcNo,ce.ExecErrorByteCodePosition,ce.ExecErrorToString])); //Birb + Result := False; + end; +end; + +procedure Teditor.Writeln(const s: string); +begin + debugoutput.output.Lines.Add(S); + debugoutput.Visible := True; +end; + +procedure Teditor.ceCompile(Sender: TPSScript); +begin + Sender.AddMethod(Self, @TEditor.Writeln, 'procedure writeln(s: string)'); + Sender.AddMethod(Self, @TEditor.Readln, 'procedure readln(var s: string)'); + Sender.AddRegisteredVariable('Self', 'TForm'); + Sender.AddRegisteredVariable('Application', 'TApplication'); +end; + +procedure Teditor.Readln(var s: string); +begin + s := InputBox(STR_INPUTBOX_TITLE, '', ''); +end; + +procedure Teditor.New1Click(Sender: TObject); +begin + if SaveCheck then //check if script changed and not yet saved + begin + ed.ClearAll; + ed.Lines.Text := STR_DEFAULT_PROGRAM; + ed.Modified := False; + aFile := ''; + end; +end; + +procedure Teditor.Open1Click(Sender: TObject); +begin + if SaveCheck then //check if script changed and not yet saved + begin + if OpenDialog1.Execute then + begin + ed.ClearAll; + ed.Lines.LoadFromFile(OpenDialog1.FileName); + ed.Modified := False; + aFile := OpenDialog1.FileName; + end; + end; +end; + +procedure Teditor.Save1Click(Sender: TObject); +begin + if aFile <> '' then + begin + ed.Lines.SaveToFile(aFile); + ed.Modified := False; + end else + SaveAs1Click(nil); +end; + +procedure Teditor.Saveas1Click(Sender: TObject); +begin + if SaveDialog1.Execute then + begin + aFile := SaveDialog1.FileName; + ed.Lines.SaveToFile(aFile); + ed.Modified := False; + end; +end; + +//check if script changed and not yet saved// +function Teditor.SaveCheck: Boolean; +begin + if ed.Modified then + begin + case MessageDlg(STR_NOTSAVED, mtConfirmation, mbYesNoCancel, 0) of + idYes: + begin + Save1Click(nil); + Result := aFile <> ''; + end; + IDNO: Result := True; + else + Result := False; + end; + end else Result := True; +end; + +procedure Teditor.edStatusChange(Sender: TObject; + Changes: TSynStatusChanges); +begin + StatusBar.Panels[0].Text := IntToStr(ed.CaretY)+':'+IntToStr(ed.CaretX) +end; + +procedure Teditor.Decompile1Click(Sender: TObject); +var + s: string; +begin + if Compile then + begin + ce.GetCompiled(s); + IFPS3DataToText(s, s); + debugoutput.output.Lines.Text := s; + debugoutput.visible := true; + end; +end; + +function Teditor.ceNeedFile(Sender: TObject; const OrginFileName: String; + var FileName, Output: String): Boolean; +var + path: string; + f: TFileStream; +begin + if aFile <> '' then + Path := ExtractFilePath(aFile) + else + Path := ExtractFilePath(ParamStr(0)); + Path := Path + FileName; + try + F := TFileStream.Create(Path, fmOpenRead or fmShareDenyWrite); + except + Result := false; + exit; + end; + try + SetLength(Output, f.Size); + f.Read(Output[1], Length(Output)); + finally + f.Free; + end; + Result := True; +end; + +procedure Teditor.ceBreakpoint(Sender: TObject; const FileName: String; Position, Row, + Col: Cardinal); +begin + FActiveLine := Row; + if (FActiveLine < ed.TopLine +2) or (FActiveLine > Ed.TopLine + Ed.LinesInWindow -2) then + begin + Ed.TopLine := FActiveLine - (Ed.LinesInWindow div 2); + end; + ed.CaretY := FActiveLine; + ed.CaretX := 1; + + ed.Refresh; +end; + +procedure Teditor.SetActiveFile(const Value: string); +begin + FActiveFile := Value; + ce.MainFileName := ExtractFileName(FActiveFile); + if Ce.MainFileName = '' then + Ce.MainFileName := STR_UNNAMED; +end; + +function GetErrorRowCol(const inStr: string): TBufferCoord; +var + Row:string; + Col:string; + p1,p2,p3:integer; +begin + p1:=Pos('(',inStr); + p2:=Pos(':',inStr); + p3:=Pos(')',inStr); + if (p1>0) and (p2>p1) and (p3>p2) then + begin + Row := Copy(inStr, p1+1,p2-p1-1); + Col := Copy(inStr, p2+1,p3-p2-1); + Result.Char := StrToInt(Trim(Col)); + Result.Line := StrToInt(Trim(Row)); + end + else + begin + Result.Char := 1; + Result.Line := 1; + end +end; + +procedure Teditor.messagesDblClick(Sender: TObject); +begin + //if Copy(messages.Items[messages.ItemIndex],1,7)= '[Error]' then + //begin + ed.CaretXY := GetErrorRowCol(messages.Items[messages.ItemIndex]); + ed.SetFocus; + //end; +end; + +procedure Teditor.Gotolinenumber1Click(Sender: TObject); +begin + with TfrmGotoLine.Create(self) do + try + Char := ed.CaretX; + Line := ed.CaretY; + ShowModal; + if ModalResult = mrOK then + ed.CaretXY := CaretXY; + finally + Free; + ed.SetFocus; + end; +end; + +procedure Teditor.Find1Click(Sender: TObject); +begin + ShowSearchReplaceDialog(FALSE); +end; + +procedure Teditor.Searchagain1Click(Sender: TObject); +begin + DoSearchReplaceText(FALSE, FALSE); +end; + +procedure Teditor.Replace1Click(Sender: TObject); +begin + ShowSearchReplaceDialog(TRUE); +end; + +procedure Teditor.Syntaxcheck1Click(Sender: TObject); +begin + Compile; +end; + +procedure Teditor.edDropFiles(Sender: TObject; X, Y: Integer; + AFiles: TStrings); +begin + if AFiles.Count>=1 then + if SaveCheck then //check if script changed and not yet saved + begin + ed.ClearAll; + ed.Lines.LoadFromFile(AFiles[0]); + ed.Modified := False; + aFile := AFiles[0]; + end; +end; + +end. + diff --git a/Samples/Debug/readme.txt b/Samples/Debug/readme.txt new file mode 100644 index 0000000..e4a5045 --- /dev/null +++ b/Samples/Debug/readme.txt @@ -0,0 +1 @@ +This demo requires SynEdit (http://synedit.sf.net) to compile. \ No newline at end of file diff --git a/Samples/Debug/uFrmGotoLine.dfm b/Samples/Debug/uFrmGotoLine.dfm new file mode 100644 index 0000000000000000000000000000000000000000..e41c5f809e99a69ffa8c74451f4e81a15437bcd0 GIT binary patch literal 802 zcmaKq-)_?|7{y(OCQXyDA#uSSk+??#i5u?LwCN_LP1P9f1_Vy>b+P2wljCaTIe=H; z!FT~^{xscIiL2PLzTf%I(fK<@BwR1%F^Qw=ysvK0JzjLrgX*Fe(%Udg;cbZ9Ij_10qC zZ&--{IQ$cl9ph4i^NZ;sQd&J+qCn|)((0e^E^;MHN>@-kr|7mkoVRol&Y*x z-iqyjS1VB0A}jE2Tq|`N=g1@xO@Vtn<+ab{woE}aG2xeWO8CXFafu`IFw^Jb)DwO? zf*z7;b? z>Hu*62S5l}WU|#-3akCRYnu}{&B5huV)621fxdvVc@sF&u8yeUY$>}ox)$ajB+abcHigi+t+r_LI{z< zOG^8Nw^`S+p#Hr8ZN{nJN=k|*=tlK;(}LFlc#RW9_#aoXeN+FF#3mDkg@vNHxL5=N z0a037D$2{tg=JZyqM|~iQYn#6r^S>hQ$%B9qu6l64aLlvGsW!Lv&G!GbHx^0Y$3MU zW*aeY-aIjX{(Q09Zo7$v3m1xg_Sr`)Uc6Wwc;JEJkV6g;M;vj4IQH0M#R(^zAWk{u z6tQH<5^>g9XNj}VK3klB{`unKi!T;eTycfC`s%C2_19l7Zoc_uar^DJi@WZ+OWb$g zed56f9~6&1`lxu~i6_J}&pabuc;N-{^2;xaS6_Wqy#D&@V)^pr;+=Qi5%0bCp7`ja zkHjaRd?G&o{B!ZuS6_*5zWGM{@WT({=bwKTzx?ux_~Va1#9x2?CI0#6A44GP-ma6t zItf4mi7*U8VPQdGSz=^)go+A_oaUe?C@9ZIk}UES;j$^%nwMjnJm^9`pF`k`U=xTk zkG4WsKKm;21wx@f0JOlME>Yk?z$R$q3&-M?6)P_D2xJqWIj%BT&tx(~5DtgHSrI9O$Ra2U1@JFkQ$qp{kzt8!+CvyDS?nhe zw-PpiF@ge40uyr@%}D`nEoTH919-77TTB{);*-sBg%yDs!Gd&nITI%e!Ztx7Y!j&V zfmjAZm{aW#*bwaY5Og?JZnK0D5_$yc2AliB=&6V-Db+}^eVr9j!ox3NM@p8`B`8xF zehCCJBa~q#t(F?qe<)EN2qbH2YLcm>RRop52qFBAAC*)oQ?xHjw=~80WvZbj5GYTp z5ui^>`$FYpAfyLKK~u_S%xGz1p+GXt5fW5a5I`1cgaGBr_T^=DGZjG#+BZxIg{(RfsP^bT>?mJ|x?0Be<&Cq@ zo;;DDJWyU&$M)22j1ac9H5`WG75Y^BnX_hLgccGsHO52XIuN82Tr;@J;QEz%b1@VO zye;2k6GZ?FUr8L#BPK)h2MH z6b_{kZPcaEngnXe5d+#IP>JDPD+pQ=jg%5FghRITyZf76#ZkQSkqj#w;a%D-vojhTfcoVy`}@OV+@pHvAVf) z(Y|~Nqzab8;S}cq?G**ub4|zNRKA2rf*^s&sTFdq!w55Gl%YN50di6t*$XI{h@m|e zKm(^^76?)xuu_=VvT&R%#Hrz+D2s8rtVEc~2Yp6+3k=PjiS|@JTw$fbY_5i&-7AMW z75QjM$&j_lW^?B@8U)aIt_PB+%NHxh)Y+z54X_yqW+aA>U=M*=;8fc-E;_N=;v`>*BH8(?$(N>C8 zwWn?bbocOZB&bmYt#cjaQ`*WE2VGKA?Tb6z;}$1DQn8dxfB_mCQm_t~hoR5 zB84JwFmS~+Bq-I8V>}%qo4~4TrIZNT#sF=tD_0Yd-5hG6M!-x{H8KP(bur8v2;9vv zi~k*Zy7>SV*xbPo7d1xgJ7sl_B%Dx7{YF@l`mfu0p)}C z=>e#%HQ8Mb`_z!MIU+-`)Ucn&`h}D$3UrRu$z1DyLR9j;Qiw^s_X$zJdl!15~jC&Wqci-`q`hHE_jsE-4 zC&yEF@Uw!S^&R|b{xu$j54bd5bq9VWhfYT>5_fbsj(2pZpu##~;N{Km8Z5-=p7 z5|s%PN-K=-GH>I>#f8O;^d{gk3u3B8wavG%jdTvTZC)%bLPz9@07#zmd3_u_4U;lp&I14 z&?y=qSkygCn>LLq5w(97^%%AaJn(m0l8s4V7z+3584%Xa);zSNp>x5AL#=LX5KY!M zw6si1ClyTBA_NMwup)p)Ib;#r9YIhI_K1siXrS8aDhHGPPOhA!LJNc$orq1^5O!1| zb_uOOSb$eSpZyxwg=hgUpvB^HOd5&>pXX6?mb)N$it-XTq62gpdEU$s;D3 zaSQ?}T<$og1mC6b%EU2SU0p3|Yik9jTwvOSj$bgF0$GNt z!*93Uc4DWUb`rbqzPs3Ck3CfEvj6`3i-Qh2NHBI`4gQ#8ju9uGc%nGtj59KEi>|+4 zcG+d(y6dhJH{N)o&@s!s_uea(En6lYfBbP3ue|iqOQNr@PrUZpYvRo}-&FC+2OoSO zzWCw`@!fadiSNJvUi|v&ui|gSC+n_t5?CjJRggez;>3dSeoYuH_AwGD7;l^Th(DUJ zqLC7R@pzh<$^Kw?@?(W%onL>&dARQgy~sEJlLsV^q` z9Y+(3RaRG9CBaIKFkKmqOtuaB|M2AsoZLJNq^7e_n-p~dcY|sIJGk}~~0)j+9B7s2ygUo|L0)qqw3H~Kw zw;sfQ3-S)O27iQK4As}ycf&_YV35EdfkCbg2JkOYgB?I!p?wXqI;<~yH!azJ|ClRZt*Tx%fEH~O{BZ;#F zlC=Dt`em$#EM0QuL4todapJ^|)nGY8it(Ef>kpC#^5(`sJX>zLrQCPleI?>1i8BoH zfCCOtpZD5pFNqjS?!5EPa^Ado66YTz&Os<_#LsntHJuMbH*l=-8pm!)Ga~ds$`BZo z95n{aiA3xtPd@o%iE|bb=Pe}8U5pw75(tU@Wpi`0!eOpy*F5yE3WiNL-Lx5JM+T__ zz@YR%V?gXGySlpMIp>@saW+IQS+ZocFi<{RPslSec4>7mpwiw9`3wSs1O}-wP_K_W z?l_6_D-!iTdBFu2tWgZqMfweGTU{8sGfJK34fHeA*4EY!43cwfVxWE_KTtYz(M1=n zHU^Htxuq`Zbwz!m@5q5+#5IkzxODT)H@1JdB2?N;mkA7lsHG2@eim~->#vCkuyE?t`O4~!LXuF(?%?QXu9 zkG{n#*3cNdVhznd_ON<(*<}}npBNYy;EbePzI=HG1LuMEk}(3#UCN%G9{JEi4=D_! z(LU~m8*cE#aO9Ckdd7S@_NJ}Q6)zD3?Us`RWps%-5HS!p^+03bTEzLzEDY2ooCB3F zzWAbi_St9UlTSXG!N3?o`)TTw7Y5?a6}J)t=aw;GE)0~9N8H+py~Ae8+r)6|t+z^? zO&v9cd+xa>oIcGoo) zFJ9aU3~KFb4A_I0tAauM2l@bQTQvseI$n94)+Mf=k@7g&Aa`x1y}i8?wSQ@1!1;G+ zV!*k1$@Pcx^m*5`_HoS3O#eU(*gMGhX|H*p4IC+tqmOgfmteCN0E09!&~KR-dV717 zf53T*ylYy=t<-hXKTwyL?`R+AH4n5QBjuvx-yM4+E@{KF57NZIm;vWEG8pK)XcrlS z<+DpV_9h>0ABR1gjE^&OAibs;gO8L?bKRJAzR8m(_tO6|wlXo$e*gB{Zy5~KAMNAr zyz|bS7s2R6Y{)i2i()XDds3#@{%ErV%UBWpedCfJ~$SbeB zQpKER>`e@u2kH{n1I{yL{DT(;(h>vbfx5)?z&U5!O1nhc;8Aa_B>#x@o7v99faiK7 zp1sLn`0&FIRi7pXGv+g6Z#@rsJ!re6{X@Qa(Cb0hBZz@DGTK>Jy|tgb>+A5t4{Av7+E&WrznTZipYVbG0%v78$NZR@9>eky5~Xj|zYuwN}1x6;Sa_CNO6WAc$l9+5bQC-GdF ziX|8qVZU24)?g0AHBGxj+e-gHAE#|7*9>Dmt`)6I28K?Pcl{n1Iv4|*7_bj7fB*e= zPYkAy8*9Ae_7CoOi8&B!mG1Qb4BUUnlD+1ici4%3HwMN7|1}2AhnJtmI?mF2lXt#9 z`skyZfnm^%f%)%$g@HPSvl?FUQm>m|ug}2HPJ8Xf@L$XWeFk$NolhHndVu>tUi^A} z2Mpa_7`PsCt?AWS4~$po_jL~B@^RclY4+kX-*>q%&`;C0y8VM0^Nl5cz&RYr_+RG_ zE)0X*2g=81zTbdhsn$!pF74E)Db3X8vI2qGO4doc)K@))&oduDcU!w0p&TW*+CRYv>%v zBj)Qy{M?pnytVng6MHj%$jX66(4|4vj8XS)$1Aip`5SBBSPyN;L)tJ8olb40)2WfQ zLzh^qTw`mJyx}k@UbyoxDepY^$@>Z%1m(R8=ZAP_E`OZ^b*#T&X)W1!rO*prPl3)N?^?L-NTyKh@{R4}|*ppi0US zuTFL6L0+8WDlyM-;czW3_j%eBzS|tH%sDR5tm=ga5i4<4r~|oo59%L-x*o{7GS3fi z-#EkvAUaNUvY{__seu8$2K7yZFgJA5*oQ3DP+~+yK z1J4DGN){NS8TGzF@SyTf^1%IP=Dv8AOT`QD$*N}I=7DhlV=(3)nzx2{eRn3MqnbGpV_?!FA+_xDm4~SoSnSbaQnEPt1ZH$En;%Ci7 z?^#lB+&p;c17z2s>oq11ti5tBC|l;)tX+A@fwd=&If`|mbkfv2=uZf-+#uso^1!&x ziwEv==b8)h$vHRI1#JXtM_jwy3pe$_T$_j~JJ>hJWvtNI*{NcBFCKEug_nIGz1B(U z1Nk%UgO&mIKn57sk_X1Z_**)ey?6FOnJ^FL+;W}a*~Kh5ux{jKAN1PPJaAo@Ym;^o zF;S)7za@4&->CMUnO`tAWZuWRE9)`LYbj^yfXM^%6fYZP+6T=8WuVXK&{kv2b{&^- zZQE?l@!?Nd

HMlIe6Jgj%C^?#LbM?aLfT2L1-&kK zen|T)Qx0CXdhfmWHtpm9baVl8S@OWS#oyjiJn+m0b&~Zw))}-M9)9>?WhZG9xK~6T zn44>#Wy-H&Eo4_rsw2jy7`zULaGyttRbHq5oX zY&F{?U{1m9-XTHV@>mL;e{6}du6N(#?@-x^|7o9jEr+U$iKa>_gxFW`YXnOPT_2d*>iv$XHlF$~YM7(5Ij?&-+Y|7gFbeK2j5 z_7{10=m!rSjH^dG#%S8nR>Rh`K@Rj;-Spi~{LsTV%8BJh)Gu=^*=PTGmt4;TccFaX zyiBsZ@6n$1m~nmfEAwnHY9Jwu!)Jp#RrzSeBzXiLK}(^%{XAMB-VLu~uxydSYn=KY zH4V^=bRid70Q=rUU(a|4f9piWy@+}Hk&m|LqDP((LX6tW+>x;=<3*j*(sna;LmzzZ ziO+XrttafWhj7-VpT3wrfwqHw6Z59xEBapU#dA-ZXPc1|51M_zKlIRE&{s0XrTsAb zpl*||DxAURc_z&Vu|VIN>0{`J*ay$tkawPc(0!19%7Z?T_L#XD`=C7FTbT<;JiDy? z8e>PsFU&u<&&xg-(?X^y*3eiSdGy0a_Yy1PB|P`6_LcEWw2Gm)Ps2XQJNuv?WW32f z$P@Ds`c2vuJSUyi2iH8Fv6k$E{)>H(PRo=z73UTGy7mX zq34BjOZ~t&z09xiY__sx%){6R<1g-!vk%IYePG>XWJ(!Rrtq6f84odTA}wtc$6#Cf zRQJ4au28F0Iz~N(ovUPickQ*;D!i!!7e*wT7B1iP#%;i z=Y{=I9-KR3hi~fUdeJoQJLN%{a$Y#M)DP+y^_05qZod*ejpmtHP1nWREnX{Fs|D>o z_@MYOMWb-%fB^;uG3TbXukaZ6Ph-{{w;!PVfK# literal 0 HcmV?d00001 diff --git a/Samples/Import/arraytest.rops b/Samples/Import/arraytest.rops new file mode 100644 index 0000000..667646e --- /dev/null +++ b/Samples/Import/arraytest.rops @@ -0,0 +1,22 @@ +Program IFSTest; +type + TArrayOfByte = array of byte; + +procedure Test(x: TARrayOfByte); +var + i: Integer; +begin + for i := 0 to Getarraylength(X) -1 do + begin + writeln(inttostr(x[i])); + end; +end; +var + temp: TArrayOfByte; + +Begin + setarraylength(temp, 2); + temp[0] := 1; + temp[1] :=23; + test(temp); +End. diff --git a/Samples/Import/booleantest.rops b/Samples/Import/booleantest.rops new file mode 100644 index 0000000..f09d50b --- /dev/null +++ b/Samples/Import/booleantest.rops @@ -0,0 +1,15 @@ +Program IFSTest; +var + x1, x2: integer; + b: boolean; +Begin + x1 := 2; + x2 := 2; + b := x1 = x2; + if b then begin writeln('true'); end else begin writeln('false');end; + x1 := 2; + x2 := 4; + b := x1 = x2; + if b then begin writeln('true'); end else begin writeln('false');end; + writeln('done'); +End. \ No newline at end of file diff --git a/Samples/Import/bytearray.rops b/Samples/Import/bytearray.rops new file mode 100644 index 0000000..a970225 --- /dev/null +++ b/Samples/Import/bytearray.rops @@ -0,0 +1,14 @@ +Program IFSTest; +type + TByteArray = array of byte; +var + x: TByteARray; +Begin + try + x[0] := 1; + // will cause an runtime error (Out Of Record Fields Range) + writeln('Not supposed to be here'); + except + Writeln('Error, which is ok since we accessed a field outside it''s bounds'); + end; +End. \ No newline at end of file diff --git a/Samples/Import/casetest.rops b/Samples/Import/casetest.rops new file mode 100644 index 0000000..b45c335 --- /dev/null +++ b/Samples/Import/casetest.rops @@ -0,0 +1,12 @@ +Program IFSTest; +var + b: Byte; +Begin + for b := 0 to 2 do begin + case b of + 0: writeln('0'); + 1: writeln('1'); + else writeln('>1'); + end; + end; +End. \ No newline at end of file diff --git a/Samples/Import/dlltest.rops b/Samples/Import/dlltest.rops new file mode 100644 index 0000000..c2bd052 --- /dev/null +++ b/Samples/Import/dlltest.rops @@ -0,0 +1,19 @@ +Program IFSTest; +// compile the demo application, minimize delphi and run this. +function FindWindow(C1, C2: PChar): Longint; external 'FindWindowA@user32.dll stdcall'; +function ShowWindow(hWnd, nCmdShow: Longint): Integer; external 'ShowWindow@user32.dll stdcall'; +function SetWindowText(hWnd: Longint; Text: PChar): Longint; external 'SetWindowTextA@user32.dll stdcall'; +var + i: Longint; + wnd: Longint; +Begin + wnd := Findwindow('', 'Innerfuse Pascal Script III'); + SetWindowText(Wnd, 'This is DLL demo, it calls some windows user32 routines. This will hide this window for a few seconds'); + for i := 0 to 200000 do begin end; + ShowWindow(Wnd, 0); // hide it + for i := 0 to 200000 do begin end; + SetWindowText(Wnd, 'Wasn''t that nice?'); + ShowWindow(Wnd, 5); // show it + for i := 0 to 200000 do begin end; + SetWindowText(Wnd, 'Innerfuse Pascal Script III'); +End. diff --git a/Samples/Import/exc.ROPS b/Samples/Import/exc.ROPS new file mode 100644 index 0000000..4350d3b --- /dev/null +++ b/Samples/Import/exc.ROPS @@ -0,0 +1,13 @@ +Program test; +var + I: Integer; +begin + try + I := I div 0; + except + try + except + end; + Writeln('SHOULD GET HERE'); + end; +end. diff --git a/Samples/Import/exittest.rops b/Samples/Import/exittest.rops new file mode 100644 index 0000000..682b825 --- /dev/null +++ b/Samples/Import/exittest.rops @@ -0,0 +1,14 @@ +Program IFSTest; +procedure test; +begin + writeln('1'); + exit; + writeln('2'); +end; +Begin + test; + writeln('3'); + exit; + writeln('4'); + +End. \ No newline at end of file diff --git a/Samples/Import/fDwin.dfm b/Samples/Import/fDwin.dfm new file mode 100644 index 0000000000000000000000000000000000000000..a19cf548397b8620f440d72f247bb628ea22c4a1 GIT binary patch literal 615 zcmYjOO>^2X5S8WFvQ0=cIkh*gy=2nqFTf^DGUdaA)zVul>;*JkBt{Y;`FHtKIVZ+u zpqJI`toFUP@4Y9459W^(a(Dfk62kN0UBIioR2NMd!P5D!#OHcT{{?edxwYS;;RDFk z+WC8rWn$~3R^iP+T461076`q$RF&QbnMQ3`Tw?0fP?T^v)XLpvYhf%n_GxfG?Ef6` zKiNZnR^0QXoi;m{CAJtGo?WLIw3PHMZn}xsK-e7@y+SD4E5OKQyI;5$gbulyVwD*X z4yL986GyqW@*tF5ZFNx^0F{AqV7j?{2DCYtM^&!r-{in}Qfr zyZW1A?Q?{Wny{l5o&GpxO}~VhP$gh|iaf|rTVMlNiXFPRGuD;B8Q8j^-kGPqf{+hz C8oK2G literal 0 HcmV?d00001 diff --git a/Samples/Import/fDwin.pas b/Samples/Import/fDwin.pas new file mode 100644 index 0000000..1f20539 --- /dev/null +++ b/Samples/Import/fDwin.pas @@ -0,0 +1,27 @@ +unit fDwin; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + ExtCtrls, StdCtrls; + +type + Tdwin = class(TForm) + Memo1: TMemo; + Panel1: TPanel; + Button1: TButton; + private + { Private declarations } + public + { Public declarations } + end; + +var + dwin: Tdwin; + +implementation + +{$R *.dfm} + +end. diff --git a/Samples/Import/fMain.dfm b/Samples/Import/fMain.dfm new file mode 100644 index 0000000000000000000000000000000000000000..fa64adc4d470454603c642c7b0925cd7ee443a71 GIT binary patch literal 1949 zcmd5-&2HO95T+>c-*yrdD1!DP^guKQBE<1Am&mjP8;yQyvB@#nNF#HRC70P{^6^UXIS`VZfTNB!&ZaB?#;9^L)LF^qUR zeB{L=gtH-KsaqMHXRs7)(rU*vZ+|kZ7kD9(_IIXz1^6}*?RCq&0+Pqu92_qZKfrcP z*&tHbB^ZZ z1CSZWHSk9`*?~sK=>5cbv94T zSH2=!(mXc2c$O0^WM!{1&a|wip;i4@srpT&s@b-q72{Gecg~*cB&$#GZRWU$Tu>os zY8X~Lf|Oe7PqUnPP^~Q+?6M<*<&gh{{=YT!4%ArTQ^aIHwJFz^B2z*x zo+IMM=(XO6X((|Ml-+_8=&=fCZ`8+4<$gV!^+RLULMitK&|;F2t@p14 zT83O!bujhi6fLJ}S>}BeA&(`}y(tD8ENajigwn6sXtXTXP|J=f<)lt?LU}JZ7mW}%qG`UTxf_;G?ku59L@Qx# zcAbu^@B{AmN@R^i65|wD-S(>z>ME=oYP30=Iexs`_+Q4J37Xf1tWfzoUhTI}cf@=h zdBDmXpZ`PYuS-%WTU=s}IEVCg^Yrdlq-8)iY=rDue*5-B+GK_b>FJjIgyeo_+r#-yP z`T4s(A$7>9f=``^{vGk)gf6e}0;=Eb9lD$%k&IScvcOzOUvb#^M)5!DbMZBOZy0hI Tb+qL$wfTP>rX>HRCU5)+)=X%B literal 0 HcmV?d00001 diff --git a/Samples/Import/fMain.pas b/Samples/Import/fMain.pas new file mode 100644 index 0000000..baea9d9 --- /dev/null +++ b/Samples/Import/fMain.pas @@ -0,0 +1,471 @@ +unit fMain; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + ExtCtrls, StdCtrls, uPSCompiler, uPSRuntime, uPSPreprocessor, uPSUtils, + Menus, uPSC_comobj, uPSR_comobj; + +type + TMainForm = class(TForm) + Memo1: TMemo; + Memo2: TMemo; + Splitter1: TSplitter; + MainMenu1: TMainMenu; + Toosl1: TMenuItem; + Compile1: TMenuItem; + CompilewithTimer1: TMenuItem; + File1: TMenuItem; + Exit1: TMenuItem; + N1: TMenuItem; + SaveAs1: TMenuItem; + Save1: TMenuItem; + Open1: TMenuItem; + New1: TMenuItem; + OpenDialog1: TOpenDialog; + SaveDialog1: TSaveDialog; + N2: TMenuItem; + Stop1: TMenuItem; + N3: TMenuItem; + CompileandDisassemble1: TMenuItem; + procedure Compile1Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure Exit1Click(Sender: TObject); + procedure New1Click(Sender: TObject); + procedure Open1Click(Sender: TObject); + procedure Save1Click(Sender: TObject); + procedure SaveAs1Click(Sender: TObject); + procedure Memo1Change(Sender: TObject); + procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); + procedure Stop1Click(Sender: TObject); + procedure CompileandDisassemble1Click(Sender: TObject); + procedure CompilewithTimer1Click(Sender: TObject); + private + fn: string; + changed: Boolean; + function SaveTest: Boolean; + public + { Public declarations } + end; + +var + MainForm: TMainForm; + +implementation + +uses + uPSDisassembly, uPSC_dll, uPSR_dll, uPSDebugger, + uPSR_std, uPSC_std, uPSR_stdctrls, uPSC_stdctrls, + uPSR_forms, uPSC_forms, + + uPSC_graphics, + uPSC_controls, + uPSC_classes, + uPSR_graphics, + uPSR_controls, + uPSR_classes, + fDwin; + +{$R *.DFM} + +var + Imp: TPSRuntimeClassImporter; + +function StringLoadFile(const Filename: string): string; +var + Stream: TStream; +begin + Stream := TFileStream.Create(Filename, fmOpenread or fmSharedenywrite); + try + SetLength(Result, Stream.Size); + Stream.Read(Result[1], Length(Result)); + finally + Stream.Free; + end; +end; + +function OnNeedFile(Sender: TPSPreProcessor; const callingfilename: string; var FileName, Output: string): Boolean; +var + s: string; +begin + s := ExtractFilePath(callingfilename); + if s = '' then s := ExtractFilePath(Paramstr(0)); + Filename := s + Filename; + if FileExists(Filename) then + begin + Output := StringLoadFile(Filename); + Result := True; + end else + Result := False; +end; + +function MyOnUses(Sender: TPSPascalCompiler; const Name: string): Boolean; +begin + if Name = 'SYSTEM' then + begin + TPSPascalCompiler(Sender).AddFunction('procedure Writeln(s: string);'); + TPSPascalCompiler(Sender).AddFunction('function Readln(question: string): string;'); + Sender.AddDelphiFunction('function ImportTest(S1: string; s2: Longint; s3: Byte; s4: word; var s5: string): string;'); + + Sender.AddConstantN('NaN', 'extended').Value.textended := 0.0 / 0.0; + Sender.AddConstantN('Infinity', 'extended').Value.textended := 1.0 / 0.0; + Sender.AddConstantN('NegInfinity', 'extended').Value.textended := - 1.0 / 0.0; + + SIRegister_Std(Sender); + SIRegister_Classes(Sender, True); + SIRegister_Graphics(Sender, True); + SIRegister_Controls(Sender); + SIRegister_stdctrls(Sender); + SIRegister_Forms(Sender); + SIRegister_ComObj(Sender); + + AddImportedClassVariable(Sender, 'Memo1', 'TMemo'); + AddImportedClassVariable(Sender, 'Memo2', 'TMemo'); + AddImportedClassVariable(Sender, 'Self', 'TForm'); + AddImportedClassVariable(Sender, 'Application', 'TApplication'); + + Result := True; + end + else + begin + TPSPascalCompiler(Sender).MakeError('', ecUnknownIdentifier, ''); + Result := False; + end; +end; + +function MyWriteln(Caller: TPSExec; p: TIFExternalProcRec; Global, Stack: TPSStack): Boolean; +var + PStart: Cardinal; +begin + if Global = nil then begin result := false; exit; end; + PStart := Stack.Count - 1; + MainForm.Memo2.Lines.Add(Stack.GetString(PStart)); + Result := True; +end; + +function MyReadln(Caller: TPSExec; p: TIFExternalProcRec; Global, Stack: TPSStack): Boolean; +var + PStart: Cardinal; +begin + if Global = nil then begin result := false; exit; end; + PStart := Stack.Count - 2; + Stack.SetString(PStart + 1, InputBox(MainForm.Caption, Stack.GetString(PStart), '')); + Result := True; +end; + +function ImportTest(S1: string; s2: Longint; s3: Byte; s4: word; var s5: string): string; +begin + Result := s1 + ' ' + IntToStr(s2) + ' ' + IntToStr(s3) + ' ' + IntToStr(s4) + ' - OK!'; + S5 := s5 + ' '+ result + ' - OK2!'; +end; + +var + IgnoreRunline: Boolean = False; + I: Integer; + +procedure RunLine(Sender: TPSExec); +begin + if IgnoreRunline then Exit; + i := (i + 1) mod 15; + Sender.GetVar(''); + if i = 0 then Application.ProcessMessages; +end; + +function MyExportCheck(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure; const ProcDecl: string): Boolean; +begin + Result := True; +end; + + +procedure TMainForm.Compile1Click(Sender: TObject); +var + x1: TPSPascalCompiler; + x2: TPSDebugExec; + xpre: TPSPreProcessor; + s, d: string; + + procedure Outputtxt(const s: string); + begin + Memo2.Lines.Add(s); + end; + + procedure OutputMsgs; + var + l: Longint; + b: Boolean; + begin + b := False; + for l := 0 to x1.MsgCount - 1 do + begin + Outputtxt(x1.Msg[l].MessageToString); + if (not b) and (x1.Msg[l] is TPSPascalCompilerError) then + begin + b := True; + Memo1.SelStart := X1.Msg[l].Pos; + end; + end; + end; +begin + if tag <> 0 then exit; + Memo2.Clear; + xpre := TPSPreProcessor.Create; + try + xpre.OnNeedFile := OnNeedFile; + xpre.MainFileName := fn; + xpre.MainFile := Memo1.Text; + xpre.PreProcess(xpre.MainFileName, s); + + x1 := TPSPascalCompiler.Create; + x1.OnExportCheck := MyExportCheck; + x1.OnUses := MyOnUses; + x1.OnExternalProc := DllExternalProc; + if x1.Compile(s) then + begin + Outputtxt('Succesfully compiled'); + xpre.AdjustMessages(x1); + OutputMsgs; + if not x1.GetOutput(s) then + begin + x1.Free; + Outputtxt('[Error] : Could not get data'); + exit; + end; + x1.GetDebugOutput(d); + x1.Free; + x2 := TPSDebugExec.Create; + try + RegisterDLLRuntime(x2); + RegisterClassLibraryRuntime(x2, Imp); + RIRegister_ComObj(x2); + + tag := longint(x2); + if sender <> nil then + x2.OnRunLine := RunLine; + x2.RegisterFunctionName('WRITELN', MyWriteln, nil, nil); + x2.RegisterFunctionName('READLN', MyReadln, nil, nil); + x2.RegisterDelphiFunction(@ImportTest, 'IMPORTTEST', cdRegister); + if not x2.LoadData(s) then + begin + Outputtxt('[Error] : Could not load data: '+TIFErrorToString(x2.ExceptionCode, x2.ExceptionString)); + tag := 0; + exit; + end; + x2.LoadDebugData(d); + SetVariantToClass(x2.GetVarNo(x2.GetVar('MEMO1')), Memo1); + SetVariantToClass(x2.GetVarNo(x2.GetVar('MEMO2')), Memo2); + SetVariantToClass(x2.GetVarNo(x2.GetVar('SELF')), Self); + SetVariantToClass(x2.GetVarNo(x2.GetVar('APPLICATION')), Application); + + x2.RunScript; + if x2.ExceptionCode <> erNoError then + Outputtxt('[Runtime Error] : ' + TIFErrorToString(x2.ExceptionCode, x2.ExceptionString) + + ' in ' + IntToStr(x2.ExceptionProcNo) + ' at ' + IntToSTr(x2.ExceptionPos)) + else + OutputTxt('Successfully executed'); + finally + tag := 0; + x2.Free; + end; + end + else + begin + Outputtxt('Failed when compiling'); + xpre.AdjustMessages(x1); + OutputMsgs; + x1.Free; + end; + finally + Xpre.Free; + end; +end; + +procedure TMainForm.FormCreate(Sender: TObject); +begin + Caption := 'RemObjects Pascal Script'; + fn := ''; + changed := False; + Memo1.Lines.Text := 'Program Test;'#13#10'Begin'#13#10'End.'; +end; + +procedure TMainForm.Exit1Click(Sender: TObject); +begin + Close; +end; + +procedure TMainForm.New1Click(Sender: TObject); +begin + if not SaveTest then + exit; + Memo1.Lines.Text := 'Program Test;'#13#10'Begin'#13#10'End.'; + Memo2.Lines.Clear; + fn := ''; +end; + +function TMainForm.SaveTest: Boolean; +begin + if changed then + begin + case MessageDlg('File is not saved, save now?', mtWarning, mbYesNoCancel, 0) of + mrYes: + begin + Save1Click(nil); + Result := not changed; + end; + mrNo: Result := True; + else + Result := False; + end; + end + else + Result := True; +end; + +procedure TMainForm.Open1Click(Sender: TObject); +begin + if not SaveTest then + exit; + if OpenDialog1.Execute then + begin + Memo1.Lines.LoadFromFile(OpenDialog1.FileName); + changed := False; + Memo2.Lines.Clear; + fn := OpenDialog1.FileName; + end; +end; + +procedure TMainForm.Save1Click(Sender: TObject); +begin + if fn = '' then + begin + Saveas1Click(nil); + end + else + begin + Memo1.Lines.SaveToFile(fn); + changed := False; + end; +end; + +procedure TMainForm.SaveAs1Click(Sender: TObject); +begin + SaveDialog1.FileName := ''; + if SaveDialog1.Execute then + begin + fn := SaveDialog1.FileName; + Memo1.Lines.SaveToFile(fn); + changed := False; + end; +end; + +procedure TMainForm.Memo1Change(Sender: TObject); +begin + changed := True; +end; + +procedure TMainForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean); +begin + CanClose := SaveTest; +end; + +procedure TMainForm.Stop1Click(Sender: TObject); +begin + if tag <> 0 then + TPSExec(tag).Stop; +end; + +procedure TMainForm.CompileandDisassemble1Click(Sender: TObject); +var + x1: TPSPascalCompiler; + xpre: TPSPreProcessor; + s, s2: string; + + procedure OutputMsgs; + var + l: Integer; + b: Boolean; + begin + b := False; + for l := 0 to x1.MsgCount - 1 do + begin + Memo2.Lines.Add(x1.Msg[l].MessageToString); + if (not b) and (x1.Msg[l] is TPSPascalCompilerError) then + begin + b := True; + Memo1.SelStart := X1.Msg[l].Pos; + end; + end; + end; +begin + if tag <> 0 then exit; + Memo2.Clear; + xpre := TPSPreProcessor.Create; + try + xpre.OnNeedFile := OnNeedFile; + xpre.MainFileName := fn; + xpre.MainFile := Memo1.Text; + xpre.PreProcess(xpre.MainFileName, s); + x1 := TPSPascalCompiler.Create; + x1.OnExternalProc := DllExternalProc; + x1.OnUses := MyOnUses; + if x1.Compile(s) then + begin + Memo2.Lines.Add('Succesfully compiled'); + xpre.AdjustMessages(x1); + OutputMsgs; + if not x1.GetOutput(s) then + begin + x1.Free; + Memo2.Lines.Add('[Error] : Could not get data'); + exit; + end; + x1.Free; + IFPS3DataToText(s, s2); + dwin.Memo1.Text := s2; + dwin.showmodal; + end + else + begin + Memo2.Lines.Add('Failed when compiling'); + xpre.AdjustMessages(x1); + OutputMsgs; + x1.Free; + end; + finally + xPre.Free; + end; +end; + + +procedure TMainForm.CompilewithTimer1Click(Sender: TObject); +var + Freq, Time1, Time2: Comp; +begin + if not QueryPerformanceFrequency(TLargeInteger((@Freq)^)) then + begin + ShowMessage('Your computer does not support Performance Timers!'); + exit; + end; + QueryPerformanceCounter(TLargeInteger((@Time1)^)); + IgnoreRunline := True; + try + Compile1Click(nil); + except + end; + IgnoreRunline := False; + QueryPerformanceCounter(TLargeInteger((@Time2)^)); + Memo2.Lines.Add('Time: ' + Sysutils.FloatToStr((Time2 - Time1) / Freq) + + ' sec'); +end; + +initialization + Imp := TPSRuntimeClassImporter.Create; + RIRegister_Std(Imp); + RIRegister_Classes(Imp, True); + RIRegister_Graphics(Imp, True); + RIRegister_Controls(Imp); + RIRegister_stdctrls(imp); + RIRegister_Forms(Imp); +finalization + Imp.Free; +end. diff --git a/Samples/Import/fortest.rops b/Samples/Import/fortest.rops new file mode 100644 index 0000000..5695ff5 --- /dev/null +++ b/Samples/Import/fortest.rops @@ -0,0 +1,9 @@ +Program IFSTest; +var + i: Longint; +Begin + for i := 0 to 9 do + begin + writeln('hello'+inttostr(i)); + end; +End. diff --git a/Samples/Import/if.rops b/Samples/Import/if.rops new file mode 100644 index 0000000..0db351c --- /dev/null +++ b/Samples/Import/if.rops @@ -0,0 +1,9 @@ +Program IFSTest; +var + a: boolean; +Begin + a := true; + if a then begin ;end else + if a then begin ;end else; + writeln('5'); +End. \ No newline at end of file diff --git a/Samples/Import/iformtest.rops b/Samples/Import/iformtest.rops new file mode 100644 index 0000000..e8e14ba --- /dev/null +++ b/Samples/Import/iformtest.rops @@ -0,0 +1,104 @@ +Program IFSTest; +var + F, Form: TForm; + Labl: TLabel; + Button: TButton; + Edit: TEdit; + Memo: TMemo; + Stop: Boolean; +procedure MyOnCloseQuery(Sender: TObject; var CanClose: Boolean); +begin + CanClose := Stop; +end; +procedure c2(sender: TObject); +begin + f.Close; +end; + +procedure buttonclick(sender: TObject); +var + l: TLabel; + b: TButton; +begin + if Length(Edit.Text) < 5 then + begin + f := TForm.Create(self); + f.Width := 100; + f.Height := 100; + f.Position := poScreenCenter; + f.BorderStyle := bsDialog; + f.Caption := 'Error'; + l := TLabel.Create(F); + l.parent := f; + l.Left := 10; + l.Top := 10; + l.Width := 100; + l.Height := 50; + l.Caption := 'Invalid name'; + b := TButton.Create(f); + b.parent := f; + b.Left:=10; + b.Top := 40; + b.Caption := 'OK'; + b.Default := True; + b.Cancel := True; + b.OnClick := @C2; + f.Visible := True; + form.Visible := False; + while f.Visible do + begin + Application.HandleMessage; + end; + Form.Visible := True; + end else begin + writeln('debug:'+Edit.Text); + Stop := True; + Form.Close; + end; +end; +Begin + Form := TForm.Create(self); + Form.Width := 400; + Form.Height := 300; + Form.BorderStyle := bsDialog; + Form.BorderIcons := []; + Form.OnCloseQuery := @MyOnCloseQuery; + Form.Caption := 'Name'; + Form.Position := poScreenCenter; + Labl := TLabel.Create(Form); + Labl.Top := 120; + Labl.Left := 160; + Labl.Caption := 'Please type in your name:'; + Labl.Parent := Form; + Edit := TEdit.Create(Form); + Edit.Font.Name := 'Tahoma'; + Edit.SetBounds(160,160,80,24); + Edit.Parent := Form; + Button := TButton.Create(Form); + Button.Left := 160; + Button.Top := 200; + Button.Width := 80; + Button.Height := 24; + Button.Caption := '&OK'; + Button.OnClick := @buttonclick; + Button.Parent := Form; + Button.Default := True; + Memo := TMemo.Create(Form); + Memo.Left := 10; + Memo.Width := 380; + Memo.Top := 10; + Memo.Height := 100; + Memo.Text := 'Welcome to Form Test.'#13#10#13#10'Type here your name (min 5 letters). You can''t exit this demo without it.'; + Memo.Color := 0; + Memo.Font.Color := $FFFFFF; + Memo.Parent := Form; + Memo.Readonly := True; + Form.Visible := true; + stop := false; + while Form.Visible do + begin + Application.HandleMessage; + end; + Button.Free; + Form.Free; +End. diff --git a/Samples/Import/importtest.rops b/Samples/Import/importtest.rops new file mode 100644 index 0000000..7564c50 --- /dev/null +++ b/Samples/Import/importtest.rops @@ -0,0 +1,16 @@ +Program IFSTest; +var + a,b :string; +Begin + a := 'test: '; + b := ImportTest('1', 2, 3, 4, a); + writeln(b); + writeln(a); +{ +Output should be: + +1 2 3 4 - OK! +1 2 3 4 - OK! - OK2! + +} +End. \ No newline at end of file diff --git a/Samples/Import/longfortest.rops b/Samples/Import/longfortest.rops new file mode 100644 index 0000000..94eece2 --- /dev/null +++ b/Samples/Import/longfortest.rops @@ -0,0 +1,10 @@ +Program IFSTest; +var + i, i2: Longint; +Begin + for i := 0 to 1000000 do + begin + i2 := i -1; + end; + writeln(inttostr(i2)); +End. \ No newline at end of file diff --git a/Samples/Import/rectest.rops b/Samples/Import/rectest.rops new file mode 100644 index 0000000..79efab7 --- /dev/null +++ b/Samples/Import/rectest.rops @@ -0,0 +1,11 @@ +Program IFSTest; +type + TMyRec = record a: Integer; b: string; end; +var + s: TMyRec; +Begin + s.a := 1234; + s.b := 'abc'; + writeln(s.b); + writeln(inttostr(s.a)); +End. \ No newline at end of file diff --git a/Samples/Import/stringtest.rops b/Samples/Import/stringtest.rops new file mode 100644 index 0000000..76b4372 --- /dev/null +++ b/Samples/Import/stringtest.rops @@ -0,0 +1,8 @@ +Program test; +var s: string; +begin +s:='123456789'; +s[1]:=s[2]; +writeln(s); +end. + diff --git a/Samples/Import/t1.rops b/Samples/Import/t1.rops new file mode 100644 index 0000000..07a4d54 --- /dev/null +++ b/Samples/Import/t1.rops @@ -0,0 +1,6 @@ +Program test; +var + i: Longint; +begin + writeln('Really simple test'); +end. diff --git a/Samples/Import/t10.rops b/Samples/Import/t10.rops new file mode 100644 index 0000000..403890a --- /dev/null +++ b/Samples/Import/t10.rops @@ -0,0 +1,12 @@ +Program test; +begin + writeln('1'); + try + writeln('2'); + raiseexception(erCustomError, 'TEST EXCEPTION'); + writeln('3'); + finally + writeln('4'); + end; + writeln('5'); +end. diff --git a/Samples/Import/t11.rops b/Samples/Import/t11.rops new file mode 100644 index 0000000..fd3b929 --- /dev/null +++ b/Samples/Import/t11.rops @@ -0,0 +1,57 @@ +Program IFSTest; +var + F, Form: TForm; + i: Longint; + Labl: TLabel; + Button: TButton; + Edit: TEdit; + Memo: TMemo; + Stop: Boolean; + +Begin + Form := TForm.Create(self); + Form.Width := 400; + Form.Height := 300; + Form.BorderStyle := bsDialog; + Form.BorderIcons := []; + Form.Caption := 'Name'; + Form.Position := poScreenCenter; + Labl := TLabel.Create(Form); + Labl.Top := 120; + Labl.Left := 160; + Labl.Caption := 'Please type in your name:'; + Labl.Parent := Form; + Edit := TEdit.Create(Form); + Edit.Font.Name := 'Tahoma'; + Edit.SetBounds(160,160,80,24); + Edit.Parent := Form; + Button := TButton.Create(Form); + Button.Left := 160; + Button.Top := 200; + Button.Width := 80; + Button.Height := 24; + Button.Caption := '&OK'; + Button.Parent := Form; + Button.Default := True; + Memo := TMemo.Create(Form); + Memo.Left := 10; + Memo.Width := 380; + Memo.Top := 10; + Memo.Height := 100; + Memo.Text := 'Welcome to Form Test.'#13#10#13#10'Plase wait till the loop is over.'; + Memo.Color := 0; + Memo.Font.Color := $FFFFFF; + Memo.Parent := Form; + Memo.Readonly := True; + Form.Visible := true; + Form.Refresh; + stop := false; + while Form.Visible do + begin + Application.ProcessMessages; + i := i + 1; + if i > 100000 then Break; + end; + Button.Free; + Form.Free; +End. diff --git a/Samples/Import/t2.rops b/Samples/Import/t2.rops new file mode 100644 index 0000000..7904b33 --- /dev/null +++ b/Samples/Import/t2.rops @@ -0,0 +1,6 @@ +Program test; +var + i: Longint; +begin + for i := 0 to 100000 do ; +end. diff --git a/Samples/Import/t3.rops b/Samples/Import/t3.rops new file mode 100644 index 0000000..2819850 --- /dev/null +++ b/Samples/Import/t3.rops @@ -0,0 +1,4 @@ +Program test; +begin + writeln('test'); +end. diff --git a/Samples/Import/t4.rops b/Samples/Import/t4.rops new file mode 100644 index 0000000..f622aa5 --- /dev/null +++ b/Samples/Import/t4.rops @@ -0,0 +1,8 @@ +Program test; +var + s: string; +begin + s := 'test'; + s := s + 'TESTED'; + writeln(s); +end. diff --git a/Samples/Import/t5.rops b/Samples/Import/t5.rops new file mode 100644 index 0000000..a3ddab9 --- /dev/null +++ b/Samples/Import/t5.rops @@ -0,0 +1,9 @@ +Program test; +var + s: string; +begin + Writeln('Your name?'); + s := readln(s); + s := s + 'TESTED'; + writeln(s); +end. diff --git a/Samples/Import/t6.rops b/Samples/Import/t6.rops new file mode 100644 index 0000000..17617c1 --- /dev/null +++ b/Samples/Import/t6.rops @@ -0,0 +1,22 @@ +Program IFSTest; +type + TArrayOfByte = array of byte; + +procedure Test(x: TARrayOfByte); +var + i: Integer; +begin + for i := 0 to Getarraylength(X) -1 do + begin + writeln(inttostr(x[i])); + end; +end; +var + temp: TArrayOfByte; + +Begin + setarraylength(temp, 2); + temp[0] := 1; + temp[1] :=23; + test(temp); +End. diff --git a/Samples/Import/t7.rops b/Samples/Import/t7.rops new file mode 100644 index 0000000..5f54b91 --- /dev/null +++ b/Samples/Import/t7.rops @@ -0,0 +1,7 @@ +Program test; +var + r: TObject; +begin + r := TObject.Create; + r.Free; +end. diff --git a/Samples/Import/t8.rops b/Samples/Import/t8.rops new file mode 100644 index 0000000..2d6e691 --- /dev/null +++ b/Samples/Import/t8.rops @@ -0,0 +1,16 @@ +Program test; +var + r: TObject; +begin + if r = nil then Writeln('(r = nil) = true') else Writeln('(r = nil) = false'); + if r <> nil then Writeln('(r <> nil) = true') else Writeln('(r <> nil) = false'); + r := TObject.Create; + if r = nil then Writeln('(r = nil) = true') else Writeln('(r = nil) = false'); + if r <> nil then Writeln('(r <> nil) = true') else Writeln('(r <> nil) = false'); + r.Free; + if r = nil then Writeln('(r = nil) = true') else Writeln('(r = nil) = false'); + if r <> nil then Writeln('(r <> nil) = true') else Writeln('(r <> nil) = false'); + r := nil; + if r = nil then Writeln('(r = nil) = true') else Writeln('(r = nil) = false'); + if r <> nil then Writeln('(r <> nil) = true') else Writeln('(r <> nil) = false'); +end. diff --git a/Samples/Import/t9.rops b/Samples/Import/t9.rops new file mode 100644 index 0000000..c4e54ce --- /dev/null +++ b/Samples/Import/t9.rops @@ -0,0 +1,16 @@ +Program test; +var + t: TObject; + i: IUnknown; +begin + t := TObject.Create; + try + try + i := t; + except + writeln('Expected Exception: Interface not supported'); + end; + finally + t.Free; + end; +end. diff --git a/Samples/Import/testdefine.rops b/Samples/Import/testdefine.rops new file mode 100644 index 0000000..718bd69 --- /dev/null +++ b/Samples/Import/testdefine.rops @@ -0,0 +1,10 @@ +{.$DEFINE ERROR} + +// Remove the . before the define to +// cause an error in textinclude.rops + +{$I testinclude.rops} +begin + testproc(); + writeln('test'); +end. diff --git a/Samples/Import/testinclude.rops b/Samples/Import/testinclude.rops new file mode 100644 index 0000000..c9ae677 --- /dev/null +++ b/Samples/Import/testinclude.rops @@ -0,0 +1,12 @@ +{ + This file is part of a DEFINE / INCLUDE test. Use + testdefine.rops file to execute this file. +} + +procedure TestProc; +begin + Writeln('Test Proc Called'); + {$IFDEF ERROR} + Error! + {$ENDIF} +end; diff --git a/Samples/Import/vartype.rops b/Samples/Import/vartype.rops new file mode 100644 index 0000000..89f21a9 --- /dev/null +++ b/Samples/Import/vartype.rops @@ -0,0 +1,14 @@ +Program IFSTest; +var + e: variant; +Begin + e := null; + case VarType(e) of +varempty :writeln('unassigned'); +varNull: Writeln('null'); +varstring: Writeln('String'); + varInteger : writeln('VarInteger'); +varSingle: Writeln('Single'); +varDouble: Writeln('Double'); + end; +End. \ No newline at end of file diff --git a/Samples/Import/wordole.rops b/Samples/Import/wordole.rops new file mode 100644 index 0000000..9c8612d --- /dev/null +++ b/Samples/Import/wordole.rops @@ -0,0 +1,7 @@ +Program test; +var + WordDoc: Variant; +begin + WordDoc := CreateOleObject('Word.Application'); + WordDoc.Visible := True; +end. diff --git a/Samples/Kylix/Import.dpr b/Samples/Kylix/Import.dpr new file mode 100644 index 0000000..83a86d3 --- /dev/null +++ b/Samples/Kylix/Import.dpr @@ -0,0 +1,16 @@ +program Import; + +uses + QForms, + fMain in 'fMain.pas' {MainForm}, + fDwin in 'fDwin.pas' {dwin}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TMainForm, MainForm); + Application.CreateForm(Tdwin, dwin); + Application.Run; +end. + diff --git a/Samples/Kylix/arraytest.rops b/Samples/Kylix/arraytest.rops new file mode 100644 index 0000000..314bb89 --- /dev/null +++ b/Samples/Kylix/arraytest.rops @@ -0,0 +1,22 @@ +Program IFSTest; +type + TArrayOfByte = array of byte; + +procedure Test(x: TARrayOfByte); +var + i: Integer; +begin + for i := 0 to Getarraylength(X) -1 do + begin + writeln(inttostr(x[i])); + end; +end; +var + temp: TArrayOfByte; + +Begin + setarraylength(temp, 2); + temp[0] := 1; + temp[1] :=23; + test(temp); +End. \ No newline at end of file diff --git a/Samples/Kylix/booleantest.rops b/Samples/Kylix/booleantest.rops new file mode 100644 index 0000000..f09d50b --- /dev/null +++ b/Samples/Kylix/booleantest.rops @@ -0,0 +1,15 @@ +Program IFSTest; +var + x1, x2: integer; + b: boolean; +Begin + x1 := 2; + x2 := 2; + b := x1 = x2; + if b then begin writeln('true'); end else begin writeln('false');end; + x1 := 2; + x2 := 4; + b := x1 = x2; + if b then begin writeln('true'); end else begin writeln('false');end; + writeln('done'); +End. \ No newline at end of file diff --git a/Samples/Kylix/bytearray.rops b/Samples/Kylix/bytearray.rops new file mode 100644 index 0000000..d4cd198 --- /dev/null +++ b/Samples/Kylix/bytearray.rops @@ -0,0 +1,9 @@ +Program IFSTest; +type + TByteArray = array of byte; +var + x: TByteARray; +Begin + x[0] := 1; + // will cause an runtime error (Out Of Record Fields Range) +End. \ No newline at end of file diff --git a/Samples/Kylix/casetest.rops b/Samples/Kylix/casetest.rops new file mode 100644 index 0000000..b45c335 --- /dev/null +++ b/Samples/Kylix/casetest.rops @@ -0,0 +1,12 @@ +Program IFSTest; +var + b: Byte; +Begin + for b := 0 to 2 do begin + case b of + 0: writeln('0'); + 1: writeln('1'); + else writeln('>1'); + end; + end; +End. \ No newline at end of file diff --git a/Samples/Kylix/exittest.rops b/Samples/Kylix/exittest.rops new file mode 100644 index 0000000..682b825 --- /dev/null +++ b/Samples/Kylix/exittest.rops @@ -0,0 +1,14 @@ +Program IFSTest; +procedure test; +begin + writeln('1'); + exit; + writeln('2'); +end; +Begin + test; + writeln('3'); + exit; + writeln('4'); + +End. \ No newline at end of file diff --git a/Samples/Kylix/fDwin.dfm b/Samples/Kylix/fDwin.dfm new file mode 100644 index 0000000000000000000000000000000000000000..c34c1b0ef04fd43f4cafab99622dc648bcf4ba28 GIT binary patch literal 666 zcmZWn&2Hi_5O$mJ6R1tJoa>zZT$YX=+I2HI!nOYNI&ofwtX z?#0&3$lu@iPe!Wo;(1E$u0AOtRq=QiRn1Yzi|%-Zl?{KBuu?nvD_V%gZo&bLpFpfP zHarG5Z=h{iYlS%CdN}8D4fMAEP+M_;TuJLDESkVp-LstUtWYw(9t*>bf$b7uun@9Q z$0%2*G)rn6?X6WZdvs5Sz8Tk8!Mp8sEl*5)X;)487UKS-9F$y|K?z!{{L4bvdc(5S z?u~1~9glC9_5-0uJk+A|KuK0`4brxNNm3{yT9NE>r<^SSnY$V2ej(lgO#%8@)*JdW zYbBk;T&Hc(WkVwpRjpfZ`J#=F`t-3h&0an5B8n0~K5%263$V_5M$+O#)O Q4aYecSJ2?h<6IE(1t4n6rvLx| literal 0 HcmV?d00001 diff --git a/Samples/Kylix/fDwin.pas b/Samples/Kylix/fDwin.pas new file mode 100644 index 0000000..12138dc --- /dev/null +++ b/Samples/Kylix/fDwin.pas @@ -0,0 +1,27 @@ +unit fDwin; + +interface + +uses + SysUtils, Classes, QGraphics, QControls, QForms, QDialogs, QStdCtrls, + QExtCtrls; + +type + Tdwin = class(TForm) + Memo1: TMemo; + Panel1: TPanel; + Button1: TButton; + private + { Private declarations } + public + { Public declarations } + end; + +var + dwin: Tdwin; + +implementation + +{$R *.dfm} + +end. diff --git a/Samples/Kylix/fMain.dfm b/Samples/Kylix/fMain.dfm new file mode 100644 index 0000000000000000000000000000000000000000..91fa017964a45ae70c1302967a6d22043ffa1bda GIT binary patch literal 1775 zcmcIkO>Pr06n17Z(=;v^Q1J+hrPYS zI0_Og4#5GCI0V?9B$JS$uGqc*@4fHY?{^5YUi-Y?9bELl@zD<-fNa=3u4O$$SeJ`= zuokLs@I<*m#m#u`{sP`RGFCJ9nd864WI9vsP36%g7AhSHPU$HU%?re)*!=?P?U5qa zIN?lb7xa2~&Rb!7p?DD+cnPOmz+gmA7fNv!c6Dg8F#02!;iZbKsX%g~n$`Mfj{SNs zZKR0FMv4WQ6q!S!Ml%>r@=GKLx}vx+r|OpC2vmEREnv-zWu#U(L;^EqN(RA@OQHy8 z@Gv*sVayWk!{T7T63QihyTIZW9vWgwJ1vw)l#-kgSs&>KEicQ zt9^V^x~s8Pp;Bp;f5F4KniKN7HeMd^HCo6wL2Q=cXkPYP1yDO~81W{(*#~DGCPoq+7g=ctz7F2bX z%J;}5mnVUFtM=Hz=S^$zwMCx`f2~J_e$K{t=>Ryek6cC%_+*IGthbQ58j(utrqo71 zq8lnn literal 0 HcmV?d00001 diff --git a/Samples/Kylix/fMain.pas b/Samples/Kylix/fMain.pas new file mode 100644 index 0000000..b8ccae2 --- /dev/null +++ b/Samples/Kylix/fMain.pas @@ -0,0 +1,330 @@ +unit fMain; + +interface + +uses + Classes, QGraphics, QControls, QForms, QDialogs, + uPSCompiler, uPSRuntime, uPSUtils, QMenus, QTypes, QStdCtrls, QExtCtrls; + +type + TMainForm = class(TForm) + Memo1: TMemo; + Memo2: TMemo; + Splitter1: TSplitter; + MainMenu1: TMainMenu; + Toosl1: TMenuItem; + Compile1: TMenuItem; + File1: TMenuItem; + Exit1: TMenuItem; + N1: TMenuItem; + SaveAs1: TMenuItem; + Save1: TMenuItem; + Open1: TMenuItem; + New1: TMenuItem; + OpenDialog1: TOpenDialog; + SaveDialog1: TSaveDialog; + N2: TMenuItem; + Stop1: TMenuItem; + N3: TMenuItem; + CompileandDisassemble1: TMenuItem; + procedure Compile1Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure Exit1Click(Sender: TObject); + procedure New1Click(Sender: TObject); + procedure Open1Click(Sender: TObject); + procedure Save1Click(Sender: TObject); + procedure SaveAs1Click(Sender: TObject); + procedure Memo1Change(Sender: TObject); + procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); + procedure Stop1Click(Sender: TObject); + procedure CompileandDisassemble1Click(Sender: TObject); + private + fn: string; + changed: Boolean; + function SaveTest: Boolean; + public + { Public declarations } + end; + +var + MainForm: TMainForm; + +implementation +uses + fDwin, uPSDisassembly, uPSC_dll, uPSR_dll; +{$R *.dfm} + +function MyOnUses(Sender: TIFPSPascalCompiler; const Name: string): Boolean; +begin + if Name = 'SYSTEM' then + begin + TIFPSPascalCompiler(Sender).AddFunction('procedure Writeln(s: string);'); + TIFPSPascalCompiler(Sender).AddFunction('function Readln(question: string): string;'); + Sender.AddConstantN('NaN', 'extended').SetExtended(0.0 / 0.0); + Sender.AddConstantN('Infinity', 'extended').SetExtended(1.0 / 0.0); + Sender.AddConstantN('NegInfinity', 'extended').SetExtended(1.0 / 0.0); + Sender.AddDelphiFunction('function ImportTest(S1: string; s2: Longint; s3: Byte; s4: word; var s5: string): string;'); + Result := True; + end + else + begin + TIFPSPascalCompiler(Sender).MakeError('', ecUnknownIdentifier, ''); + Result := False; + end; +end; + +function MyWriteln(Caller: TIFPSExec; p: TPSExternalProcRec; Global, Stack: TIFPSStack): Boolean; +begin + MainForm.Memo2.Lines.Add(Stack.GetString(-1)); + Result := True; +end; + +function MyReadln(Caller: TIFPSExec; p: TPSExternalProcRec; Global, Stack: TIFPSStack): Boolean; +begin + Stack.SetString(-1,InputBox(MainForm.Caption, Stack.GetString(-2), '')); + Result := True; +end; + +function ImportTest(S1: string; s2: Longint; s3: Byte; s4: word; var s5: string): string; +begin + Result := s1 + ' ' + IntToStr(s2) + ' ' + IntToStr(s3) + ' ' + IntToStr(s4) + ' - OK!'; + S5 := s5 + ' '+ result + ' - OK2!'; +end; + +var + I: Integer; + +procedure RunLine(Sender: TIFPSExec); +begin + i := (i + 1) mod 15; + if i = 0 then Application.ProcessMessages; +end; + +function MyExportCheck(Sender: TIFPSPascalCompiler; Proc: TIFPSInternalProcedure; const ProcDecl: string): Boolean; +begin + Result := TRue; +end; + + +procedure TMainForm.Compile1Click(Sender: TObject); +var + x1: TIFPSPascalCompiler; + x2: TIFPSExec; + s: string; + + procedure Outputtxt(const s: string); + begin + Memo2.Lines.Add(s); + end; + + procedure OutputMsgs; + var + l: Longint; + b: Boolean; + begin + b := False; + for l := 0 to x1.MsgCount - 1 do + begin + Outputtxt(x1.Msg[l].MessageToString); + if (not b) and (x1.Msg[l] is TPSPascalCompilerError) then + begin + b := True; + Memo1.SelStart := X1.Msg[l].Pos; + end; + end; + end; +begin + if tag <> 0 then exit; + Memo2.Clear; + x1 := TIFPSPascalCompiler.Create; + x1.OnExportCheck := MyExportCheck; + x1.OnUses := MyOnUses; + x1.OnExternalProc := DllExternalProc; + if x1.Compile(Memo1.Text) then + begin + Outputtxt('Succesfully compiled'); + OutputMsgs; + if not x1.GetOutput(s) then + begin + x1.Free; + Outputtxt('[Error] : Could not get data'); + exit; + end; + x1.Free; + x2 := TIFPSExec.Create; + RegisterDLLRuntime(x2); + tag := longint(x2); + if sender <> nil then + x2.OnRunLine := RunLine; + x2.RegisterFunctionName('WRITELN', MyWriteln, nil, nil); + x2.RegisterFunctionName('READLN', MyReadln, nil, nil); + x2.RegisterDelphiFunction(@importtest, 'IMPORTTEST', cdRegister); + if not x2.LoadData(s) then begin + Outputtxt('[Error] : Could not load data'); + x2.Free; + exit; + end; + x2.RunScript; + if x2.ExceptionCode <> ENoError then + Outputtxt('[Runtime Error] : ' + TIFErrorToString(x2.ExceptionCode, x2.ExceptionString) + + ' in ' + IntToStr(x2.ExceptionProcNo) + ' at ' + IntToSTr(x2.ExceptionPos)) + else + OutputTxt('Successfully executed'); + + tag := 0; + x2.Free; + end + else + begin + Outputtxt('Failed when compiling'); + OutputMsgs; + x1.Free; + end; +end; + +procedure TMainForm.FormCreate(Sender: TObject); +begin + Caption := 'RemObjects Pascal Script'; + fn := ''; + changed := False; + Memo1.Lines.Text := 'Program ROTEST;'#13#10'Begin'#13#10'End.'; +end; + + +procedure TMainForm.Exit1Click(Sender: TObject); +begin + Close; +end; + +procedure TMainForm.New1Click(Sender: TObject); +begin + if not SaveTest then + exit; + Memo1.Lines.Text := 'Program ROTEST;'#13#10'Begin'#13#10'End.'; + Memo2.Lines.Clear; + fn := ''; +end; + +function TMainForm.SaveTest: Boolean; +begin + if changed then + begin + case MessageDlg('File is not saved, save now?', mtWarning, mbYesNoCancel, 0) of + mrYes: + begin + Save1Click(nil); + Result := not changed; + end; + mrNo: Result := True; + else + Result := False; + end; + end + else + Result := True; +end; + +procedure TMainForm.Open1Click(Sender: TObject); +begin + if not SaveTest then + exit; + if OpenDialog1.Execute then + begin + Memo1.Lines.LoadFromFile(OpenDialog1.FileName); + changed := False; + Memo2.Lines.Clear; + fn := OpenDialog1.FileName; + end; +end; + +procedure TMainForm.Save1Click(Sender: TObject); +begin + if fn = '' then + begin + Saveas1Click(nil); + end + else + begin + Memo1.Lines.SaveToFile(fn); + changed := False; + end; +end; + +procedure TMainForm.SaveAs1Click(Sender: TObject); +begin + SaveDialog1.FileName := ''; + if SaveDialog1.Execute then + begin + fn := SaveDialog1.FileName; + Memo1.Lines.SaveToFile(fn); + changed := False; + end; +end; + +procedure TMainForm.Memo1Change(Sender: TObject); +begin + changed := True; +end; + +procedure TMainForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean); +begin + CanClose := SaveTest; +end; + +procedure TMainForm.Stop1Click(Sender: TObject); +begin + if tag <> 0 then + TIFPSExec(tag).Stop; +end; + +procedure TMainForm.CompileandDisassemble1Click(Sender: TObject); +var + x1: TIFPSPascalCompiler; + s, s2: string; + + procedure OutputMsgs; + var + l: Longint; + b: Boolean; + begin + b := False; + for l := 0 to x1.MsgCount - 1 do + begin + Memo2.Lines.Add(x1.Msg[l].MessageToString); + if (not b) and (x1.Msg[l] is TPSPascalCompilerError) then + begin + b := True; + Memo1.SelStart := X1.Msg[l].Pos; + end; + end; + end; +begin + if tag <> 0 then exit; + Memo2.Clear; + x1 := TIFPSPascalCompiler.Create; + x1.OnExternalProc := DllExternalProc; + x1.OnUses := MyOnUses; + if x1.Compile(Memo1.Text) then + begin + Memo2.Lines.Add('Succesfully compiled'); + OutputMsgs; + if not x1.GetOutput(s) then + begin + x1.Free; + Memo2.Lines.Add('[Error] : Could not get data'); + exit; + end; + x1.Free; + IFPS3DataToText(s, s2); + dwin.Memo1.Text := s2; + dwin.showmodal; + end + else + begin + Memo2.Lines.Add('Failed when compiling'); + OutputMsgs; + x1.Free; + end; +end; + +end. diff --git a/Samples/Kylix/fortest.rops b/Samples/Kylix/fortest.rops new file mode 100644 index 0000000..5695ff5 --- /dev/null +++ b/Samples/Kylix/fortest.rops @@ -0,0 +1,9 @@ +Program IFSTest; +var + i: Longint; +Begin + for i := 0 to 9 do + begin + writeln('hello'+inttostr(i)); + end; +End. diff --git a/Samples/Kylix/if.rops b/Samples/Kylix/if.rops new file mode 100644 index 0000000..0db351c --- /dev/null +++ b/Samples/Kylix/if.rops @@ -0,0 +1,9 @@ +Program IFSTest; +var + a: boolean; +Begin + a := true; + if a then begin ;end else + if a then begin ;end else; + writeln('5'); +End. \ No newline at end of file diff --git a/Samples/Kylix/importtest.rops b/Samples/Kylix/importtest.rops new file mode 100644 index 0000000..7564c50 --- /dev/null +++ b/Samples/Kylix/importtest.rops @@ -0,0 +1,16 @@ +Program IFSTest; +var + a,b :string; +Begin + a := 'test: '; + b := ImportTest('1', 2, 3, 4, a); + writeln(b); + writeln(a); +{ +Output should be: + +1 2 3 4 - OK! +1 2 3 4 - OK! - OK2! + +} +End. \ No newline at end of file diff --git a/Samples/Kylix/longfortest.rops b/Samples/Kylix/longfortest.rops new file mode 100644 index 0000000..94eece2 --- /dev/null +++ b/Samples/Kylix/longfortest.rops @@ -0,0 +1,10 @@ +Program IFSTest; +var + i, i2: Longint; +Begin + for i := 0 to 1000000 do + begin + i2 := i -1; + end; + writeln(inttostr(i2)); +End. \ No newline at end of file diff --git a/Samples/Kylix/rectest.rops b/Samples/Kylix/rectest.rops new file mode 100644 index 0000000..79efab7 --- /dev/null +++ b/Samples/Kylix/rectest.rops @@ -0,0 +1,11 @@ +Program IFSTest; +type + TMyRec = record a: Integer; b: string; end; +var + s: TMyRec; +Begin + s.a := 1234; + s.b := 'abc'; + writeln(s.b); + writeln(inttostr(s.a)); +End. \ No newline at end of file diff --git a/Samples/Kylix/vartype.rops b/Samples/Kylix/vartype.rops new file mode 100644 index 0000000..ad4e635 --- /dev/null +++ b/Samples/Kylix/vartype.rops @@ -0,0 +1,14 @@ +Program IFSTest; +var + e: variant; +Begin + e := null; + case VarType(e) of +varempty :writeln('unassigned'); +varNull: Writeln('null'); +varstring: Writeln('String'); + varInteger : writeln('VarInteger'); +varSingle: Writeln('Single'); +varDouble: Writeln('Double'); + end; +End. \ No newline at end of file diff --git a/Samples/RO-TestApp/MegaDemo.RODL b/Samples/RO-TestApp/MegaDemo.RODL new file mode 100644 index 0000000..1bcf01a --- /dev/null +++ b/Samples/RO-TestApp/MegaDemo.RODL @@ -0,0 +1,109 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/Samples/RO-TestApp/MegaDemo.ROPS b/Samples/RO-TestApp/MegaDemo.ROPS new file mode 100644 index 0000000..4a4eb01 --- /dev/null +++ b/Samples/RO-TestApp/MegaDemo.ROPS @@ -0,0 +1,92 @@ +var + Message: TROBINMessage; + Channel: TRoIndyHttpChannel; + Service: NewService; + s: string; + i1, i2, i3: Integer; + +procedure TestPerson; +var + inp, outp: TPerson; +begin + inp.FirstName := 'First_Name'; + inp.FirstName := 'Last_Name'; + inp.Age := 100; + inp.Sex := sxFemale; + Writeln('Calling TestPerson:'); + Service.EchoPerson(inp, outp); + Writeln('Test Result: FirstName: '+outp.FirstName+ + ' LastName: '+outp.LastName + ' Age: '+inttostr(outp.Age)); + if inp.Sex = sxMale then + Writeln('Male') + else + Writeln('Female'); +end; + +procedure TestStringArray; +var + Str, Str2: TStringArray; + i: Longint; + s: string; +begin + Str := ['first', 'second', 'third', 'fourth', 'fifth']; + Writeln('Passing [''first'', ''second'', ''third'', ''fourth'', ''fifth''] to TestStringArray:'); + str2 := Service.TestStringArray(str); + for i := 0 to GetArrayLength(str2) -1 do + S := s + str2[i]+' '; + Writeln('Result: '+s); +end; + +procedure TestIntegerArray; +var + Str, Str2: TIntegerArray; + i: Longint; + s: string; +begin + Str := [12, 34, 45, 67, 89]; + Writeln('Passing [12, 34, 45, 67, 89] to TestIntegerArray:'); + str2 := Service.TestIntegerArray(str); + for i := 0 to GetArrayLength(str2) -1 do + S := s + inttostr(str2[i])+' '; + Writeln('Result: '+s); +end; + +begin + Message := TROBINMessage.Create(nil); + Message.UseCompression := False; + Channel := TRoIndyHTTPChannel.Create(nil); + Channel.TargetURL := 'http://localhost:8099/BIN'; + Service := NewService.Create(Message, Channel); + try + TestPerson; + Writeln('MegaDemo Test'); + Writeln('First number:'); + s := readln('First Number'); + i1 := StrToInt(s); + Writeln('Second number:'); + s := readln('Second Number'); + i2 := StrToInt(s); + i3 := Service.Sum(i1,i2); + writeln(inttostr(i1)+'+'+inttostr(i2)+' -> Server, Result:'+inttostr(i3)); + + Writeln('Server Time:'+DateToStr(Service.GetServerTime)); + + TestStringArray; + TestIntegerArray; + + Writeln('Custom Object As String: '+Service.CustomObjectAsString); + + try + Writeln('Trying to raise an exception:'); + Service.RaiseError; + Writeln('Exception Failed'); + except + Writeln('Exception: '+ExceptionToString(ExceptionType, ExceptionParam)); + end; + finally + Service := nil; + channel.Free; + message.Free; + end; +end. + diff --git a/Samples/RO-TestApp/TestApplication.dpr b/Samples/RO-TestApp/TestApplication.dpr new file mode 100644 index 0000000..3108f9c --- /dev/null +++ b/Samples/RO-TestApp/TestApplication.dpr @@ -0,0 +1,14 @@ +program TestApplication; + +uses + Forms, + fMain in 'fMain.pas' {Form1}; + +{$R *.RES} + +begin + Application.Initialize; + Application.Title := 'Test Application'; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Samples/RO-TestApp/TestApplication.res b/Samples/RO-TestApp/TestApplication.res new file mode 100644 index 0000000000000000000000000000000000000000..67a114db32436a1e742e75cbf1a79dd35f519deb GIT binary patch literal 22748 zcmeHPcW@iU_us^c6AKl~mL*P+Wm!hHxdvVc@sF&u8yeS)EU^ox)$ajB+abcHigi+t+r_LI{z< zOG^8Nw>j6+p#HrGZN{kIN=r+|=|=T<(}LFlc#RPg@jtE-`=#x6F+h~ z`^19}J}4f2^ilD|6Hka|o_R*R@WKn?<(FR;ufF=Kc>VR)#j<6~#5?c2Bi?)OJ@L^; zABj&s`9ysF`RC%Ruf7uBeDjU?;fEi@&p-bxe);7W@y8#3h`;{&OZ@ZCKZZcoy^2G4+2u&=W=rjjKQBg%9lH^3+L|irnTk~>klLuYM=W__05o`ic z?$K5V%V%E`eSuIY5CAPOs7n-i5U>dv`NFZdWyLBg%FDyyfKQR2z2&9|tLA}MPZvD5w;0b z`#>yt-l|7PN1e912-=Bv9?qf7nsJ5OuYj?JF8* zqCI&cK}DdVu8!@g-54QkYil?R#Vhuy_A_SA#0V`UXljgy!gV0XB)Dd9mBaNb_2yzI z7I<5+$tH>b7{C&=sctd|l0KWDT(5_K-5vy+C<1bX5zxM7G6<4bZycdquZL{=SgTFo zNGTl3Alj%)p*0EAk|PGRN1zhJyH*giBpN9tUf)0n1jSUTxG1H2I?YZJ&5GeY`NU^3lY;QTB(Y^@;HMV~HVtP#nV8<9J#bR}H z=AeDWWJnb(g~KV%1KKMJwC9?R$Ekb?kpw{kky9(=T89y)PcKJ%%md`4II}+qeV?W{{wD zrn3qleyRl3)L#9`5Sg;=gMdO=@y$qpd1!_1QCpQRL98ULtBbSykkdXzg4CQWK~`HS zR@I)m5zyVk!;zpy5wy;6luv0ZR~&RnO|>uXbdOt{1WCnGE&&E;Y)HX6U>;UB7n2o1 zd?qOrfrEi7t|39Gh8*MR5ZMG)T`Q$T&^88WYh8t!h}`B-3pD~}nyQf{XsL@~-az1P zj$ssN=t?5fG<_2cFuf_0fNH3THhjxU6g3t=Q@weuoM{lOY?J#=%`}Fvn``AO6h%P! zpnZA(YHLkymqR`^ByEn!P%Jg%=h1#4q0`Gl76!G4Lo_Xg0 zokIK{?`=Y;45CU1kbzJLkO=|BRQCx&Eazu^hk5VgXMIQhr9R`{#qZsBe5Jl$Q+K2P zKJ>}))E)dR=VyHfznXuIN8tl5jaS`)U&*1OFvQPj*v7l;8e_{_ z;u2yhY)T44OUXQTEZzy>&SO*fZgae{d2BYzRbMI`cqb-Im>^&lR31w$g@&j+HknKc z7~z~e7Ot#d9=q$VyNW&c+*2%ExGYLWK&Pzh5F@Us{vP-Zi(s2}zv7>PzBk#Nw@ zKG0<4754l6;mTxXJdPG+b_=6HI2a68rmK@^V6j12Fj!K&^7lA?k67`Q4T63!v$8=r z$PWBv)lLs89U}^x$p}myen*3JnnU;%N_2n*yvo9nYSkcU4?An~ICg~HX5&Qi2JM20CL3d3I*g)iQkjcr?s>+PHm_U#xt2T z(jhcZF#VVd{GOTaG$@PIW-^tKq_0HDAq)8GrfpzPnHEi;`4 z$zVf$Z8c==^VyQbY*t74yWOBRoN1`94zfX|YJlHst!U${S+&(Or%h|A4`-$}q}A`$ zssRKcqE;<_k0K15Rv)gN+K{0r{Yuo);^LsNqRH8yFEkuAct`q{H*^LNT&T1#W&)cX1~Mo5Dk z7dk})1dFlKZSsim zW*mb+3YR;MDaCgwys~i&;;-z*_s(a`7-&lc6d)VFq|<3pTU#qIy@_~VbOc;%&+UJ`wMed4v(UK4M=`KF3jKKS4R z@x>Qki0{7pPJI9U_u|)Ie-(ctK3R9IlfXI&tbzn$6ZG&DU)hzP#L$P{_$0b4XdX#R@K+~ z{gH$f9G{7{OriPaD8Z;NCSujonx@p&W@@Ud5)t~b=#*(2qK<-5s(h>~)I`%w>WfK! z$I--MRq3=<8m!U?GgZ;ZB-^0>4__`v{@Dj?U9g9I<-7P>A75y@0yLyunh_!e0z02% z;4;(>x8S=2@EW69Vhqr%jjIY5a?cKw7rRle>4#&JD0N8KbqV(;QSFcj10?D}gYdJx zC?YL^?VrEidh6-Z*4kjJV4v9Q4Q;T&1|9G>1IU>rAV>rx5*Q>f$O0H7Fi2pK;9nwk z>p}cCzu;hN@JIN?P0!($B*w=4VJT{7{3{@{vdfEZ*C04v*ngs%6<3US0ZkbIKvHu zj*~dQB2oX77hG_`8pS|eq~FlC)rFxutJDSFKtDrmZEgL)AUVe-2I@ER1En(;U3AfE zW8fH^Tk4`-SJWr^jyxEKUDH^LOE%wpa|sO63xlakT&Jrt51h~H>S|9PN83dHk(YU5 zC}dkiF1Tm|A1OWUJR&h6pWX+rrmy8W1wAi`)S0j z-J1XT^XGSv*2HkrO*hFm-grae{Go~k7$cbTfb)zJ`#f^Vk|kOHz*qt28a*-4?iPyq z=v%yE4UNGo*3kT8536UFU3O9UiGgte&Pd8-%a&y^a2{wc86)7_rR?eHkq{kXUwN#Z`$g7@e(o6ZaFznR+pFq5d(2k4>Sg@MV#-LUz~S;Z`Z#xe2{vm!Fh~;v{g#QLx3^dM z2b{MkxTba7N?kYo19ge{j`ne0^FSLiTrNuf-LW^~k~Td1AWaO68E}3hi-Eq2c9Ahy zA-kkwZ}Q>xaoDrT`ZzNO(rcPA_;C3&*Ns`{n>1-sFa0lLD-#3l_iw-bmc>B*(LV0Z zJMYYkLC4;Vjof~kYue03-5999!{yUD)-W)r7!H1;-^4&W@aLa@=3vmamGh7fgO0t= zJ@?!pu?E*PVedSYUrY)lN)C7eT&*IaXryzkoz79Y9@Budl z>~ZE`;F@&D8fzPao(GS5Yfdc%u}23msQJ?Kz&H}mKILGbZKXW^t9hXOSs!x6e1qJ7 z(6Z+p`9%mA2HhAK%egVowto8Qr;>Jwww3+?`_+;X zSb}j8_PZrx4dy^x)3i&pt@ID{aoUD*%`oQUTG6^>VCXb?*YAO$gE63q0sHXs_uqf_ z#9;ck(Z)+||KN_7m;0S@O!2O3D*=zoJhn?tmV_-b+Ut{2Wc=>6p;~c#=dFT71 zk3PB?7zW)KnE(D)7^qV?tKk(d^}6}>`V0*1wAXG7|HVAeXD|oS`LyAu2e=R9#jn?Q zz|if5f$JgPnqHmtz<8B@U*|wBAICkEW-mSqeU}dd{WNW>+dr5w-)Qm&oWqff|8@T0 z!Z65vphA2W`VAPCc+G>3HRz|^vBpT|fwq@+lyQ3jKg~UqRpwpea@NC;HLWo)_U7Ev zrZe`YkNf)TuXA#sci(+i`3J^JwCiTAQpc@2e{kl3dnhWt(R{4V9T;erhS*jUgP8;A zTyz!vw5NYs9sV^fd|W&1(hxsw<_~5rI+}RN*?(AVebKz;yF0N)yI0I-=5g-2hR%UJ zV!m#~&u#g}TbtiIu{ZOFoE&HvT^eM~7C|RAof=s? zbcwafHMSwyf4Q=P~N+6eu#HA?p$-v1EE`W4m9VEuheJU*VNVJ zbmV#GnJWJ7zT=$La(>VAR=nfPmAXSya3&T4TKRmCdM>DKrF^o_PxU$S1EGFCsETsL zt5e;1kQe8;O3iazI9!X%eV#Uj?>5IPdyWe>Ok(@gZjsyt_QNN%<}`> z_vINa>`g4e9?=@JMR*Rf84p7Cm^A?KAi+bnCTa3u?4J+dY*PEG;zi9Tg#2X*a~JR+ z!9z|RVuUUZTQc6EpP-$hkKkw4AQ*cxXW@A+_jwNR zz;i((k_ExM``QY9m&$@9BeIz^} z_75TM8PqW}V^P-DFTM0qRkLADW~4kY{^q_j_iaYX1LBun<{vr+=Dr$h8>8WY_*pa2 zdzRE2HxFL=0NHiudX32gYpkeopk;tPkO9WE6Cd`95w_Imf|tQ&dR2fa2m4_p`K+N7OC zOjM=!Z;2hxH>$m7<`;|&nfI~o%6bg*TFRL^VDi8`#mh#S_CfPN8R#=QwAC21UB_iy zTX?oI%LAUfRP|^)i>dZCxIfFai8xU0vuYl=2dHh7DF-k6KpSQH3&bUz3l=O;`xKNt zbKF8aaE@4uW<83v8uCEf#9EV^2hNL|2hN}AFOVc|fe(t8*6CU~cEdgXy~wEB4Z# zkO!XIz%wcZc_3!yd8`3y9;lC|ztD4$&sLi@3NdRp=ZHM8Hiu_;6%W*Z_UoPt{JkqB zf6hH?7vzC!Q`<>X4qkSWW0^JzadRi@_xv7zPfP9HkO#hJ9)o9ha(H09kam)5L9Yv* zAJRU{l!KS8-h1!8O*=UN9i7iymOOB7@wc}W4?MF$on$?abp|bmhaY}e*-6?2?iG;- z=H}XGnR4*5)jUJ0_k$pZ9^^qG`Z&!4>o4SidO)7Y1J@DvL3x&f@3{skFYcwV4RdWT zTg`UJO;!9rouNKZPKK@SpbZ8OJ(>sBhwyBa;^DdHo>MW7wh!7)YFn-A4~6`usSjMc zrkzAgi-=tCxvw@|d!`(?2dsI(Gv{i5jcfeWQ%}vxfqsZ~mvoc~Z8c?L?g7#MbAN{M z8F^(KW!R{0j;$~7)~k77y%Nu^XL(?KOs|XK?1R=xy*9OtV&5+NP^HJ_9ax$vAI$^l z))WssYih0w#?|K7`aO8)SkpXQc;SW0UK#6xakZLvJ+65N58WmYoC{MQMl%;Ym*-j+ zjH`3xZjP48!v*1`mUXdph#n*^~)Sf_St{lCEqi_T__(o zFO#g`d$eagW=x;`%03&68b}D^@Y&!_RX$oiK^}oe&{Ak`KaW<7cSGwKEL)`T8l(P4 zO#?K;UC4#z!@l>>*E8P1-#SroFJj()k0epA)IyTr!S^YpzWaF#Js8aioTb7@!XT<*=FR#gJvJ_4?VOO^p%WpX+O+9 zsN3YL8fWl%o=NjTEYP=R`WX5l_Q5kZ)= z^2B_Eev@_u&q?R>!8MO(tR?%P|6(7c(=ugF#kqw|7-USwy(R8tXgS Zv`nezZ^t<;@d<6lJ1tX!wvZO^{{g&jPWJ!+ literal 0 HcmV?d00001 diff --git a/Samples/RO-TestApp/fMain.dfm b/Samples/RO-TestApp/fMain.dfm new file mode 100644 index 0000000000000000000000000000000000000000..8e7ea803e997097ddcdac7c9012c6a2d67131b46 GIT binary patch literal 1923 zcmb_dOK;mo5MEIhA9`4EQuI<3;Gr;z7Ez+~*h^$ef(=L}A<{8=O4j69++@imc2|g8 z^au3k^=}mDAwbb{yL^bG;IyX-g0S=YX7-zz)!%&-EZxm|ie5eu210?ie5nUZ#*=BU z_&r&{z3hI|=>{z8enP!l63MuGrRkSIwz2HWj^W@;5|--UZy<5+-a{yb?O_pOYWpE4 znY5qV0SIZ&vW$`t=gvKcQN|4`q!%(>;t+;Qmdc3}V=h1%59G`aR!n zX@>kw5!9PevP}&W(+eggOAzV>Ye-lx|7pW%kI=d*K^^T-0;&8zNc*!z+Q4BuPJr9j z@bQSb(Tb!XCcfk(-HMJr$~fC{oD_Zi@hMUty>|y&lImaC_KO$xWHPaF6xk07&<8>U)^0>horqeKjJC(hJphLl;7^5}N_OD;lC9^Oo`GmgCGkBI;F}_dgyn zrTx?pRnly307q_0AFOu1z7TJKOEr?T$=PY=v;xmBXV^R(#tus|LV>%*)QbVK+_cge z@%V=@h z(aV!DRLFBmO9|ELGtVyp-&Sd-jqO=&o2%`(k%Wqt^$P{q?0Qu#LgO0&9#>x$f>2X$ zmT$+WVm-8P5gIBs>q3sII`X_kYS#`++HC8QkD0ru9lnx~m?~pFjMMrhGS4ej+pB6x z+pAKUeyn=n?4-6gR9Dm+^}!e&+zYX&s7j|@HxQlYZOg#TAT7tGaT%WH+Ug~&;h(fz zA7!v|^Se>L(l5^Yta6>J`+_a=}&th+n>&brB(zoEK8d%6*aII|@GeSv^^(yzH;#D5}!V6j8_1 o|9Bln6@pZM5s9!Wv04_ZMEtEpR3rPWL9BP?b8B=Ir)Wq20A{*nLjV8( literal 0 HcmV?d00001 diff --git a/Samples/RO-TestApp/fMain.pas b/Samples/RO-TestApp/fMain.pas new file mode 100644 index 0000000..c1aad1e --- /dev/null +++ b/Samples/RO-TestApp/fMain.pas @@ -0,0 +1,174 @@ +unit fMain; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + ExtCtrls, StdCtrls, uPSComponent, uPSCompiler, Menus, uPSRuntime, + uROPSServerLink, uPSComponent_Default; + +type + TForm1 = class(TForm) + Memo1: TMemo; + Memo2: TMemo; + Splitter1: TSplitter; + PSScript: TPSScript; + PS3DllPlugin: TPSDllPlugin; + MainMenu1: TMainMenu; + Program1: TMenuItem; + Compile1: TMenuItem; + PS3RemObjectsPlugin1: TPSRemObjectsSdkPlugin; + OpenDialog1: TOpenDialog; + OpenDialog2: TOpenDialog; + N1: TMenuItem; + OpenScript1: TMenuItem; + OpenRODL1: TMenuItem; + PSImport_Classes1: TPSImport_Classes; + PSImport_DateUtils1: TPSImport_DateUtils; + procedure IFPS3ClassesPlugin1CompImport(Sender: TObject; + x: TPSPascalCompiler); + procedure IFPS3ClassesPlugin1ExecImport(Sender: TObject; Exec: TPSExec; + x: TPSRuntimeClassImporter); + procedure PSScriptCompile(Sender: TPSScript); + procedure Compile1Click(Sender: TObject); + procedure PSScriptExecute(Sender: TPSScript); + procedure OpenRODL1Click(Sender: TObject); + procedure OpenScript1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation +uses + uPSR_std, + uPSC_std, + uPSR_stdctrls, + uPSC_stdctrls, + uPSR_forms, + uPSC_forms, + uPSC_graphics, + uPSC_controls, + uPSC_classes, + uPSR_graphics, + uPSR_controls, + uPSR_classes; + +{$R *.DFM} + +procedure TForm1.IFPS3ClassesPlugin1CompImport(Sender: TObject; + x: TIFPSPascalcompiler); +begin + SIRegister_Std(x); + SIRegister_Classes(x, true); + SIRegister_Graphics(x, true); + SIRegister_Controls(x); + SIRegister_stdctrls(x); + SIRegister_Forms(x); +end; + +procedure TForm1.IFPS3ClassesPlugin1ExecImport(Sender: TObject; Exec: TIFPSExec; + x: TIFPSRuntimeClassImporter); +begin + RIRegister_Std(x); + RIRegister_Classes(x, True); + RIRegister_Graphics(x, True); + RIRegister_Controls(x); + RIRegister_stdctrls(x); + RIRegister_Forms(x); +end; + +function ImportTest(S1: string; s2: Longint; s3: Byte; s4: word; var s5: string): string; +begin + Result := s1 + ' ' + IntToStr(s2) + ' ' + IntToStr(s3) + ' ' + IntToStr(s4) + ' - OK!'; + S5 := s5 + ' '+ result + ' - OK2!'; +end; + +procedure MyWriteln(const s: string); +begin + Form1.Memo2.Lines.Add(s); +end; + +function MyReadln(const question: string): string; +begin + Result := InputBox(question, '', ''); +end; + +procedure TForm1.PSScriptCompile(Sender: TPSScript); +begin + Sender.AddFunction(@MyWriteln, 'procedure Writeln(s: string);'); + Sender.AddFunction(@MyReadln, 'function Readln(question: string): string;'); + Sender.AddFunction(@ImportTest, 'function ImportTest(S1: string; s2: Longint; s3: Byte; s4: word; var s5: string): string;'); + Sender.AddRegisteredVariable('Application', 'TApplication'); + Sender.AddRegisteredVariable('Self', 'TForm'); + Sender.AddRegisteredVariable('Memo1', 'TMemo'); + Sender.AddRegisteredVariable('Memo2', 'TMemo'); +end; + +procedure TForm1.Compile1Click(Sender: TObject); + procedure OutputMessages; + var + l: Longint; + b: Boolean; + begin + b := False; + + for l := 0 to PSScript.CompilerMessageCount - 1 do + begin + Memo2.Lines.Add('Compiler: '+ PSScript.CompilerErrorToStr(l)); + if (not b) and (PSScript.CompilerMessages[l] is TIFPSPascalCompilerError) then + begin + b := True; + Memo1.SelStart := PSScript.CompilerMessages[l].Pos; + end; + end; + end; +begin + Memo2.Lines.Clear; + PSScript.Script.Assign(Memo1.Lines); + Memo2.Lines.Add('Compiling'); + if PSScript.Compile then + begin + OutputMessages; + Memo2.Lines.Add('Compiled succesfully'); + if not PSScript.Execute then + begin + Memo1.SelStart := PSScript.ExecErrorPosition; + Memo2.Lines.Add(PSScript.ExecErrorToString +' at '+Inttostr(PSScript.ExecErrorProcNo)+'.'+Inttostr(PSScript.ExecErrorByteCodePosition)); + end else Memo2.Lines.Add('Succesfully executed'); + end else + begin + OutputMessages; + Memo2.Lines.Add('Compiling failed'); + end; +end; + +procedure TForm1.PSScriptExecute(Sender: TPSScript); +begin + PSScript.SetVarToInstance('APPLICATION', Application); + PSScript.SetVarToInstance('SELF', Self); + PSScript.SetVarToInstance('MEMO1', Memo1); + PSScript.SetVarToInstance('MEMO2', Memo2); +end; + +procedure TForm1.OpenRODL1Click(Sender: TObject); +begin + if OpenDialog2.Execute then + begin + PS3RemObjectsPlugin1.RODLLoadFromFile(OpenDialog2.FileName); + end; +end; + +procedure TForm1.OpenScript1Click(Sender: TObject); +begin + if OpenDialog1.Execute then + begin + Memo1.Lines.LoadFromFile(OpenDialog1.FileName); + end; +end; + +end. diff --git a/Samples/TestApp/TestApplication.dpr b/Samples/TestApp/TestApplication.dpr new file mode 100644 index 0000000..3108f9c --- /dev/null +++ b/Samples/TestApp/TestApplication.dpr @@ -0,0 +1,14 @@ +program TestApplication; + +uses + Forms, + fMain in 'fMain.pas' {Form1}; + +{$R *.RES} + +begin + Application.Initialize; + Application.Title := 'Test Application'; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Samples/TestApp/TestApplication.res b/Samples/TestApp/TestApplication.res new file mode 100644 index 0000000000000000000000000000000000000000..67a114db32436a1e742e75cbf1a79dd35f519deb GIT binary patch literal 22748 zcmeHPcW@iU_us^c6AKl~mL*P+Wm!hHxdvVc@sF&u8yeS)EU^ox)$ajB+abcHigi+t+r_LI{z< zOG^8Nw>j6+p#HrGZN{kIN=r+|=|=T<(}LFlc#RPg@jtE-`=#x6F+h~ z`^19}J}4f2^ilD|6Hka|o_R*R@WKn?<(FR;ufF=Kc>VR)#j<6~#5?c2Bi?)OJ@L^; zABj&s`9ysF`RC%Ruf7uBeDjU?;fEi@&p-bxe);7W@y8#3h`;{&OZ@ZCKZZcoy^2G4+2u&=W=rjjKQBg%9lH^3+L|irnTk~>klLuYM=W__05o`ic z?$K5V%V%E`eSuIY5CAPOs7n-i5U>dv`NFZdWyLBg%FDyyfKQR2z2&9|tLA}MPZvD5w;0b z`#>yt-l|7PN1e912-=Bv9?qf7nsJ5OuYj?JF8* zqCI&cK}DdVu8!@g-54QkYil?R#Vhuy_A_SA#0V`UXljgy!gV0XB)Dd9mBaNb_2yzI z7I<5+$tH>b7{C&=sctd|l0KWDT(5_K-5vy+C<1bX5zxM7G6<4bZycdquZL{=SgTFo zNGTl3Alj%)p*0EAk|PGRN1zhJyH*giBpN9tUf)0n1jSUTxG1H2I?YZJ&5GeY`NU^3lY;QTB(Y^@;HMV~HVtP#nV8<9J#bR}H z=AeDWWJnb(g~KV%1KKMJwC9?R$Ekb?kpw{kky9(=T89y)PcKJ%%md`4II}+qeV?W{{wD zrn3qleyRl3)L#9`5Sg;=gMdO=@y$qpd1!_1QCpQRL98ULtBbSykkdXzg4CQWK~`HS zR@I)m5zyVk!;zpy5wy;6luv0ZR~&RnO|>uXbdOt{1WCnGE&&E;Y)HX6U>;UB7n2o1 zd?qOrfrEi7t|39Gh8*MR5ZMG)T`Q$T&^88WYh8t!h}`B-3pD~}nyQf{XsL@~-az1P zj$ssN=t?5fG<_2cFuf_0fNH3THhjxU6g3t=Q@weuoM{lOY?J#=%`}Fvn``AO6h%P! zpnZA(YHLkymqR`^ByEn!P%Jg%=h1#4q0`Gl76!G4Lo_Xg0 zokIK{?`=Y;45CU1kbzJLkO=|BRQCx&Eazu^hk5VgXMIQhr9R`{#qZsBe5Jl$Q+K2P zKJ>}))E)dR=VyHfznXuIN8tl5jaS`)U&*1OFvQPj*v7l;8e_{_ z;u2yhY)T44OUXQTEZzy>&SO*fZgae{d2BYzRbMI`cqb-Im>^&lR31w$g@&j+HknKc z7~z~e7Ot#d9=q$VyNW&c+*2%ExGYLWK&Pzh5F@Us{vP-Zi(s2}zv7>PzBk#Nw@ zKG0<4754l6;mTxXJdPG+b_=6HI2a68rmK@^V6j12Fj!K&^7lA?k67`Q4T63!v$8=r z$PWBv)lLs89U}^x$p}myen*3JnnU;%N_2n*yvo9nYSkcU4?An~ICg~HX5&Qi2JM20CL3d3I*g)iQkjcr?s>+PHm_U#xt2T z(jhcZF#VVd{GOTaG$@PIW-^tKq_0HDAq)8GrfpzPnHEi;`4 z$zVf$Z8c==^VyQbY*t74yWOBRoN1`94zfX|YJlHst!U${S+&(Or%h|A4`-$}q}A`$ zssRKcqE;<_k0K15Rv)gN+K{0r{Yuo);^LsNqRH8yFEkuAct`q{H*^LNT&T1#W&)cX1~Mo5Dk z7dk})1dFlKZSsim zW*mb+3YR;MDaCgwys~i&;;-z*_s(a`7-&lc6d)VFq|<3pTU#qIy@_~VbOc;%&+UJ`wMed4v(UK4M=`KF3jKKS4R z@x>Qki0{7pPJI9U_u|)Ie-(ctK3R9IlfXI&tbzn$6ZG&DU)hzP#L$P{_$0b4XdX#R@K+~ z{gH$f9G{7{OriPaD8Z;NCSujonx@p&W@@Ud5)t~b=#*(2qK<-5s(h>~)I`%w>WfK! z$I--MRq3=<8m!U?GgZ;ZB-^0>4__`v{@Dj?U9g9I<-7P>A75y@0yLyunh_!e0z02% z;4;(>x8S=2@EW69Vhqr%jjIY5a?cKw7rRle>4#&JD0N8KbqV(;QSFcj10?D}gYdJx zC?YL^?VrEidh6-Z*4kjJV4v9Q4Q;T&1|9G>1IU>rAV>rx5*Q>f$O0H7Fi2pK;9nwk z>p}cCzu;hN@JIN?P0!($B*w=4VJT{7{3{@{vdfEZ*C04v*ngs%6<3US0ZkbIKvHu zj*~dQB2oX77hG_`8pS|eq~FlC)rFxutJDSFKtDrmZEgL)AUVe-2I@ER1En(;U3AfE zW8fH^Tk4`-SJWr^jyxEKUDH^LOE%wpa|sO63xlakT&Jrt51h~H>S|9PN83dHk(YU5 zC}dkiF1Tm|A1OWUJR&h6pWX+rrmy8W1wAi`)S0j z-J1XT^XGSv*2HkrO*hFm-grae{Go~k7$cbTfb)zJ`#f^Vk|kOHz*qt28a*-4?iPyq z=v%yE4UNGo*3kT8536UFU3O9UiGgte&Pd8-%a&y^a2{wc86)7_rR?eHkq{kXUwN#Z`$g7@e(o6ZaFznR+pFq5d(2k4>Sg@MV#-LUz~S;Z`Z#xe2{vm!Fh~;v{g#QLx3^dM z2b{MkxTba7N?kYo19ge{j`ne0^FSLiTrNuf-LW^~k~Td1AWaO68E}3hi-Eq2c9Ahy zA-kkwZ}Q>xaoDrT`ZzNO(rcPA_;C3&*Ns`{n>1-sFa0lLD-#3l_iw-bmc>B*(LV0Z zJMYYkLC4;Vjof~kYue03-5999!{yUD)-W)r7!H1;-^4&W@aLa@=3vmamGh7fgO0t= zJ@?!pu?E*PVedSYUrY)lN)C7eT&*IaXryzkoz79Y9@Budl z>~ZE`;F@&D8fzPao(GS5Yfdc%u}23msQJ?Kz&H}mKILGbZKXW^t9hXOSs!x6e1qJ7 z(6Z+p`9%mA2HhAK%egVowto8Qr;>Jwww3+?`_+;X zSb}j8_PZrx4dy^x)3i&pt@ID{aoUD*%`oQUTG6^>VCXb?*YAO$gE63q0sHXs_uqf_ z#9;ck(Z)+||KN_7m;0S@O!2O3D*=zoJhn?tmV_-b+Ut{2Wc=>6p;~c#=dFT71 zk3PB?7zW)KnE(D)7^qV?tKk(d^}6}>`V0*1wAXG7|HVAeXD|oS`LyAu2e=R9#jn?Q zz|if5f$JgPnqHmtz<8B@U*|wBAICkEW-mSqeU}dd{WNW>+dr5w-)Qm&oWqff|8@T0 z!Z65vphA2W`VAPCc+G>3HRz|^vBpT|fwq@+lyQ3jKg~UqRpwpea@NC;HLWo)_U7Ev zrZe`YkNf)TuXA#sci(+i`3J^JwCiTAQpc@2e{kl3dnhWt(R{4V9T;erhS*jUgP8;A zTyz!vw5NYs9sV^fd|W&1(hxsw<_~5rI+}RN*?(AVebKz;yF0N)yI0I-=5g-2hR%UJ zV!m#~&u#g}TbtiIu{ZOFoE&HvT^eM~7C|RAof=s? zbcwafHMSwyf4Q=P~N+6eu#HA?p$-v1EE`W4m9VEuheJU*VNVJ zbmV#GnJWJ7zT=$La(>VAR=nfPmAXSya3&T4TKRmCdM>DKrF^o_PxU$S1EGFCsETsL zt5e;1kQe8;O3iazI9!X%eV#Uj?>5IPdyWe>Ok(@gZjsyt_QNN%<}`> z_vINa>`g4e9?=@JMR*Rf84p7Cm^A?KAi+bnCTa3u?4J+dY*PEG;zi9Tg#2X*a~JR+ z!9z|RVuUUZTQc6EpP-$hkKkw4AQ*cxXW@A+_jwNR zz;i((k_ExM``QY9m&$@9BeIz^} z_75TM8PqW}V^P-DFTM0qRkLADW~4kY{^q_j_iaYX1LBun<{vr+=Dr$h8>8WY_*pa2 zdzRE2HxFL=0NHiudX32gYpkeopk;tPkO9WE6Cd`95w_Imf|tQ&dR2fa2m4_p`K+N7OC zOjM=!Z;2hxH>$m7<`;|&nfI~o%6bg*TFRL^VDi8`#mh#S_CfPN8R#=QwAC21UB_iy zTX?oI%LAUfRP|^)i>dZCxIfFai8xU0vuYl=2dHh7DF-k6KpSQH3&bUz3l=O;`xKNt zbKF8aaE@4uW<83v8uCEf#9EV^2hNL|2hN}AFOVc|fe(t8*6CU~cEdgXy~wEB4Z# zkO!XIz%wcZc_3!yd8`3y9;lC|ztD4$&sLi@3NdRp=ZHM8Hiu_;6%W*Z_UoPt{JkqB zf6hH?7vzC!Q`<>X4qkSWW0^JzadRi@_xv7zPfP9HkO#hJ9)o9ha(H09kam)5L9Yv* zAJRU{l!KS8-h1!8O*=UN9i7iymOOB7@wc}W4?MF$on$?abp|bmhaY}e*-6?2?iG;- z=H}XGnR4*5)jUJ0_k$pZ9^^qG`Z&!4>o4SidO)7Y1J@DvL3x&f@3{skFYcwV4RdWT zTg`UJO;!9rouNKZPKK@SpbZ8OJ(>sBhwyBa;^DdHo>MW7wh!7)YFn-A4~6`usSjMc zrkzAgi-=tCxvw@|d!`(?2dsI(Gv{i5jcfeWQ%}vxfqsZ~mvoc~Z8c?L?g7#MbAN{M z8F^(KW!R{0j;$~7)~k77y%Nu^XL(?KOs|XK?1R=xy*9OtV&5+NP^HJ_9ax$vAI$^l z))WssYih0w#?|K7`aO8)SkpXQc;SW0UK#6xakZLvJ+65N58WmYoC{MQMl%;Ym*-j+ zjH`3xZjP48!v*1`mUXdph#n*^~)Sf_St{lCEqi_T__(o zFO#g`d$eagW=x;`%03&68b}D^@Y&!_RX$oiK^}oe&{Ak`KaW<7cSGwKEL)`T8l(P4 zO#?K;UC4#z!@l>>*E8P1-#SroFJj()k0epA)IyTr!S^YpzWaF#Js8aioTb7@!XT<*=FR#gJvJ_4?VOO^p%WpX+O+9 zsN3YL8fWl%o=NjTEYP=R`WX5l_Q5kZ)= z^2B_Eev@_u&q?R>!8MO(tR?%P|6(7c(=ugF#kqw|7-USwy(R8tXgS Zv`nezZ^t<;@d<6lJ1tX!wvZO^{{g&jPWJ!+ literal 0 HcmV?d00001 diff --git a/Samples/TestApp/fMain.dfm b/Samples/TestApp/fMain.dfm new file mode 100644 index 0000000000000000000000000000000000000000..24cbdff3342f3792b04778d11026165e46462df4 GIT binary patch literal 1232 zcmb`HO>fgc5QaBS;*WeZ+!2xw2q7WT29BIkw^k!HjTO6%IKkE);)V6DwYyQ%f5+cJ z;!p{3hP53xjw*2?imct4cV^bl&iGFcMgC$rpP-Xx-#Z9Jfq!B~J{Q@fTRuCN@I|#> zw%QTT+YhL_B8f`dGsC<9vQAZ7wJZ7EF>svbaw7fuP>ud-o z3seRmW-LyP&%L6;F82^QQK*lv6bPqYOiDTiD&hR7;Y@2dM%(l@LhARlV{uakb*Gf9 znPp>o%9Y|7LfvQ%8SfU4W;)|Zwze+t80}F4O#KgNzZ%f`9^VK8!o7mK19HPl!a$Bg zB?w!~mO0D?UkjX-_xiy^X7?7>gqhD>_xRWykH;=f68Bzbb7P)>n}Ptd11uS%UVw!@ zdT~>BPxl9>^i*HEWlE`$q;`aF%iA!Jz2YKS37p#pl-@O=|9pbU__(K3F}9b0lLe#q zPP1N5${P?$_aoicY&B~-Q4m%QY}bpC$FrPJ5R0)mJ(z@H=5+6$Wghqwut(Nw&AX#1e$*cXA1E)7o`-sn_7ioWu?vZwvzda-))k9}nLK_i l>{mNeQ?(=4RP9W5m}*qsMj2a6!_(i9Z`QDums?c){sJ#MhIIe{ literal 0 HcmV?d00001 diff --git a/Samples/TestApp/fMain.pas b/Samples/TestApp/fMain.pas new file mode 100644 index 0000000..327268a --- /dev/null +++ b/Samples/TestApp/fMain.pas @@ -0,0 +1,152 @@ +unit fMain; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + ExtCtrls, StdCtrls, uPSComponent, uPSCompiler, uPSUtils, + Menus, uPSRuntime; + +type + TForm1 = class(TForm) + Memo1: TMemo; + Memo2: TMemo; + Splitter1: TSplitter; + PSScript: TPSScript; + PS3DllPlugin: TPSDllPlugin; + MainMenu1: TMainMenu; + Program1: TMenuItem; + Compile1: TMenuItem; + procedure IFPS3ClassesPlugin1CompImport(Sender: TObject; + x: TPSPascalCompiler); + procedure IFPS3ClassesPlugin1ExecImport(Sender: TObject; Exec: TPSExec; + x: TPSRuntimeClassImporter); + procedure PSScriptCompile(Sender: TPSScript); + procedure Compile1Click(Sender: TObject); + procedure PSScriptExecute(Sender: TPSScript); + private + MyVar: Longint; + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation +uses + uPSR_std, + uPSC_std, + uPSR_stdctrls, + uPSC_stdctrls, + uPSR_forms, + uPSC_forms, + uPSC_graphics, + uPSC_controls, + uPSC_classes, + uPSR_graphics, + uPSR_controls, + uPSR_classes; + +{$R *.DFM} + +procedure TForm1.IFPS3ClassesPlugin1CompImport(Sender: TObject; + x: TIFPSPascalcompiler); +begin + SIRegister_Std(x); + SIRegister_Classes(x, true); + SIRegister_Graphics(x, true); + SIRegister_Controls(x); + SIRegister_stdctrls(x); + SIRegister_Forms(x); +end; + +procedure TForm1.IFPS3ClassesPlugin1ExecImport(Sender: TObject; Exec: TIFPSExec; + x: TIFPSRuntimeClassImporter); +begin + RIRegister_Std(x); + RIRegister_Classes(x, True); + RIRegister_Graphics(x, True); + RIRegister_Controls(x); + RIRegister_stdctrls(x); + RIRegister_Forms(x); +end; + +function ImportTest(S1: string; s2: Longint; s3: Byte; s4: word; var s5: string): string; +begin + Result := s1 + ' ' + IntToStr(s2) + ' ' + IntToStr(s3) + ' ' + IntToStr(s4) + ' - OK!'; + S5 := s5 + ' '+ result + ' - OK2!'; +end; + +procedure MyWriteln(const s: string); +begin + Form1.Memo2.Lines.Add(s); +end; + +function MyReadln(const question: string): string; +begin + Result := InputBox(question, '', ''); +end; + +procedure TForm1.PSScriptCompile(Sender: TPSScript); +begin + Sender.AddFunction(@MyWriteln, 'procedure Writeln(s: string);'); + Sender.AddFunction(@MyReadln, 'function Readln(question: string): string;'); + Sender.AddFunction(@ImportTest, 'function ImportTest(S1: string; s2: Longint; s3: Byte; s4: word; var s5: string): string;'); + Sender.AddRegisteredVariable('Application', 'TApplication'); + Sender.AddRegisteredVariable('Self', 'TForm'); + Sender.AddRegisteredVariable('Memo2', 'TMemo'); + Sender.AddRegisteredPTRVariable('Memo1', 'TMemo'); + Sender.AddRegisteredPTRVariable('MyVar', 'Longint'); +end; + +procedure TForm1.Compile1Click(Sender: TObject); + procedure OutputMessages; + var + l: Longint; + b: Boolean; + begin + b := False; + + for l := 0 to PSScript.CompilerMessageCount - 1 do + begin + Memo2.Lines.Add('Compiler: '+ PSScript.CompilerErrorToStr(l)); + if (not b) and (PSScript.CompilerMessages[l] is TIFPSPascalCompilerError) then + begin + b := True; + Memo1.SelStart := PSScript.CompilerMessages[l].Pos; + end; + end; + end; +begin + Memo2.Lines.Clear; + PSScript.Script.Assign(Memo1.Lines); + Memo2.Lines.Add('Compiling'); + if PSScript.Compile then + begin + OutputMessages; + Memo2.Lines.Add('Compiled succesfully'); + if not PSScript.Execute then + begin + Memo1.SelStart := PSScript.ExecErrorPosition; + Memo2.Lines.Add(PSScript.ExecErrorToString +' at '+Inttostr(PSScript.ExecErrorProcNo)+'.'+Inttostr(PSScript.ExecErrorByteCodePosition)); + end else Memo2.Lines.Add('Succesfully executed'); + end else + begin + OutputMessages; + Memo2.Lines.Add('Compiling failed'); + end; +end; + +procedure TForm1.PSScriptExecute(Sender: TPSScript); +begin + PSScript.SetVarToInstance('APPLICATION', Application); + PSScript.SetVarToInstance('SELF', Self); + PSScript.SetVarToInstance('MEMO1', Memo1); + PSScript.SetVarToInstance('MEMO2', Memo2); + PSScript.SetPointerToData('MyVar', @MyVar, PSScript.FindBaseType(bts32)); + PSScript.SetPointerToData('Memo1', @Memo1, PSScript.FindNamedType('TMemo')); +end; + +end. diff --git a/Source/BuildPackages_D10.bdsgroup b/Source/BuildPackages_D10.bdsgroup new file mode 100644 index 0000000..2f606c0 --- /dev/null +++ b/Source/BuildPackages_D10.bdsgroup @@ -0,0 +1,23 @@ + + + + + + + + + + + + + + + PascalScript_Core_D10.bdsproj + PascalScript_RO_D10.bdsproj + PascalScript_Core_D10.bpl PascalScript_RO_D10.bpl + + + + + diff --git a/Source/BuildPackages_D6.bpg b/Source/BuildPackages_D6.bpg new file mode 100644 index 0000000..3fe0ddd --- /dev/null +++ b/Source/BuildPackages_D6.bpg @@ -0,0 +1,23 @@ +#------------------------------------------------------------------------------ +VERSION = BWS.01 +#------------------------------------------------------------------------------ +!ifndef ROOT +ROOT = $(MAKEDIR)\.. +!endif +#------------------------------------------------------------------------------ +MAKE = $(ROOT)\bin\make.exe -$(MAKEFLAGS) -f$** +DCC = $(ROOT)\bin\dcc32.exe $** +BRCC = $(ROOT)\bin\brcc32.exe $** +#------------------------------------------------------------------------------ +PROJECTS = PascalScript_Core_D6.bpl PascalScript_RO_D6.bpl +#------------------------------------------------------------------------------ +default: $(PROJECTS) +#------------------------------------------------------------------------------ + +PascalScript_Core_D6.bpl: PascalScript_Core_D6.dpk + $(DCC) + +PascalScript_RO_D6.bpl: PascalScript_RO_D6.dpk + $(DCC) + + diff --git a/Source/BuildPackages_D7.bpg b/Source/BuildPackages_D7.bpg new file mode 100644 index 0000000..8e45715 --- /dev/null +++ b/Source/BuildPackages_D7.bpg @@ -0,0 +1,23 @@ +#------------------------------------------------------------------------------ +VERSION = BWS.01 +#------------------------------------------------------------------------------ +!ifndef ROOT +ROOT = $(MAKEDIR)\.. +!endif +#------------------------------------------------------------------------------ +MAKE = $(ROOT)\bin\make.exe -$(MAKEFLAGS) -f$** +DCC = $(ROOT)\bin\dcc32.exe $** +BRCC = $(ROOT)\bin\brcc32.exe $** +#------------------------------------------------------------------------------ +PROJECTS = PascalScript_Core_D7.bpl PascalScript_RO_D7.bpl +#------------------------------------------------------------------------------ +default: $(PROJECTS) +#------------------------------------------------------------------------------ + +PascalScript_Core_D7.bpl: PascalScript_Core_D7.dpk + $(DCC) + +PascalScript_RO_D7.bpl: PascalScript_RO_D7.dpk + $(DCC) + + diff --git a/Source/BuildPackages_D9.bdsgroup b/Source/BuildPackages_D9.bdsgroup new file mode 100644 index 0000000..6ea98c1 --- /dev/null +++ b/Source/BuildPackages_D9.bdsgroup @@ -0,0 +1,20 @@ + + + + + + + + + + + + + PascalScript_Core_D9.bdsproj + PascalScript_RO_D9.bdsproj + PascalScript_Core_D9.bpl PascalScript_RO_D9.bpl + + + + diff --git a/Source/PascalScript.inc b/Source/PascalScript.inc new file mode 100644 index 0000000..f2bb88f --- /dev/null +++ b/Source/PascalScript.inc @@ -0,0 +1,66 @@ +{----------------------------------------------------------------------------} +{ 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}{$H+}{$MODE DELPHI}{$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} + {$DEFINE PS_HAVEVARIANT} + {$DEFINE PS_DYNARRAY} + {$DEFINE PS_NOIDISPATCH} + {$DEFINE DELPHI3UP} + {$DEFINE DELPHI6UP} +{$ENDIF} diff --git a/Source/PascalScript_Core_D10.bdsproj b/Source/PascalScript_Core_D10.bdsproj new file mode 100644 index 0000000..011055c --- /dev/null +++ b/Source/PascalScript_Core_D10.bdsproj @@ -0,0 +1,177 @@ + + + + + + + + + + + + PascalScript_Core_D10.dpk + + + 7.0 + + + 8 + 0 + 1 + 1 + 0 + 0 + 1 + 1 + 1 + 0 + 0 + 1 + 0 + 1 + 1 + 1 + 0 + 0 + 0 + 0 + 0 + 1 + 1 + 1 + 1 + 1 + True + True + + + False + + False + False + False + False + False + False + False + False + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + False + False + False + True + True + True True + True + + + + 0 + 0 + 1 + False + False + False + 16384 + 1048576 + 4194304 + RemObjects Pascal Script - Core Package False + + + + ..\Dcu\D10 + ..\Dcu\D10 + ..\Dcu\D10 + ..\Dcu\D10 + + + + False + + + + + + False + + + + + + False + True + False + + + + $00000000 + + + + True + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 1033 + 1252 + + + RemObjects Software + + 0.0.0.0 + + + + + Pascal Script + 3.0.0.0 + Monday, December 19, 2005 4:43 PM Monday, February 28, 2005 3:33 PM + + + diff --git a/Source/PascalScript_Core_D10.cfg b/Source/PascalScript_Core_D10.cfg new file mode 100644 index 0000000..a58e901 --- /dev/null +++ b/Source/PascalScript_Core_D10.cfg @@ -0,0 +1,51 @@ +-$A8 +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J- +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q- +-$R- +-$S- +-$T- +-$U- +-$V+ +-$W+ +-$X+ +-$YD +-$Z1 +-cg +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 +-N0"..\Dcu\D10" +-LE"..\Dcu\D10" +-LN"..\Dcu\D10" +-U"..\Dcu\D10" +-O"..\Dcu\D10" +-I"..\Dcu\D10" +-R"..\Dcu\D10" +-Z +-w-SYMBOL_DEPRECATED +-w-SYMBOL_LIBRARY +-w-SYMBOL_PLATFORM +-w-SYMBOL_EXPERIMENTAL +-w-UNIT_LIBRARY +-w-UNIT_PLATFORM +-w-UNIT_DEPRECATED +-w-UNIT_EXPERIMENTAL +-w-UNSAFE_TYPE +-w-UNSAFE_CODE +-w-UNSAFE_CAST diff --git a/Source/PascalScript_Core_D10.dpk b/Source/PascalScript_Core_D10.dpk new file mode 100644 index 0000000..d859134 --- /dev/null +++ b/Source/PascalScript_Core_D10.dpk @@ -0,0 +1,77 @@ +package PascalScript_Core_D10; + +{$R *.res} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'RemObjects Pascal Script - Core Package'} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + rtl, + vcl, + dbrtl; + +contains + uPSC_extctrls in 'uPSC_extctrls.pas', + uPSC_forms in 'uPSC_forms.pas', + uPSC_graphics in 'uPSC_graphics.pas', + uPSC_menus in 'uPSC_menus.pas', + uPSC_std in 'uPSC_std.pas', + uPSC_stdctrls in 'uPSC_stdctrls.pas', + uPSCompiler in 'uPSCompiler.pas', + uPSComponent in 'uPSComponent.pas', + uPSComponent_COM in 'uPSComponent_COM.pas', + uPSComponent_Controls in 'uPSComponent_Controls.pas', + uPSComponent_DB in 'uPSComponent_DB.pas', + uPSComponent_Default in 'uPSComponent_Default.pas', + uPSComponent_Forms in 'uPSComponent_Forms.pas', + uPSComponent_StdCtrls in 'uPSComponent_StdCtrls.pas', + uPSDebugger in 'uPSDebugger.pas', + uPSDisassembly in 'uPSDisassembly.pas', + uPSPreProcessor in 'uPSPreProcessor.pas', + uPSR_buttons in 'uPSR_buttons.pas', + uPSR_classes in 'uPSR_classes.pas', + uPSR_comobj in 'uPSR_comobj.pas', + uPSR_controls in 'uPSR_controls.pas', + uPSR_dateutils in 'uPSR_dateutils.pas', + uPSR_DB in 'uPSR_DB.pas', + uPSR_dll in 'uPSR_dll.pas', + uPSR_extctrls in 'uPSR_extctrls.pas', + uPSR_forms in 'uPSR_forms.pas', + uPSR_graphics in 'uPSR_graphics.pas', + uPSR_menus in 'uPSR_menus.pas', + uPSR_std in 'uPSR_std.pas', + uPSR_stdctrls in 'uPSR_stdctrls.pas', + uPSRuntime in 'uPSRuntime.pas', + uPSUtils in 'uPSUtils.pas', + uPSC_buttons in 'uPSC_buttons.pas', + uPSC_classes in 'uPSC_classes.pas', + uPSC_comobj in 'uPSC_comobj.pas', + uPSC_controls in 'uPSC_controls.pas', + uPSC_dateutils in 'uPSC_dateutils.pas', + uPSC_DB in 'uPSC_DB.pas', + uPSC_dll in 'uPSC_dll.pas', + PascalScript_Core_Reg in 'PascalScript_Core_Reg.pas', + uPSComponentExt in 'uPSComponentExt.pas'; + +end. diff --git a/Source/PascalScript_Core_D10.res b/Source/PascalScript_Core_D10.res new file mode 100644 index 0000000000000000000000000000000000000000..c3408319a9ee865c8bdf00438d00c05edbe2a4c1 GIT binary patch literal 616 zcmZXS!AiqG5QcwC4tfy}K0pu;J%~gb4~pQyDE3edt@J8sQzc@Pl0>9$;7j>7-hBh> zx0^0jyD+=6nScKIXEu`LV~a&&xPMl=<>EVFHf$`=mghk2R){;)Ko9I!>f?2Fr(5n_ z_G^5zKD@7QsmZq=mfOYh^yIBY-z|KgTBS1OdV(#}izYDVdQ?GfYB7OA1v7&>I=&+G)K-7b z)=9a~b%4Uic58YcStY)Xn45_l!x!iTFVq>qGrw& OlQ7j?hvIMf^nL&=WK-n; literal 0 HcmV?d00001 diff --git a/Source/PascalScript_Core_D3.dof b/Source/PascalScript_Core_D3.dof new file mode 100644 index 0000000..a71ae03 --- /dev/null +++ b/Source/PascalScript_Core_D3.dof @@ -0,0 +1,115 @@ +[FileVersion] +Version=3.0 + +[Compiler] +A=8 +B=0 +C=1 +D=1 +E=0 +F=0 +G=1 +H=1 +I=1 +J=0 +K=0 +L=1 +M=0 +N=1 +O=1 +P=1 +Q=0 +R=0 +S=0 +T=0 +U=0 +V=1 +W=1 +X=1 +Y=1 +Z=1 +ShowHints=1 +ShowWarnings=1 +UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +NamespacePrefix= +SymbolDeprecated=0 +SymbolLibrary=0 +SymbolPlatform=0 +UnitLibrary=0 +UnitPlatform=0 +UnitDeprecated=0 +HResultCompat=1 +HidingMember=1 +HiddenVirtual=1 +Garbage=1 +BoundsError=1 +ZeroNilCompat=1 +StringConstTruncated=1 +ForLoopVarVarPar=1 +TypedConstVarPar=1 +AsgToTypedConst=1 +CaseLabelRange=1 +ForVariable=1 +ConstructingAbstract=1 +ComparisonFalse=1 +ComparisonTrue=1 +ComparingSignedUnsigned=1 +CombiningSignedUnsigned=1 +UnsupportedConstruct=1 +FileOpen=1 +FileOpenUnitSrc=1 +BadGlobalSymbol=1 +DuplicateConstructorDestructor=1 +InvalidDirective=1 +PackageNoLink=1 +PackageThreadVar=1 +ImplicitImport=1 +HPPEMITIgnored=1 +NoRetVal=1 +UseBeforeDef=1 +ForLoopVarUndef=1 +UnitNameMismatch=1 +NoCFGFileFound=1 +MessageDirective=1 +ImplicitVariants=1 +UnicodeToLocale=1 +LocaleToUnicode=1 +ImagebaseMultiple=1 +SuspiciousTypecast=1 +PrivatePropAccessor=1 +UnsafeType=0 +UnsafeCode=0 +UnsafeCast=0 + +[Linker] +MapFile=0 +OutputObjs=0 +ConsoleApp=1 +DebugInfo=0 +RemoteSymbols=0 +MinStackSize=16384 +MaxStackSize=1048576 +ImageBase=4194304 +ExeDescription=RemObjects Pascal Script - Core Package + +[Directories] +OutputDir=s:\exe +UnitOutputDir=..\Dcu\D3 +PackageDLLOutputDir=..\Dcu\D3 +PackageDCPOutputDir=..\Dcu\D3 +SearchPath= +Conditionals= +DebugSourceDirs= +UsePackages=0 + +[Version Info Keys] +CompanyName=RemObjects Software +InternalName= +LegalCopyright= +LegalTrademarks= +ProductName=Pascal Script +ProductVersion=3.0.0.0 +FileDescription= +FileVersion=3.0.2.34 +OriginalFilename= + diff --git a/Source/PascalScript_Core_D3.dpk b/Source/PascalScript_Core_D3.dpk new file mode 100644 index 0000000..c4a4dc2 --- /dev/null +++ b/Source/PascalScript_Core_D3.dpk @@ -0,0 +1,76 @@ +package PascalScript_Core_D3; + +{$R *.res} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'RemObjects Pascal Script - Core Package'} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + rtl, + vcl, + dbrtl; + +contains + uPSC_extctrls in 'uPSC_extctrls.pas', + uPSC_forms in 'uPSC_forms.pas', + uPSC_graphics in 'uPSC_graphics.pas', + uPSC_menus in 'uPSC_menus.pas', + uPSC_std in 'uPSC_std.pas', + uPSC_stdctrls in 'uPSC_stdctrls.pas', + uPSCompiler in 'uPSCompiler.pas', + uPSComponent in 'uPSComponent.pas', + uPSComponent_COM in 'uPSComponent_COM.pas', + uPSComponent_Controls in 'uPSComponent_Controls.pas', + uPSComponent_DB in 'uPSComponent_DB.pas', + uPSComponent_Default in 'uPSComponent_Default.pas', + uPSComponent_Forms in 'uPSComponent_Forms.pas', + uPSComponent_StdCtrls in 'uPSComponent_StdCtrls.pas', + uPSDebugger in 'uPSDebugger.pas', + uPSDisassembly in 'uPSDisassembly.pas', + uPSPreProcessor in 'uPSPreProcessor.pas', + uPSR_buttons in 'uPSR_buttons.pas', + uPSR_classes in 'uPSR_classes.pas', + uPSR_comobj in 'uPSR_comobj.pas', + uPSR_controls in 'uPSR_controls.pas', + uPSR_dateutils in 'uPSR_dateutils.pas', + uPSR_DB in 'uPSR_DB.pas', + uPSR_dll in 'uPSR_dll.pas', + uPSR_extctrls in 'uPSR_extctrls.pas', + UPSR_forms in 'uPSR_forms.pas', + UPSR_graphics in 'uPSR_graphics.pas', + uPSR_menus in 'uPSR_menus.pas', + uPSR_std in 'uPSR_std.pas', + uPSR_stdctrls in 'uPSR_stdctrls.pas', + uPSRuntime in 'uPSRuntime.pas', + uPSUtils in 'uPSUtils.pas', + uPSC_buttons in 'uPSC_buttons.pas', + uPSC_classes in 'uPSC_classes.pas', + uPSC_comobj in 'uPSC_comobj.pas', + uPSC_controls in 'uPSC_controls.pas', + uPSC_dateutils in 'uPSC_dateutils.pas', + uPSC_DB in 'uPSC_DB.pas', + uPSC_dll in 'uPSC_dll.pas', + PascalScript_Core_Reg in 'PascalScript_Core_Reg.pas'; + +end. diff --git a/Source/PascalScript_Core_D4.dof b/Source/PascalScript_Core_D4.dof new file mode 100644 index 0000000..735a460 --- /dev/null +++ b/Source/PascalScript_Core_D4.dof @@ -0,0 +1,114 @@ +[FileVersion] +Version=4.0 + +[Compiler] +A=8 +B=0 +C=1 +D=1 +E=0 +F=0 +G=1 +H=1 +I=1 +J=0 +K=0 +L=1 +M=0 +N=1 +O=1 +P=1 +Q=0 +R=0 +S=0 +T=0 +U=0 +V=1 +W=1 +X=1 +Y=1 +Z=1 +ShowHints=1 +ShowWarnings=1 +UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +NamespacePrefix= +SymbolDeprecated=0 +SymbolLibrary=0 +SymbolPlatform=0 +UnitLibrary=0 +UnitPlatform=0 +UnitDeprecated=0 +HResultCompat=1 +HidingMember=1 +HiddenVirtual=1 +Garbage=1 +BoundsError=1 +ZeroNilCompat=1 +StringConstTruncated=1 +ForLoopVarVarPar=1 +TypedConstVarPar=1 +AsgToTypedConst=1 +CaseLabelRange=1 +ForVariable=1 +ConstructingAbstract=1 +ComparisonFalse=1 +ComparisonTrue=1 +ComparingSignedUnsigned=1 +CombiningSignedUnsigned=1 +UnsupportedConstruct=1 +FileOpen=1 +FileOpenUnitSrc=1 +BadGlobalSymbol=1 +DuplicateConstructorDestructor=1 +InvalidDirective=1 +PackageNoLink=1 +PackageThreadVar=1 +ImplicitImport=1 +HPPEMITIgnored=1 +NoRetVal=1 +UseBeforeDef=1 +ForLoopVarUndef=1 +UnitNameMismatch=1 +NoCFGFileFound=1 +MessageDirective=1 +ImplicitVariants=1 +UnicodeToLocale=1 +LocaleToUnicode=1 +ImagebaseMultiple=1 +SuspiciousTypecast=1 +PrivatePropAccessor=1 +UnsafeType=0 +UnsafeCode=0 +UnsafeCast=0 + +[Linker] +MapFile=0 +OutputObjs=0 +ConsoleApp=1 +DebugInfo=0 +RemoteSymbols=0 +MinStackSize=16384 +MaxStackSize=1048576 +ImageBase=4194304 +ExeDescription=RemObjects Pascal Script - Core Package + +[Directories] +UnitOutputDir=..\Dcu\D4 +PackageDLLOutputDir=..\Dcu\D4 +PackageDCPOutputDir=..\Dcu\D4 +SearchPath= +Conditionals= +DebugSourceDirs= +UsePackages=0 + +[Version Info Keys] +CompanyName=RemObjects Software +InternalName= +LegalCopyright= +LegalTrademarks= +ProductName=Pascal Script +ProductVersion=3.0.0.0 +FileDescription= +FileVersion=3.0.2.34 +OriginalFilename= + diff --git a/Source/PascalScript_Core_D4.dpk b/Source/PascalScript_Core_D4.dpk new file mode 100644 index 0000000..29b5d69 --- /dev/null +++ b/Source/PascalScript_Core_D4.dpk @@ -0,0 +1,76 @@ +package PascalScript_Core_D4 + +{$R *.res} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'RemObjects Pascal Script - Core Package'} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + rtl, + vcl, + dbrtl; + +contains + uPSC_extctrls in 'uPSC_extctrls.pas', + uPSC_forms in 'uPSC_forms.pas', + uPSC_graphics in 'uPSC_graphics.pas', + uPSC_menus in 'uPSC_menus.pas', + uPSC_std in 'uPSC_std.pas', + uPSC_stdctrls in 'uPSC_stdctrls.pas', + uPSCompiler in 'uPSCompiler.pas', + uPSComponent in 'uPSComponent.pas', + uPSComponent_COM in 'uPSComponent_COM.pas', + uPSComponent_Controls in 'uPSComponent_Controls.pas', + uPSComponent_DB in 'uPSComponent_DB.pas', + uPSComponent_Default in 'uPSComponent_Default.pas', + uPSComponent_Forms in 'uPSComponent_Forms.pas', + uPSComponent_StdCtrls in 'uPSComponent_StdCtrls.pas', + uPSDebugger in 'uPSDebugger.pas', + uPSDisassembly in 'uPSDisassembly.pas', + uPSPreProcessor in 'uPSPreProcessor.pas', + uPSR_buttons in 'uPSR_buttons.pas', + uPSR_classes in 'uPSR_classes.pas', + uPSR_comobj in 'uPSR_comobj.pas', + uPSR_controls in 'uPSR_controls.pas', + uPSR_dateutils in 'uPSR_dateutils.pas', + uPSR_DB in 'uPSR_DB.pas', + uPSR_dll in 'uPSR_dll.pas', + uPSR_extctrls in 'uPSR_extctrls.pas', + UPSR_forms in 'uPSR_forms.pas', + UPSR_graphics in 'uPSR_graphics.pas', + uPSR_menus in 'uPSR_menus.pas', + uPSR_std in 'uPSR_std.pas', + uPSR_stdctrls in 'uPSR_stdctrls.pas', + uPSRuntime in 'uPSRuntime.pas', + uPSUtils in 'uPSUtils.pas', + uPSC_buttons in 'uPSC_buttons.pas', + uPSC_classes in 'uPSC_classes.pas', + uPSC_comobj in 'uPSC_comobj.pas', + uPSC_controls in 'uPSC_controls.pas', + uPSC_dateutils in 'uPSC_dateutils.pas', + uPSC_DB in 'uPSC_DB.pas', + uPSC_dll in 'uPSC_dll.pas', + PascalScript_Core_Reg in 'PascalScript_Core_Reg.pas'; + +end. diff --git a/Source/PascalScript_Core_D5.dof b/Source/PascalScript_Core_D5.dof new file mode 100644 index 0000000..5b2a54e --- /dev/null +++ b/Source/PascalScript_Core_D5.dof @@ -0,0 +1,114 @@ +[FileVersion] +Version=5.0 + +[Compiler] +A=8 +B=0 +C=1 +D=1 +E=0 +F=0 +G=1 +H=1 +I=1 +J=0 +K=0 +L=1 +M=0 +N=1 +O=1 +P=1 +Q=0 +R=0 +S=0 +T=0 +U=0 +V=1 +W=1 +X=1 +Y=1 +Z=1 +ShowHints=1 +ShowWarnings=1 +UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +NamespacePrefix= +SymbolDeprecated=0 +SymbolLibrary=0 +SymbolPlatform=0 +UnitLibrary=0 +UnitPlatform=0 +UnitDeprecated=0 +HResultCompat=1 +HidingMember=1 +HiddenVirtual=1 +Garbage=1 +BoundsError=1 +ZeroNilCompat=1 +StringConstTruncated=1 +ForLoopVarVarPar=1 +TypedConstVarPar=1 +AsgToTypedConst=1 +CaseLabelRange=1 +ForVariable=1 +ConstructingAbstract=1 +ComparisonFalse=1 +ComparisonTrue=1 +ComparingSignedUnsigned=1 +CombiningSignedUnsigned=1 +UnsupportedConstruct=1 +FileOpen=1 +FileOpenUnitSrc=1 +BadGlobalSymbol=1 +DuplicateConstructorDestructor=1 +InvalidDirective=1 +PackageNoLink=1 +PackageThreadVar=1 +ImplicitImport=1 +HPPEMITIgnored=1 +NoRetVal=1 +UseBeforeDef=1 +ForLoopVarUndef=1 +UnitNameMismatch=1 +NoCFGFileFound=1 +MessageDirective=1 +ImplicitVariants=1 +UnicodeToLocale=1 +LocaleToUnicode=1 +ImagebaseMultiple=1 +SuspiciousTypecast=1 +PrivatePropAccessor=1 +UnsafeType=0 +UnsafeCode=0 +UnsafeCast=0 + +[Linker] +MapFile=0 +OutputObjs=0 +ConsoleApp=1 +DebugInfo=0 +RemoteSymbols=0 +MinStackSize=16384 +MaxStackSize=1048576 +ImageBase=4194304 +ExeDescription=RemObjects Pascal Script - Core Package + +[Directories] +UnitOutputDir=..\Dcu\D5 +PackageDLLOutputDir=..\Dcu\D5 +PackageDCPOutputDir=..\Dcu\D5 +SearchPath= +Conditionals= +DebugSourceDirs= +UsePackages=0 + +[Version Info Keys] +CompanyName=RemObjects Software +InternalName= +LegalCopyright= +LegalTrademarks= +ProductName=Pascal Script +ProductVersion=3.0.0.0 +FileDescription= +FileVersion=3.0.2.34 +OriginalFilename= + diff --git a/Source/PascalScript_Core_D5.dpk b/Source/PascalScript_Core_D5.dpk new file mode 100644 index 0000000..93d28f0 --- /dev/null +++ b/Source/PascalScript_Core_D5.dpk @@ -0,0 +1,76 @@ +package PascalScript_Core_D5; + +{$R *.res} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'RemObjects Pascal Script - Core Package'} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + rtl, + vcl, + dbrtl; + +contains + uPSC_extctrls in 'uPSC_extctrls.pas', + uPSC_forms in 'uPSC_forms.pas', + uPSC_graphics in 'uPSC_graphics.pas', + uPSC_menus in 'uPSC_menus.pas', + uPSC_std in 'uPSC_std.pas', + uPSC_stdctrls in 'uPSC_stdctrls.pas', + uPSCompiler in 'uPSCompiler.pas', + uPSComponent in 'uPSComponent.pas', + uPSComponent_COM in 'uPSComponent_COM.pas', + uPSComponent_Controls in 'uPSComponent_Controls.pas', + uPSComponent_DB in 'uPSComponent_DB.pas', + uPSComponent_Default in 'uPSComponent_Default.pas', + uPSComponent_Forms in 'uPSComponent_Forms.pas', + uPSComponent_StdCtrls in 'uPSComponent_StdCtrls.pas', + uPSDebugger in 'uPSDebugger.pas', + uPSDisassembly in 'uPSDisassembly.pas', + uPSPreProcessor in 'uPSPreProcessor.pas', + uPSR_buttons in 'uPSR_buttons.pas', + uPSR_classes in 'uPSR_classes.pas', + uPSR_comobj in 'uPSR_comobj.pas', + uPSR_controls in 'uPSR_controls.pas', + uPSR_dateutils in 'uPSR_dateutils.pas', + uPSR_DB in 'uPSR_DB.pas', + uPSR_dll in 'uPSR_dll.pas', + uPSR_extctrls in 'uPSR_extctrls.pas', + UPSR_forms in 'uPSR_forms.pas', + UPSR_graphics in 'uPSR_graphics.pas', + uPSR_menus in 'uPSR_menus.pas', + uPSR_std in 'uPSR_std.pas', + uPSR_stdctrls in 'uPSR_stdctrls.pas', + uPSRuntime in 'uPSRuntime.pas', + uPSUtils in 'uPSUtils.pas', + uPSC_buttons in 'uPSC_buttons.pas', + uPSC_classes in 'uPSC_classes.pas', + uPSC_comobj in 'uPSC_comobj.pas', + uPSC_controls in 'uPSC_controls.pas', + uPSC_dateutils in 'uPSC_dateutils.pas', + uPSC_DB in 'uPSC_DB.pas', + uPSC_dll in 'uPSC_dll.pas', + PascalScript_Core_Reg in 'PascalScript_Core_Reg.pas'; + +end. diff --git a/Source/PascalScript_Core_D6.dof b/Source/PascalScript_Core_D6.dof new file mode 100644 index 0000000..f5f914f --- /dev/null +++ b/Source/PascalScript_Core_D6.dof @@ -0,0 +1,127 @@ +[FileVersion] +Version=6.0 + +[Compiler] +A=8 +B=0 +C=1 +D=1 +E=0 +F=0 +G=1 +H=1 +I=1 +J=0 +K=0 +L=1 +M=0 +N=1 +O=1 +P=1 +Q=0 +R=0 +S=0 +T=0 +U=0 +V=1 +W=1 +X=1 +Y=1 +Z=1 +ShowHints=1 +ShowWarnings=1 +UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +NamespacePrefix= +SymbolDeprecated=0 +SymbolLibrary=0 +SymbolPlatform=0 +UnitLibrary=0 +UnitPlatform=0 +UnitDeprecated=0 +HResultCompat=1 +HidingMember=1 +HiddenVirtual=1 +Garbage=1 +BoundsError=1 +ZeroNilCompat=1 +StringConstTruncated=1 +ForLoopVarVarPar=1 +TypedConstVarPar=1 +AsgToTypedConst=1 +CaseLabelRange=1 +ForVariable=1 +ConstructingAbstract=1 +ComparisonFalse=1 +ComparisonTrue=1 +ComparingSignedUnsigned=1 +CombiningSignedUnsigned=1 +UnsupportedConstruct=1 +FileOpen=1 +FileOpenUnitSrc=1 +BadGlobalSymbol=1 +DuplicateConstructorDestructor=1 +InvalidDirective=1 +PackageNoLink=1 +PackageThreadVar=1 +ImplicitImport=1 +HPPEMITIgnored=1 +NoRetVal=1 +UseBeforeDef=1 +ForLoopVarUndef=1 +UnitNameMismatch=1 +NoCFGFileFound=1 +MessageDirective=1 +ImplicitVariants=1 +UnicodeToLocale=1 +LocaleToUnicode=1 +ImagebaseMultiple=1 +SuspiciousTypecast=1 +PrivatePropAccessor=1 +UnsafeType=0 +UnsafeCode=0 +UnsafeCast=0 + +[Linker] +MapFile=0 +OutputObjs=0 +ConsoleApp=1 +DebugInfo=0 +RemoteSymbols=0 +MinStackSize=16384 +MaxStackSize=1048576 +ImageBase=4194304 +ExeDescription=RemObjects Pascal Script - Core Package + +[Directories] +UnitOutputDir=..\Dcu\D6 +PackageDLLOutputDir=..\Dcu\D6 +PackageDCPOutputDir=..\Dcu\D6 +SearchPath= +Conditionals= +DebugSourceDirs= +UsePackages=0 + + +[Version Info] +MajorVer=3 +MinorVer=0 +Release=2 +Build=36 +AutoIncBuild=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1033 +CodePage=1252 +[Version Info Keys] +CompanyName=RemObjects Software +InternalName= +LegalCopyright= +LegalTrademarks= +ProductName=Pascal Script +ProductVersion=3.0.0.0 +FileDescription= +FileVersion=3.0.2.36 +OriginalFilename= diff --git a/Source/PascalScript_Core_D6.dpk b/Source/PascalScript_Core_D6.dpk new file mode 100644 index 0000000..fb43acd --- /dev/null +++ b/Source/PascalScript_Core_D6.dpk @@ -0,0 +1,76 @@ +package PascalScript_Core_D6; + +{$R *.res} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'RemObjects Pascal Script - Core Package'} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + rtl, + vcl, + dbrtl; + +contains + uPSC_extctrls in 'uPSC_extctrls.pas', + uPSC_forms in 'uPSC_forms.pas', + uPSC_graphics in 'uPSC_graphics.pas', + uPSC_menus in 'uPSC_menus.pas', + uPSC_std in 'uPSC_std.pas', + uPSC_stdctrls in 'uPSC_stdctrls.pas', + uPSCompiler in 'uPSCompiler.pas', + uPSComponent in 'uPSComponent.pas', + uPSComponent_COM in 'uPSComponent_COM.pas', + uPSComponent_Controls in 'uPSComponent_Controls.pas', + uPSComponent_DB in 'uPSComponent_DB.pas', + uPSComponent_Default in 'uPSComponent_Default.pas', + uPSComponent_Forms in 'uPSComponent_Forms.pas', + uPSComponent_StdCtrls in 'uPSComponent_StdCtrls.pas', + uPSDebugger in 'uPSDebugger.pas', + uPSDisassembly in 'uPSDisassembly.pas', + uPSPreProcessor in 'uPSPreProcessor.pas', + uPSR_buttons in 'uPSR_buttons.pas', + uPSR_classes in 'uPSR_classes.pas', + uPSR_comobj in 'uPSR_comobj.pas', + uPSR_controls in 'uPSR_controls.pas', + uPSR_dateutils in 'uPSR_dateutils.pas', + uPSR_DB in 'uPSR_DB.pas', + uPSR_dll in 'uPSR_dll.pas', + uPSR_extctrls in 'uPSR_extctrls.pas', + UPSR_forms in 'uPSR_forms.pas', + UPSR_graphics in 'uPSR_graphics.pas', + uPSR_menus in 'uPSR_menus.pas', + uPSR_std in 'uPSR_std.pas', + uPSR_stdctrls in 'uPSR_stdctrls.pas', + uPSRuntime in 'uPSRuntime.pas', + uPSUtils in 'uPSUtils.pas', + uPSC_buttons in 'uPSC_buttons.pas', + uPSC_classes in 'uPSC_classes.pas', + uPSC_comobj in 'uPSC_comobj.pas', + uPSC_controls in 'uPSC_controls.pas', + uPSC_dateutils in 'uPSC_dateutils.pas', + uPSC_DB in 'uPSC_DB.pas', + uPSC_dll in 'uPSC_dll.pas', + PascalScript_Core_Reg in 'PascalScript_Core_Reg.pas'; + +end. diff --git a/Source/PascalScript_Core_D6.res b/Source/PascalScript_Core_D6.res new file mode 100644 index 0000000000000000000000000000000000000000..b0b34001eec90986804668eb2dc1a9bd09d7757a GIT binary patch literal 616 zcmZXS&q~8U5XL`i4)!7*e1L!+dJrjT6cjgkI4M3;CSb#=kM z!+eTwXwJ>HNUQ~78g!&~SXWbTj$T7@TKH&&u2 zhy2MCft+$0qs!ulPU{2?p=0G=>;TrBh!K1ln3lFtU6~Z9PE1wjU-SYW5Yy6*m7;4h zFKR72&rcIU6#kYrUARCSIe3yrjWNcM3RR<+AORamR0t)+8?C}rER?22D&b&Hy^#3N zkU*1-Nl*SA96WfFV-JM&dvA8Tt*9@3GxN>+-j8{+QvgU)ecvjV1M+hyw8zMC)Rs&R z$3xOxF4ENJR0qK}ef};@fIl>wcH+n-wTVurLxU6{lW!-Ewl3MUl1e4RrOyAyv3$GQ zPmi#x+Yvs@01XJX4(>5xnH=#x>;?%ZMzFE2?s39vDJ}$reXp%JAT&JBv$&wS+#WWH z6J_tn+ATIFh-WlF)tIu)XN&|OHj2wF#fct18Ni3-_5lCT^IHA>#BIR{{6BkbPftYb zu%5=z$G_23Q)j6+;QC+T_}}@}oB?0Xf!RPOh(*Ub z|4^}oN*|XR>jK3KpnD1D!f(bd{j)J&WE?<->ieU3jX5mh4Rsz%oI~k<7xEe$q|^v(* ziUhPTRiO@V^-bonhZ?p}K?ym|+t_5}3JiA1$|@&=EKmA`nq>`A(Myao-aI)wd<;eM z4|wV#(Wb^;;k?7z-r*xx@0p{{|AajGhU*5IHD%so6sMPWfqQkbrJgEzTjWEo`ETO&K-Ok)5A?KR zYmIoTWE8PMza2eKnbm}1xl2I|>8|7r`zt8y6z~kAtYDekT}Jz)-Rke`MfK}EY_prg81KcNjj{T5sNd76tkUg2@ sdq`8Cvfq!mTIM?dBZ;ihyVg5#^hE);^=q`DW{&Q0B>p4*8y|%;r2qf` literal 0 HcmV?d00001 diff --git a/Source/PascalScript_Core_D7.cfg b/Source/PascalScript_Core_D7.cfg new file mode 100644 index 0000000..8189105 --- /dev/null +++ b/Source/PascalScript_Core_D7.cfg @@ -0,0 +1,47 @@ +-$A8 +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J- +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q- +-$R- +-$S- +-$T- +-$U- +-$V+ +-$W+ +-$X+ +-$YD +-$Z1 +-cg +-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 +-E"s:\exe" +-N"..\Dcu\D7" +-LE"..\Dcu\D7" +-LN"..\Dcu\D7" +-Z +-w-SYMBOL_DEPRECATED +-w-SYMBOL_LIBRARY +-w-SYMBOL_PLATFORM +-w-UNIT_LIBRARY +-w-UNIT_PLATFORM +-w-UNIT_DEPRECATED +-w-UNSAFE_TYPE +-w-UNSAFE_CODE +-w-UNSAFE_CAST diff --git a/Source/PascalScript_Core_D7.dof b/Source/PascalScript_Core_D7.dof new file mode 100644 index 0000000..7fee580 --- /dev/null +++ b/Source/PascalScript_Core_D7.dof @@ -0,0 +1,129 @@ +[FileVersion] +Version=7.0 + +[Compiler] +A=8 +B=0 +C=1 +D=1 +E=0 +F=0 +G=1 +H=1 +I=1 +J=0 +K=0 +L=1 +M=0 +N=1 +O=1 +P=1 +Q=0 +R=0 +S=0 +T=0 +U=0 +V=1 +W=1 +X=1 +Y=1 +Z=1 +ShowHints=1 +ShowWarnings=1 +UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +NamespacePrefix= +SymbolDeprecated=0 +SymbolLibrary=0 +SymbolPlatform=0 +UnitLibrary=0 +UnitPlatform=0 +UnitDeprecated=0 +HResultCompat=1 +HidingMember=1 +HiddenVirtual=1 +Garbage=1 +BoundsError=1 +ZeroNilCompat=1 +StringConstTruncated=1 +ForLoopVarVarPar=1 +TypedConstVarPar=1 +AsgToTypedConst=1 +CaseLabelRange=1 +ForVariable=1 +ConstructingAbstract=1 +ComparisonFalse=1 +ComparisonTrue=1 +ComparingSignedUnsigned=1 +CombiningSignedUnsigned=1 +UnsupportedConstruct=1 +FileOpen=1 +FileOpenUnitSrc=1 +BadGlobalSymbol=1 +DuplicateConstructorDestructor=1 +InvalidDirective=1 +PackageNoLink=1 +PackageThreadVar=1 +ImplicitImport=1 +HPPEMITIgnored=1 +NoRetVal=1 +UseBeforeDef=1 +ForLoopVarUndef=1 +UnitNameMismatch=1 +NoCFGFileFound=1 +MessageDirective=1 +ImplicitVariants=1 +UnicodeToLocale=1 +LocaleToUnicode=1 +ImagebaseMultiple=1 +SuspiciousTypecast=1 +PrivatePropAccessor=1 +UnsafeType=0 +UnsafeCode=0 +UnsafeCast=0 + +[Linker] +MapFile=0 +OutputObjs=0 +ConsoleApp=1 +DebugInfo=0 +RemoteSymbols=0 +MinStackSize=16384 +MaxStackSize=1048576 +ImageBase=4194304 +ExeDescription=RemObjects Pascal Script - Core Package + +[Directories] +OutputDir= +UnitOutputDir=..\Dcu\D7 +PackageDLLOutputDir=..\Dcu\D7 +PackageDCPOutputDir=..\Dcu\D7 +SearchPath= +Packages= +Conditionals= +DebugSourceDirs= +UsePackages=0 + + +[Version Info] +MajorVer=3 +MinorVer=0 +Release=2 +Build=36 +AutoIncBuild=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1033 +CodePage=1252 +[Version Info Keys] +CompanyName=RemObjects Software +InternalName= +LegalCopyright= +LegalTrademarks= +ProductName=Pascal Script +ProductVersion=3.0.0.0 +FileDescription= +FileVersion=3.0.2.36 +OriginalFilename= diff --git a/Source/PascalScript_Core_D7.dpk b/Source/PascalScript_Core_D7.dpk new file mode 100644 index 0000000..0d9be30 --- /dev/null +++ b/Source/PascalScript_Core_D7.dpk @@ -0,0 +1,76 @@ +package PascalScript_Core_D7; + +{$R *.res} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'RemObjects Pascal Script - Core Package'} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + rtl, + vcl, + dbrtl; + +contains + uPSC_extctrls in 'uPSC_extctrls.pas', + uPSC_forms in 'uPSC_forms.pas', + uPSC_graphics in 'uPSC_graphics.pas', + uPSC_menus in 'uPSC_menus.pas', + uPSC_std in 'uPSC_std.pas', + uPSC_stdctrls in 'uPSC_stdctrls.pas', + uPSCompiler in 'uPSCompiler.pas', + uPSComponent in 'uPSComponent.pas', + uPSComponent_COM in 'uPSComponent_COM.pas', + uPSComponent_Controls in 'uPSComponent_Controls.pas', + uPSComponent_DB in 'uPSComponent_DB.pas', + uPSComponent_Default in 'uPSComponent_Default.pas', + uPSComponent_Forms in 'uPSComponent_Forms.pas', + uPSComponent_StdCtrls in 'uPSComponent_StdCtrls.pas', + uPSDebugger in 'uPSDebugger.pas', + uPSDisassembly in 'uPSDisassembly.pas', + uPSPreProcessor in 'uPSPreProcessor.pas', + uPSR_buttons in 'uPSR_buttons.pas', + uPSR_classes in 'uPSR_classes.pas', + uPSR_comobj in 'uPSR_comobj.pas', + uPSR_controls in 'uPSR_controls.pas', + uPSR_dateutils in 'uPSR_dateutils.pas', + uPSR_DB in 'uPSR_DB.pas', + uPSR_dll in 'uPSR_dll.pas', + uPSR_extctrls in 'uPSR_extctrls.pas', + UPSR_forms in 'uPSR_forms.pas', + UPSR_graphics in 'uPSR_graphics.pas', + uPSR_menus in 'uPSR_menus.pas', + uPSR_std in 'uPSR_std.pas', + uPSR_stdctrls in 'uPSR_stdctrls.pas', + uPSRuntime in 'uPSRuntime.pas', + uPSUtils in 'uPSUtils.pas', + uPSC_buttons in 'uPSC_buttons.pas', + uPSC_classes in 'uPSC_classes.pas', + uPSC_comobj in 'uPSC_comobj.pas', + uPSC_controls in 'uPSC_controls.pas', + uPSC_dateutils in 'uPSC_dateutils.pas', + uPSC_DB in 'uPSC_DB.pas', + uPSC_dll in 'uPSC_dll.pas', + PascalScript_Core_Reg in 'PascalScript_Core_Reg.pas'; + +end. diff --git a/Source/PascalScript_Core_D7.res b/Source/PascalScript_Core_D7.res new file mode 100644 index 0000000000000000000000000000000000000000..b0b34001eec90986804668eb2dc1a9bd09d7757a GIT binary patch literal 616 zcmZXS&q~8U5XL`i4)!7*e1L!+dJrjT6cjgkI4M3;CSb#=kM z!+eTwXwJ>HNUQ~78g!&~SXWbTj$T7@TKH&&u2 zhy2MCft+$0qs!ulPU{2?p=0G=>;TrBh!K1ln3lFtU6~Z9PE1wjU-SYW5Yy6*m7;4h zFKR72 + + + + + + + + + + + PascalScript_Core_D9.dpk + + + 7.0 + + + 8 + 0 + 1 + 1 + 0 + 0 + 1 + 1 + 1 + 0 + 0 + 1 + 0 + 1 + 1 + 1 + 0 + 0 + 0 + 0 + 0 + 1 + 0 + 1 + 1 + 1 + True + True + + + False + + False + False + False + False + False + False + False + False + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + False + False + False + True + True + True + + + 0 + 0 + 1 + False + False + False + 16384 + 1048576 + 4194304 + RemObjects Pascal Script - Core Package + + + + ..\Dcu\D9 + ..\Dcu\D9 + + ..\Dcu\D9;$(BDS)\lib\Indy9;..\..\RemObjects SDK for Dephi\Dcu\D9 + + + + False + + + + + + False + + + + + + False + + + + $00000000 + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + RemObjects Software + + 1.0.0.0 + + RemObjects Software + RemObjects Software + + RemObjects Pascal Script + 1.0.0.0 + + + diff --git a/Source/PascalScript_Core_D9.cfg b/Source/PascalScript_Core_D9.cfg new file mode 100644 index 0000000..8cb1eee --- /dev/null +++ b/Source/PascalScript_Core_D9.cfg @@ -0,0 +1,47 @@ +-$A8 +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J- +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q- +-$R- +-$S- +-$T- +-$U- +-$V+ +-$W+ +-$X+ +-$YD +-$Z1 +-cg +-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 +-N"..\Dcu\D9" +-LE"..\Dcu\D9" +-LN"..\Dcu\D9" +-w-SYMBOL_DEPRECATED +-w-SYMBOL_LIBRARY +-w-SYMBOL_PLATFORM +-w-SYMBOL_EXPERIMENTAL +-w-UNIT_LIBRARY +-w-UNIT_PLATFORM +-w-UNIT_DEPRECATED +-w-UNIT_EXPERIMENTAL +-w-UNSAFE_TYPE +-w-UNSAFE_CODE +-w-UNSAFE_CAST diff --git a/Source/PascalScript_Core_D9.dpk b/Source/PascalScript_Core_D9.dpk new file mode 100644 index 0000000..52627fe --- /dev/null +++ b/Source/PascalScript_Core_D9.dpk @@ -0,0 +1,76 @@ +package PascalScript_Core_D9; + +{$R *.res} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'RemObjects Pascal Script - Core Package'} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + rtl, + vcl, + dbrtl; + +contains + uPSC_extctrls in 'uPSC_extctrls.pas', + uPSC_forms in 'uPSC_forms.pas', + uPSC_graphics in 'uPSC_graphics.pas', + uPSC_menus in 'uPSC_menus.pas', + uPSC_std in 'uPSC_std.pas', + uPSC_stdctrls in 'uPSC_stdctrls.pas', + uPSCompiler in 'uPSCompiler.pas', + uPSComponent in 'uPSComponent.pas', + uPSComponent_COM in 'uPSComponent_COM.pas', + uPSComponent_Controls in 'uPSComponent_Controls.pas', + uPSComponent_DB in 'uPSComponent_DB.pas', + uPSComponent_Default in 'uPSComponent_Default.pas', + uPSComponent_Forms in 'uPSComponent_Forms.pas', + uPSComponent_StdCtrls in 'uPSComponent_StdCtrls.pas', + uPSDebugger in 'uPSDebugger.pas', + uPSDisassembly in 'uPSDisassembly.pas', + uPSPreProcessor in 'uPSPreProcessor.pas', + uPSR_buttons in 'uPSR_buttons.pas', + uPSR_classes in 'uPSR_classes.pas', + uPSR_comobj in 'uPSR_comobj.pas', + uPSR_controls in 'uPSR_controls.pas', + uPSR_dateutils in 'uPSR_dateutils.pas', + uPSR_DB in 'uPSR_DB.pas', + uPSR_dll in 'uPSR_dll.pas', + uPSR_extctrls in 'uPSR_extctrls.pas', + uPSR_forms in 'uPSR_forms.pas', + uPSR_graphics in 'uPSR_graphics.pas', + uPSR_menus in 'uPSR_menus.pas', + uPSR_std in 'uPSR_std.pas', + uPSR_stdctrls in 'uPSR_stdctrls.pas', + uPSRuntime in 'uPSRuntime.pas', + uPSUtils in 'uPSUtils.pas', + uPSC_buttons in 'uPSC_buttons.pas', + uPSC_classes in 'uPSC_classes.pas', + uPSC_comobj in 'uPSC_comobj.pas', + uPSC_controls in 'uPSC_controls.pas', + uPSC_dateutils in 'uPSC_dateutils.pas', + uPSC_DB in 'uPSC_DB.pas', + uPSC_dll in 'uPSC_dll.pas', + PascalScript_Core_Reg in 'PascalScript_Core_Reg.pas'; + +end. diff --git a/Source/PascalScript_Core_D9.res b/Source/PascalScript_Core_D9.res new file mode 100644 index 0000000000000000000000000000000000000000..895c7e180bbfa04d39922271c1bc35cdeb74eaf0 GIT binary patch literal 620 zcmZXS!A`En zrh@vKd7by>&Ye5cN|KMwW~Jf&T0yOfuYp-|u~2od0tK}QH&IVl?5DcGYpbgc=QjHp zzO8rf^GmY)Wo={C``CgkkEdiW&$hq0i=L*+HB_cM*oJ!40Om}$8iToam{5^I9bgd} zOi@eg@ST7eX`&STD{4|s1EWUg0KcniJ>d1JQOHO87~ZK~K;{m4q*ZugPGjBZ$srec zVvq&5DY`7b@3cU!v*I|G$6g8-EsYCjVh(Y>khwF8$$8fdW@`poi>+daHk=hSGrN(mhKkGlC+ XkT&^#(j`%wb-^^Odex=)V?MlZP|Q@- literal 0 HcmV?d00001 diff --git a/Source/PascalScript_Core_Glyphs.rc b/Source/PascalScript_Core_Glyphs.rc new file mode 100644 index 0000000..8249fdf --- /dev/null +++ b/Source/PascalScript_Core_Glyphs.rc @@ -0,0 +1,14 @@ +TPSScript BITMAP DISCARDABLE "Glyphs\TPSScript.bmp" +TPSScriptDebugger BITMAP DISCARDABLE "Glyphs\TPSScriptDebugger.bmp" +TPSDllPlugin BITMAP DISCARDABLE "Glyphs\TPSDllPlugin.bmp" + +TPSImport_Classes BITMAP DISCARDABLE "Glyphs\TPSImport_Classes.bmp" +TPSImport_ComObj BITMAP DISCARDABLE "Glyphs\TPSImport_ComObj.bmp" +TPSImport_Controls BITMAP DISCARDABLE "Glyphs\TPSImport_Controls.bmp" +TPSImport_DateUtils BITMAP DISCARDABLE "Glyphs\TPSImport_DateUtils.bmp" +TPSImport_DB BITMAP DISCARDABLE "Glyphs\TPSImport_DB.bmp" +TPSImport_Forms BITMAP DISCARDABLE "Glyphs\TPSImport_Forms.bmp" +TPSImport_StdCtrls BITMAP DISCARDABLE "Glyphs\TPSImport_StdCtrls.bmp" + + + diff --git a/Source/PascalScript_Core_Glyphs.res b/Source/PascalScript_Core_Glyphs.res new file mode 100644 index 0000000000000000000000000000000000000000..581361ffbd1a728ed0ed4dbb181e1d5cde89d4d9 GIT binary patch literal 18328 zcmeI3dr(wIzQ-F-6O6>yYFJ|=h9qL5H^y8|HhK-HU=R=$d?XsRj4w#yT8T;2shLr< zRD_F&g@VOHF9^lMLQ;sV!15>_#iIZVDPRgIkRS_`zy(Vzu%_?#%x~x%W`>7J+&^y7 zHfQ_%=GUL|?ceF?UwY12#u$4Of1J}FnuE%}CNQ=L7S7F?CtJ@v@NX5{$ehvk)O#+P zGJV`YCp$E(^?zo%7Gv39On-&`2K+d~1xHojIZU-5UBQ(;9HI~$7(P;g4>)J`?lG<> zckc!sDB{44U}(roc3n2?#7R>eGp-;TaHxx18Z2NwFNb6hjR>&NDe3uTbb4@IAwUpF z9&r*C3S*SGSQH(2AsQ@Zjskki@X27BA4s|3w`1D`(_X%}t043+ZZNvgdQCga& zv?S|)t|llHHeYnii)~?`EqVfPFGh~Sy@?( zj?>lIaY3yfj5?O2P@Ec=KcuIlqeG+76ciNPOiD_KkB^9mfHsJ%sHljEiGiN3&Q3qI zDp0KsR;faj%1D(mN~wrb96P>uFU>>Z;L?qajb){!si~=jg@sxF{AXxLNK;c2P-oAc z1qbDnT76EfILd?S+zPqtva-SzX1n#1gJWVrlzK* zs;UaY3JVGluGl&Q8P`sP3*VRGdC~^aytiw;m|WMw;!{ zqoWb4;NW1y%2$UvFqng}pf6M*P>&x!#u3^G2yKX4V?#r2Z7o8FyHHYGj2n@kpP!qX zE9YP;Zg`&J;o%{7NB2LmN_o*sL*2r4q-qE4t0?$5ot=VXL~z7wfAeb zKi7zcp5|W6-t>@jNCnY|01KV!IXinK&iP07eh+`+K%Pq$`%oqH;3FYG5MV^nbN1-k zL67YNJJDhu_wM$pc(-potR06V{J#2eB+uF!B)w0FM5$a*`WMZBM)5b5C zA4=gfk4h-2<_9?2!`ZGU?5hsUD4Igx43j4v&)h>uFBS2tW!xi*+nwRF)qKuzKK%%{ z0L{I4@uHQ2gB1?z*-&|MQ&25beHqJrbNIh4PulFojATy@TZI_lS8iv7lk; z2@P9cDt$XJXWWaI9!^Kf9m|trc@p#a|7V{3M7LZG-X3A$^{?UebJbIipD zb@GX1`=YL|>-mn7HjAB?toH@j?NjC}T_jX>I8fJDz8bg6ve)M&es)5K&r}g=pxD;H zar;B37ilLKYUh?|msDz9YqfhDxVo8NY3HD2e(xZ0B-9n2_XAII;#cN^BZo+wZ5J)} zgxKYFO)b=-+LmcQzNcMRtKHwgPdt=3^-%})9H6Q~ceE!;m##p z3oEo%DXp+reChvsQ1*I_*1LhvKN1}5{8ohh)I^7I1bmoy2n5vdB^LU~NRY5seu~+h zR)tG%)Nnu~g}PY1mt5ze;a^sCLDIH`)*U~vh~*O@OfExk#+}RYx>I$hn zgD+68g%+-;(r&8b2OFi)`M=A87qH-^lc}%#$UOWkPNdKFy%kv122^av0LR70d|%kK zxVrZ$wDwh6K;*qlwxwwJJSu<(Dz3Kx>wEsw?<=pXTvZ4aIh*SI~o9I*mqME_wNNW&k548tG(BjbIfGjl_BbjPmI zlkLQBt**>L_p7TTj#U2Ld6KzcCg>C0Xcjs6NDJ^l7is`9HQH97;A6bd8d!)Ux`2cB zyey|#H$D_7;z*a%6$+3z%JY)w0*HP6p@sP#wyE~k3I9QM!J#g4B_d6k)U%@Q??6En z=@cB&Kr|x2LZ`$rjt@{`uz~|6LVzHUJd+%=O%{NdZy85?!7-@^Mxab`#_zUdP7E|T zM;;dAHgTkBit3^}Qe&_lxQ$puaM%)Q(S;0~Yk&J7(^KdX4x)jNpxNT6Z( z`3xtHF~VXj1{^>p1X@7}i2(-?R6uM}K1DC%YRrKJsA)cP34-823@XIDmAc}c^i>P; z-4|xL&r5QIkMVE}fN-!nVhsq1p%LM(p(0TD2o57ch)K5$!(QvhS!(iMau5jc4mB~(K=`IZa^`ElFJmRwn-@HG~&1SZs!OeJ~HL$=3oGdr9 z3}=?<%CcNp&N^1KfdzePxo!YO9Joy|J-fKO$nRF)gN}K=TfCVRuU3|EFYV@`@$B&H=nkQ0znQZ`yW z$qjr~m)@7@^W^5Yk8dCCjN9LI!BL}JQ11QLyseg*Zf3aed+lb3?$n?~m$DO9@n{E& z%A<>()ucRY$mz}Tf0A{!BYH=3fJ5E!#pU15&ilf$Xro!cClfc@&XRLX=E+F=@fAlu zd|DFutTF%T-MFqhr`zJcZ3_QFb7ooD-l>7hEWfs!DTiPaR2a8`kr&swpH{Uq= zC_SJhSydJ2nX=1Py>#mC!4Lq!89q;5v41Jj$trTqlwgO+mp_~6|F?;98S*wzV|h{@ zkYU=0)mWaS_(*wjwQji@_`TI|Kk1HNTs^V7bjQweU`P3)b0xGL*|z-~4-Zu1`#73~ z4n7zax~D}&RcB=t`1>2v;A6bl8d!)^bThdoKfj}{?q1Bb?7)-deuHSlp*0`f(U2E; zZmP^LuPG|&)YQdAp8`iz(k3|6MXp4oD$)Z^ZAn>Mt)?O-T0p1)l;DsIq7eZWIu)F{ zihFH!4Gq_C4&wNnl5?O$2oMC4C+D=(+^>v^O$<;86d<^L!|MSMC^@I8va;Z6q<|Fq z13i~KK< z7~^RP3l-kDkkI>S@1P6 z$uY>4@;xQ|sV^Ou-93Q%JNA^=R$|9#9lQWLuum%YIMjWQjg+w%Scb}#v;)IVZeGUc z3-dNEso1f+#(SvUHaNrQO4<$rvZQ#Yd{1v2WT3`!rEyqHS`e$TTuG4`DOaw>FRz|> ze`gbp&a!OzV)vDc7cX{jaQJTjE>z zY+h-)o7*Lu)?V(2y5-Zh{`I4s`ac z@7B$mZEWW5*|m*#H}H;{@4o#;aHz|`6{Y_bsY>V}PI`J~cV`EG)(cc;Q}wgfiK-j%|PiAHY*Y@@Iw8=Rp z^}qpa1!+ z*yz5QPjVs;*n=UE-be-t<}%^uXBEeYfowWzpigH;27seIOs=F@@!jO?~bhM z$w#l7{}2niyo#})VKP6$S&Ty2r&V-4aV%~yKM?Y~dr5E%MzOoD1$utRUeb6JV|z)= zqOs?b^2z+i+fsg9u3N55|L*Ffd!xrq{Nnmzb7cBTHcTCHbt4DeX!>|x8}F> zjcac3+BjYl%iD6nhucs~t+2yK;ymfpc0J&2ceM}lw3-xc<#laYn6@~WYZ3%UcR8sa z8uB8~NnG2{pLX-^X5L=KoAP;GD!&)U%ffhFqMSorga$N3iqh+mKGX8P$GoRS+g`() zi?sLCv{muE@s^xJGKfY5Sm;#7(V_aEXo2de*jxd{S(6}CkeKDwp<8<@G(2cE;TZsd=5lgzm zaFfvFSB}yfESV%97!BW(sPc;AV&(0iE#~# z2oW$41B<~P5}e;LB5;iNkk30J(gxJn9@5}84RwlGjqM>RI3xYu>Ve-`SL2OW>FMOy zvq|aMWO+!??|wE}5ECh$O|rf0!G*BeprGpW=jkaCR&T6A2FZxlC4*d<^V5HcXOrLr z`R%U{yiyf-p*H9OP=aGJH_3Bl_ED#rlyG`BxzpDXsMLVt(v!UBd^VY_bg8`+E}l(- zgL)xgAH-mq4X;O@EAy0}<5?*^n)5kNT8imEZ^qttrDzO)L + + + + + + + + + + + PascalScript_RO_D10.dpk + + + 7.0 + + + 8 + 0 + 1 + 1 + 0 + 0 + 1 + 1 + 1 + 0 + 0 + 1 + 0 + 1 + 1 + 1 + 0 + 0 + 0 + 0 + 0 + 1 + 1 + 1 + 1 + 1 + True + True + + + False + + False + False + False + False + False + False + False + False + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + False + False + False + True + True + True True + True + + + + 0 + 0 + 1 + False + False + False + 16384 + 1048576 + 4194304 + RemObjects Pascal Script - RemObjects SDK 3.0 Integration False + + + + ..\Dcu\D9 + ..\Dcu\D9 + + ..\Dcu\D9;$(BDS)\lib\Indy9;..\..\RemObjects SDK for Dephi\Dcu\D9 + + + + False + + + + + + False + + + + + + False + True + False + + + + $00000000 + + + + True + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 1033 + 1252 + + + RemObjects Software + + 0.0.0.0 + + + + + Pascal Script + 3.0.0.0 + Monday, December 19, 2005 4:43 PM + + diff --git a/Source/PascalScript_RO_D10.cfg b/Source/PascalScript_RO_D10.cfg new file mode 100644 index 0000000..e163a8f --- /dev/null +++ b/Source/PascalScript_RO_D10.cfg @@ -0,0 +1,51 @@ +-$A8 +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J- +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q- +-$R- +-$S- +-$T- +-$U- +-$V+ +-$W+ +-$X+ +-$YD +-$Z1 +-cg +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 +-N0"..\Dcu\D9" +-LE"..\Dcu\D9" +-LN"\\Lucien\personal\mh\My Documents\Borland Studio Projects\Bpl" +-U"..\Dcu\D9;c:\program files\borland\bds\4.0\lib\Indy9;..\..\RemObjects SDK for Dephi\Dcu\D9" +-O"..\Dcu\D9;c:\program files\borland\bds\4.0\lib\Indy9;..\..\RemObjects SDK for Dephi\Dcu\D9" +-I"..\Dcu\D9;c:\program files\borland\bds\4.0\lib\Indy9;..\..\RemObjects SDK for Dephi\Dcu\D9" +-R"..\Dcu\D9;c:\program files\borland\bds\4.0\lib\Indy9;..\..\RemObjects SDK for Dephi\Dcu\D9" +-Z +-w-SYMBOL_DEPRECATED +-w-SYMBOL_LIBRARY +-w-SYMBOL_PLATFORM +-w-SYMBOL_EXPERIMENTAL +-w-UNIT_LIBRARY +-w-UNIT_PLATFORM +-w-UNIT_DEPRECATED +-w-UNIT_EXPERIMENTAL +-w-UNSAFE_TYPE +-w-UNSAFE_CODE +-w-UNSAFE_CAST diff --git a/Source/PascalScript_RO_D10.dpk b/Source/PascalScript_RO_D10.dpk new file mode 100644 index 0000000..a66e75b --- /dev/null +++ b/Source/PascalScript_RO_D10.dpk @@ -0,0 +1,45 @@ +package PascalScript_RO_D10; + +{$R *.res} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'RemObjects Pascal Script - RemObjects SDK 3.0 Integration'} +{$IMPLICITBUILD OFF} + +requires + rtl, + IndySystem, + IndyCore, + IndyProtocols, + PascalScript_Core_D10, + RemObjects_Core_D10, + RemObjects_Indy_D10, + dbrtl, + vcl, + vclx; + +contains + PascalScript_RO_Reg in 'PascalScript_RO_Reg.pas', + uROPSServerLink in 'uROPSServerLink.pas', + uROPSImports in 'uROPSImports.pas'; + +end. diff --git a/Source/PascalScript_RO_D10.res b/Source/PascalScript_RO_D10.res new file mode 100644 index 0000000000000000000000000000000000000000..c3408319a9ee865c8bdf00438d00c05edbe2a4c1 GIT binary patch literal 616 zcmZXS!AiqG5QcwC4tfy}K0pu;J%~gb4~pQyDE3edt@J8sQzc@Pl0>9$;7j>7-hBh> zx0^0jyD+=6nScKIXEu`LV~a&&xPMl=<>EVFHf$`=mghk2R){;)Ko9I!>f?2Fr(5n_ z_G^5zKD@7QsmZq=mfOYh^yIBY-z|KgTBS1OdV(#}izYDVdQ?GfYB7OA1v7&>I=&+G)K-7b z)=9a~b%4Uic58YcStY)Xn45_l!x!iTFVq>qGrw& OlQ7j?hvIMf^nL&=WK-n; literal 0 HcmV?d00001 diff --git a/Source/PascalScript_RO_D6.dof b/Source/PascalScript_RO_D6.dof new file mode 100644 index 0000000..0706699 --- /dev/null +++ b/Source/PascalScript_RO_D6.dof @@ -0,0 +1,114 @@ +[FileVersion] +Version=6.0 + +[Compiler] +A=8 +B=0 +C=1 +D=1 +E=0 +F=0 +G=1 +H=1 +I=1 +J=0 +K=0 +L=1 +M=0 +N=1 +O=1 +P=1 +Q=0 +R=0 +S=0 +T=0 +U=0 +V=1 +W=1 +X=1 +Y=1 +Z=1 +ShowHints=1 +ShowWarnings=1 +UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +NamespacePrefix= +SymbolDeprecated=0 +SymbolLibrary=0 +SymbolPlatform=0 +UnitLibrary=0 +UnitPlatform=0 +UnitDeprecated=0 +HResultCompat=1 +HidingMember=1 +HiddenVirtual=1 +Garbage=1 +BoundsError=1 +ZeroNilCompat=1 +StringConstTruncated=1 +ForLoopVarVarPar=1 +TypedConstVarPar=1 +AsgToTypedConst=1 +CaseLabelRange=1 +ForVariable=1 +ConstructingAbstract=1 +ComparisonFalse=1 +ComparisonTrue=1 +ComparingSignedUnsigned=1 +CombiningSignedUnsigned=1 +UnsupportedConstruct=1 +FileOpen=1 +FileOpenUnitSrc=1 +BadGlobalSymbol=1 +DuplicateConstructorDestructor=1 +InvalidDirective=1 +PackageNoLink=1 +PackageThreadVar=1 +ImplicitImport=1 +HPPEMITIgnored=1 +NoRetVal=1 +UseBeforeDef=1 +ForLoopVarUndef=1 +UnitNameMismatch=1 +NoCFGFileFound=1 +MessageDirective=1 +ImplicitVariants=1 +UnicodeToLocale=1 +LocaleToUnicode=1 +ImagebaseMultiple=1 +SuspiciousTypecast=1 +PrivatePropAccessor=1 +UnsafeType=0 +UnsafeCode=0 +UnsafeCast=0 + +[Linker] +MapFile=0 +OutputObjs=0 +ConsoleApp=1 +DebugInfo=0 +RemoteSymbols=0 +MinStackSize=16384 +MaxStackSize=1048576 +ImageBase=4194304 +ExeDescription=RemObjects Pascal Script - RemObjects SDK 3.0 Integration + +[Directories] +UnitOutputDir=..\Dcu\D6 +PackageDLLOutputDir=..\Dcu\D6 +PackageDCPOutputDir= +SearchPath=..\Dcu\D6 +Conditionals= +DebugSourceDirs= +UsePackages=0 + +[Version Info Keys] +CompanyName=RemObjects Software +InternalName= +LegalCopyright= +LegalTrademarks= +ProductName=Pascal Script +ProductVersion=3.0.0.0 +FileDescription= +FileVersion=3.0.2.36 +OriginalFilename= + diff --git a/Source/PascalScript_RO_D6.dpk b/Source/PascalScript_RO_D6.dpk new file mode 100644 index 0000000..8af9676 --- /dev/null +++ b/Source/PascalScript_RO_D6.dpk @@ -0,0 +1,43 @@ +package PascalScript_RO_D6; + +{$R *.res} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'RemObjects Pascal Script - RemObjects SDK 3.0 Integration'} +{$IMPLICITBUILD OFF} + +requires + rtl, + indy, + PascalScript_Core_D6, + RemObjects_Core_D6, + RemObjects_Indy_D6, + dbrtl, + vcl, + vclx; + +contains + PascalScript_RO_Reg in 'PascalScript_RO_Reg.pas', + uROPSServerLink in 'uROPSServerLink.pas', + uROPSImports in 'uROPSImports.pas'; + +end. diff --git a/Source/PascalScript_RO_D6.res b/Source/PascalScript_RO_D6.res new file mode 100644 index 0000000000000000000000000000000000000000..30e80177e8b672a3d17f5eff5e43be63986d201b GIT binary patch literal 616 zcmZXS!AiqG5Qcwi4)!7*yqklE9z;r71w|0CN_)@-D>*7@jS|tcq!IB2d@J9^yKi9q zW@BvC4YQfu`RCt%W>=DYY&I(m_t$9Ds`wh1B^PU|?p2^ht&JOLpljw6UEuZ9*E#DR z^C`ZKH}B(9vixOj3exZYp#>QpU&&ssZGLqd0~N}ZD$^ZosUDQToat6$FhhrFs;#E> zur?Y@QCI8m9fNt)L^1dm)Wob3qef?f-`7z0cq7i3%18Sc-a^kHbB8?8Dm)>pv2OI_ zkc&Ja$SJ!qx-5U>v`*jyk{l+ABI W+^0Qfn) literal 0 HcmV?d00001 diff --git a/Source/PascalScript_RO_D7.cfg b/Source/PascalScript_RO_D7.cfg new file mode 100644 index 0000000..80106f5 --- /dev/null +++ b/Source/PascalScript_RO_D7.cfg @@ -0,0 +1,50 @@ +-$A8 +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J- +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q- +-$R- +-$S- +-$T- +-$U- +-$V+ +-$W+ +-$X+ +-$YD +-$Z1 +-cg +-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 +-N"..\Dcu\D7" +-LE"..\Dcu\D7" +-LN"c:\program files\borland\delphi7\Projects\Bpl" +-U"..\Dcu\D7" +-O"..\Dcu\D7" +-I"..\Dcu\D7" +-R"..\Dcu\D7" +-Z +-w-SYMBOL_DEPRECATED +-w-SYMBOL_LIBRARY +-w-SYMBOL_PLATFORM +-w-UNIT_LIBRARY +-w-UNIT_PLATFORM +-w-UNIT_DEPRECATED +-w-UNSAFE_TYPE +-w-UNSAFE_CODE +-w-UNSAFE_CAST diff --git a/Source/PascalScript_RO_D7.dof b/Source/PascalScript_RO_D7.dof new file mode 100644 index 0000000..9611383 --- /dev/null +++ b/Source/PascalScript_RO_D7.dof @@ -0,0 +1,130 @@ +[FileVersion] +Version=7.0 + +[Compiler] +A=8 +B=0 +C=1 +D=1 +E=0 +F=0 +G=1 +H=1 +I=1 +J=0 +K=0 +L=1 +M=0 +N=1 +O=1 +P=1 +Q=0 +R=0 +S=0 +T=0 +U=0 +V=1 +W=1 +X=1 +Y=1 +Z=1 +ShowHints=1 +ShowWarnings=1 +UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +NamespacePrefix= +SymbolDeprecated=0 +SymbolLibrary=0 +SymbolPlatform=0 +UnitLibrary=0 +UnitPlatform=0 +UnitDeprecated=0 +HResultCompat=1 +HidingMember=1 +HiddenVirtual=1 +Garbage=1 +BoundsError=1 +ZeroNilCompat=1 +StringConstTruncated=1 +ForLoopVarVarPar=1 +TypedConstVarPar=1 +AsgToTypedConst=1 +CaseLabelRange=1 +ForVariable=1 +ConstructingAbstract=1 +ComparisonFalse=1 +ComparisonTrue=1 +ComparingSignedUnsigned=1 +CombiningSignedUnsigned=1 +UnsupportedConstruct=1 +FileOpen=1 +FileOpenUnitSrc=1 +BadGlobalSymbol=1 +DuplicateConstructorDestructor=1 +InvalidDirective=1 +PackageNoLink=1 +PackageThreadVar=1 +ImplicitImport=1 +HPPEMITIgnored=1 +NoRetVal=1 +UseBeforeDef=1 +ForLoopVarUndef=1 +UnitNameMismatch=1 +NoCFGFileFound=1 +MessageDirective=1 +ImplicitVariants=1 +UnicodeToLocale=1 +LocaleToUnicode=1 +ImagebaseMultiple=1 +SuspiciousTypecast=1 +PrivatePropAccessor=1 +UnsafeType=0 +UnsafeCode=0 +UnsafeCast=0 + +[Linker] +MapFile=0 +OutputObjs=0 +ConsoleApp=1 +DebugInfo=0 +RemoteSymbols=0 +MinStackSize=16384 +MaxStackSize=1048576 +ImageBase=4194304 +ExeDescription=RemObjects Pascal Script - RemObjects SDK 3.0 Integration + +[Directories] +OutputDir= +UnitOutputDir=..\Dcu\D7 +PackageDLLOutputDir=..\Dcu\D7 +PackageDCPOutputDir= +SearchPath=..\Dcu\D7 +Packages= +Conditionals= +DebugSourceDirs= +UsePackages=0 + + +[Version Info] +MajorVer=3 +MinorVer=0 +Release=3 +Build=43 +AutoIncBuild=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1033 +CodePage=1252 +[Version Info Keys] +CompanyName=RemObjects Software +InternalName= +LegalCopyright= +LegalTrademarks= +ProductName=Pascal Script +ProductVersion=3.0.0.0 +FileDescription= +FileVersion=3.0.3.43 +OriginalFilename= +Compile Date=Friday, July 02, 2004 6:59 PM diff --git a/Source/PascalScript_RO_D7.dpk b/Source/PascalScript_RO_D7.dpk new file mode 100644 index 0000000..4e2301a --- /dev/null +++ b/Source/PascalScript_RO_D7.dpk @@ -0,0 +1,43 @@ +package PascalScript_RO_D7; + +{$R *.res} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'RemObjects Pascal Script - RemObjects SDK 3.0 Integration'} +{$IMPLICITBUILD OFF} + +requires + rtl, + indy, + PascalScript_Core_D7, + RemObjects_Core_D7, + RemObjects_Indy_D7, + dbrtl, + vcl, + vclx; + +contains + PascalScript_RO_Reg in 'PascalScript_RO_Reg.pas', + uROPSServerLink in 'uROPSServerLink.pas', + uROPSImports in 'uROPSImports.pas'; + +end. diff --git a/Source/PascalScript_RO_D7.res b/Source/PascalScript_RO_D7.res new file mode 100644 index 0000000000000000000000000000000000000000..e33923009ed71c1317434d2fce44597ae1e555ef GIT binary patch literal 612 zcmZXSK}*9x5QU#L2YV3@o+XFe6bUg3ir~Rote`DcauPJQQ6e=dX+(PO-}2vh_a9il z-4I)K!)#`D-n@M?i6pt$d|nyuujMuB{05j6oAcFlYLM3maU=D0$9|@3ypFoMBJQxa z@y&X7KEEVWzp8DlexH~m%i*cmtJv%_d(c;@La8!6!Io;I1m;YS%E8=QjIU6>4zUmo zM$x%8;X4KMqOoG|Q`E#niJ?Ykg5TAHp793UF_DY*9NtoIAPb8;);c^rqFh70TI4cM z59EZ?7+t1*V6~3n5IWZW)kd%uRHX1_VD_|&>e{40O={{s|DqRoQx{Tg)~&XddaWkp zs)eS~_RzMPhQw3tpz?w~M))o_2lgbuGqZDbpd;-wNtd24;cnR*B5I2tRg39M9^Xy6 SA!}wlf!EwxcPIXo59b>Zky7sf literal 0 HcmV?d00001 diff --git a/Source/PascalScript_RO_D9.bdsproj b/Source/PascalScript_RO_D9.bdsproj new file mode 100644 index 0000000..257cfc7 --- /dev/null +++ b/Source/PascalScript_RO_D9.bdsproj @@ -0,0 +1,172 @@ + + + + + + + + + + + + PascalScript_RO_D9.dpk + + + 7.0 + + + 8 + 0 + 1 + 1 + 0 + 0 + 1 + 1 + 1 + 0 + 0 + 1 + 0 + 1 + 1 + 1 + 0 + 0 + 0 + 0 + 0 + 1 + 1 + 1 + 1 + 1 + True + True + + + False + + False + False + False + False + False + False + False + False + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + False + False + False + True + True + True + + + 0 + 0 + 1 + False + False + False + 16384 + 1048576 + 4194304 + RemObjects Pascal Script - RemObjects SDK 3.0 Integration + + + + ..\Dcu\D9 + ..\Dcu\D9 + + ..\Dcu\D9;$(BDS)\lib\Indy9;..\..\RemObjects SDK for Dephi\Dcu\D9 + + + + False + + + + + + False + + + + + + False + + + + $00000000 + + + + True + False + 3 + 0 + 3 + 51 + False + False + False + False + False + 1033 + 1252 + + + RemObjects Software + + 3.0.3.51 + + + + + Pascal Script + 3.0.0.0 + Wednesday, November 24, 2004 7:40 PM + + diff --git a/Source/PascalScript_RO_D9.cfg b/Source/PascalScript_RO_D9.cfg new file mode 100644 index 0000000..755409b --- /dev/null +++ b/Source/PascalScript_RO_D9.cfg @@ -0,0 +1,51 @@ +-$A8 +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J- +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q- +-$R- +-$S- +-$T- +-$U- +-$V+ +-$W+ +-$X+ +-$YD +-$Z1 +-cg +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 +-N"..\Dcu\D9" +-LE"..\Dcu\D9" +-LN"\\Lucien\personal\mh\My Documents\Borland Studio Projects\Bpl" +-U"..\Dcu\D9;c:\program files\borland\bds\3.0\lib\Indy9;..\..\RemObjects SDK for Dephi\Dcu\D9" +-O"..\Dcu\D9;c:\program files\borland\bds\3.0\lib\Indy9;..\..\RemObjects SDK for Dephi\Dcu\D9" +-I"..\Dcu\D9;c:\program files\borland\bds\3.0\lib\Indy9;..\..\RemObjects SDK for Dephi\Dcu\D9" +-R"..\Dcu\D9;c:\program files\borland\bds\3.0\lib\Indy9;..\..\RemObjects SDK for Dephi\Dcu\D9" +-Z +-w-SYMBOL_DEPRECATED +-w-SYMBOL_LIBRARY +-w-SYMBOL_PLATFORM +-w-SYMBOL_EXPERIMENTAL +-w-UNIT_LIBRARY +-w-UNIT_PLATFORM +-w-UNIT_DEPRECATED +-w-UNIT_EXPERIMENTAL +-w-UNSAFE_TYPE +-w-UNSAFE_CODE +-w-UNSAFE_CAST diff --git a/Source/PascalScript_RO_D9.dpk b/Source/PascalScript_RO_D9.dpk new file mode 100644 index 0000000..51221cf --- /dev/null +++ b/Source/PascalScript_RO_D9.dpk @@ -0,0 +1,45 @@ +package PascalScript_RO_D9; + +{$R *.res} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'RemObjects Pascal Script - RemObjects SDK 3.0 Integration'} +{$IMPLICITBUILD OFF} + +requires + rtl, + IndySystem, + IndyCore, + IndyProtocols, + PascalScript_Core_D9, + RemObjects_Core_D9, + RemObjects_Indy_D9, + dbrtl, + vcl, + vclx; + +contains + PascalScript_RO_Reg in 'PascalScript_RO_Reg.pas', + uROPSServerLink in 'uROPSServerLink.pas', + uROPSImports in 'uROPSImports.pas'; + +end. diff --git a/Source/PascalScript_RO_D9.res b/Source/PascalScript_RO_D9.res new file mode 100644 index 0000000000000000000000000000000000000000..5d8dd7d6a8413db40bc2a3e2271f475ff57776d6 GIT binary patch literal 1472 zcmb7DO;1xn6g`C|l?~EB!_qD^abZjgCC{$}4M=1mP!S$Gf`A4iACJfDOv8d2LuL{e zBqjv^h;czo`cqiAaHl)p!Z@Bgj{<&dyzQNtJNL}FXJ+02K$-4b<{bWJU%EQ^Zensi z*VosR?|`mzP^RCf=WsgBHUG92z&~28tYga|y@htW&4h@M&Sf3jOqWd3lu|mJPgEF& zr=c=NsfFER<+GsxlnQr`_kjWfrHoY#wfi>kizPM+i&?yUZ&sRL0CD zjkzQWp)E5}$?TTi-%=_mSZh^cj5&(xVHO(|S&|%%=zvVtnxL9SCT<={UZ?g=95Ggh zO;%`VcMu0v8(Ic5y_ecJuBTOP53EhC-gB-rJYvHj)(J_?o=dCsVp>!q`ZZ(b(|Qou zD2{a`1jGkHF)a;8Itf1d*yxCuqV433iEO<(XzOvpg3dWZzM?k$feB0Wv}35rNFbcSFhsYP?`?9=$caZ3M2KcTlzy~SSqf33yOR=f>#i=R*^xi7QE z71kQ{&!XM!1^`s(&h_Fk9$*qv^f64c@7Tq6A+I5aayjo`g}kC1YG-e$@9ZsAaQ>ER zT{Tk8V-|~SAL0o|lfJ^DuQ$Q5*r)v0pTbAE7^ZjnQAyJB{ADjSi=}<%CuXsOZLDDf zFEGLW6;{c-f#=vHX2WADsBx#a={0H)MUOB*zA<9fv4th#o80vhqgA1%&Q*@5@eD6H zT4s$HWoq9f?+z4^+a7rjz2uo;w22iY9(j>xhRB$+OVlOnm%Y|4a)3H6{k3+UtlM0% zM!pSVhH;asI}Qw?hif|f{1bhSmvtkk%2v38YZvyKolqI$)U@OG5VBoiwN=(#;cOE( zsC9}88k}3_8HlDbYu9{ch>GMS%Ls6XeTAbLenDd6zMUt__L<7_+W@Ze9)YLK%9+PJ O6;aXIE%@bp&i?{aRdAXB literal 0 HcmV?d00001 diff --git a/Source/PascalScript_RO_Glyphs.RES b/Source/PascalScript_RO_Glyphs.RES new file mode 100644 index 0000000000000000000000000000000000000000..3fcd3550e0f3568651a154a90f97b3b3229b52c5 GIT binary patch literal 1876 zcma)*ZAepL6vv;U7orHmpeRHu11$z>HD8jgt8TJQr%q?4F-=x3)C}K{#>|&KsF`zy zC8CxTMpk4|B4)J0BEf`+Kte_RQWo?@D)Gaf{?}8NtCe2^|Hd&hi)A`ylo&x?8`k{3 z2|%*_*R^UPW6TY{_eQ#Y*Kr0h|7B*g8O4glh86N7|7UoTDai!J#MtCO-_!Qywo6sj z_OnG;kvM!M!=u0vw{YIt+8PlW3J10%FMkOKWduVaH}{wu>%`G$w2e*|2o;4T&T|f; z{mG#%a%orrlQ^hv@9b%Gb(EDj(#>fxDwPl#DnW2GJPVbQ2BHxGi*$>6bc6RL@E19= zgO$^-ZVWwlceb_{tM8W_e1M1-66zD;pKlhr% zjb9u1{4GA$EutW4D0TXFJUBL+jW`s6N=!^dgb|83u7>)HmHAiei`$w??{!rVJgOP# zw~zPd;9TI~Mby>Rp+%A;IwNtS^;zmDBP97m_F@#tj-{nL>=p3p^VJZE@vgU@#du>B z!68&y#z|v(Wm1aRv6%QXK8D$Cn%Uh#AKLDvd~+x)20e#ih9Lls^WtkoLZ3WwGP83v zxs%~GE?Ay{qe^b~OX52W;_HLsjMR2SUq#8Ly$`+iTnP*e+_hlDaXOvo(uth1*rIRX zz@sgXLypgYLry3NBNV9ugsi;0oH&T!z%uf#X^Xk~jEFjrExH`F^~guLDx!fbK`2=f z<*ywK5gbqz9FZjnTLO`zGHq3H1*3F8xhm=vrZh}-lsJEd$WiD#XvS0bqpib{neX8T u%&+m)U=nDq5SM|_U(|MbiI^+-Xwh7imX@vvkr!Y@(KJFK%HNB;jPjpm^*f&c literal 0 HcmV?d00001 diff --git a/Source/PascalScript_RO_Reg.pas b/Source/PascalScript_RO_Reg.pas new file mode 100644 index 0000000..1369293 --- /dev/null +++ b/Source/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/Source/ThirdParty/ROPS_EXTENDED.dpk b/Source/ThirdParty/ROPS_EXTENDED.dpk new file mode 100644 index 0000000..4a3e446 --- /dev/null +++ b/Source/ThirdParty/ROPS_EXTENDED.dpk @@ -0,0 +1,43 @@ +package ROPS_EXTENDED; + +{$R *.RES} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'Innerfuse Pascal Script 3 Extensions'} +{$IMPLICITBUILD ON} + +requires + JvCoreD5R, + JvSystemD5R, + JvNetD5R, + VCLIB50, + PascalScript_Core_D5; + +contains + uPSI_JvMail in 'uPSI_JvMail.pas', + uPSI_Registry in 'uPSI_Registry.pas', + uPSI_IBX in 'uPSI_IBX.pas', + uPS_ExtReg in 'uPS_ExtReg.pas', + uPSI_Mask in 'uPSI_Mask.pas', + uPSI_Dialogs in 'uPSI_Dialogs.pas'; + +end. diff --git a/Source/ThirdParty/uPSI_Dialogs.pas b/Source/ThirdParty/uPSI_Dialogs.pas new file mode 100644 index 0000000..d93f226 --- /dev/null +++ b/Source/ThirdParty/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/Source/ThirdParty/uPSI_IBX.pas b/Source/ThirdParty/uPSI_IBX.pas new file mode 100644 index 0000000..7d1836a --- /dev/null +++ b/Source/ThirdParty/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/Source/ThirdParty/uPSI_JvMail.pas b/Source/ThirdParty/uPSI_JvMail.pas new file mode 100644 index 0000000..bb79bbd --- /dev/null +++ b/Source/ThirdParty/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/Source/ThirdParty/uPSI_Mask.pas b/Source/ThirdParty/uPSI_Mask.pas new file mode 100644 index 0000000..b2bc080 --- /dev/null +++ b/Source/ThirdParty/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/Source/ThirdParty/uPSI_Registry.pas b/Source/ThirdParty/uPSI_Registry.pas new file mode 100644 index 0000000..538d44d --- /dev/null +++ b/Source/ThirdParty/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/Source/ThirdParty/uPS_ExtReg.pas b/Source/ThirdParty/uPS_ExtReg.pas new file mode 100644 index 0000000..b0dec7a --- /dev/null +++ b/Source/ThirdParty/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/Source/__Clean.bat b/Source/__Clean.bat new file mode 100644 index 0000000..495e744 --- /dev/null +++ b/Source/__Clean.bat @@ -0,0 +1,3 @@ +del *.bak +del *.dcu +del *.~* \ No newline at end of file diff --git a/Source/changelog.txt b/Source/changelog.txt new file mode 100644 index 0000000..336789d --- /dev/null +++ b/Source/changelog.txt @@ -0,0 +1,62 @@ +December 2004 + - Safecall + - UnloadDll function + - New package for non-db versions of delphi (Personal) + +November 2004: + - Assign for plugin collections. + - IDE demo changes + +November 2004; + - Allow overriding internal procs. + - Add importdecl to old style AddFunction ImportDecl. + +October 2004: + - New compiletime support functions + - getconst/getconstcount + - allow interface to be registered more than once and in any order + - widestring published properties support. + +August 2004: + - Fix. Var parameter types weren't always checked. + - fixes for CHAR consts. + - Eliminate "Comparing signed and unsigned types" warnings (on D5) (jr) + +2004-05-01 + - strtoint now throws an exception for invalid numbers. + - Compiler fix: Check var parameters. + - Docs update + - Fixes in the import tool + - Added a few new functions to make it earlier to add variable pointers to the script. + - Added a few new samples + - New Help system + + +2004-04-24: + - Changed unit names for RemObjects. +2004-01-13: + - Removed TIFPSInternalProcedure.exportmode and made it always use + emExportDecl + - RunProcP RunProcPN added + - Added Variant and PChar to the default to be exported type list + - function TIFPS3CompExec.ExecuteFunction(const Params: array of Variant; + const ProcName: string): Variant; + - Fix in ExportCheck + - Added source for Using_Innerfuse_Pascal_Script.pdf + - Updated docs +2004-01-14: + - Added CompExec.GetVarContents (for watches) + - Seperate Procedure Parameter reading code from using the actual header +2004-01-15: + - Added IDispatchInvoke scripted function + - Copyright Update +2004-01-16: + - Full IDispatch (dynamic) invoke support + + - Made IDispatch code work only on Variant types + - Fixes in IFPSVariantToString + + + +Todo: + - Com functions diff --git a/Source/eDefines.inc b/Source/eDefines.inc new file mode 100644 index 0000000..80efcee --- /dev/null +++ b/Source/eDefines.inc @@ -0,0 +1,359 @@ +(* +{----------------------------------------------------------------------------} +{file: eDefines.inc +{type: Delphi include file +{ +{compiler: Borland Pascal 7, +{ Delphi 1-7, Delphi 2005 for Win32 +{ Kylix 1-3, +{ C++Builder 1-5 (Pascal Only) +{ +{platforms: DOS, DPMI, Win16, Win32, Linux +{ +{author: mh@elitedev.com +{date: 8/3/1997, last changed: 7/2/2002 for Delphi 7 and Kylix 3 +{ +{contents: Defines that can be flexibily used to determine the exact +{ compiler version used. +{ +{(c)opyright elitedevelopments. 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 +{ 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 and above +{ DELPHI2005UP Delphi 2005 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 (any C++Builder) +{ 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 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 +{ DOTNET .NET +{ +{ LINUX any Linux platform +{ LINUX32 32bit Linux +{----------------------------------------------------------------------------} +*) +{ defines for Borland Pascal 7.0 } +{$IFDEF VER70} + {$DEFINE BP} + {$DEFINE BP7} + {$DEFINE 16BIT} + + { 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 } +{$IFNDEF LINUX} + + { defines for Delphi 1.0 } + {$IFDEF VER80} + {$DEFINE DELPHI} + {$DEFINE DELPHI1} + {$DEFINE DELPHI1UP} + {$DEFINE DELPHI_16BIT} + {$DEFINE WIN16} + {$DEFINE 16BIT} + {$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 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} + + {$IFDEF WIN32} + {$DEFINE MSWINDOWS} //not automatically defined for Delphi 2 thru 5 + {$DEFINE 32BIT} + {$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} + +{ defines for 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} diff --git a/Source/license.txt b/Source/license.txt new file mode 100644 index 0000000..37d3a3b --- /dev/null +++ b/Source/license.txt @@ -0,0 +1,29 @@ +********************************************************************* +RemObjects Pascal Script +Created By Carlo Kok ck@carlo-kok.com +********************************************************************* +Copyright (C) 2000-2004 by Carlo Kok, Innerfuse, RemObjects + +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 must have a visible line in your programs aboutbox or + documentation that it is made using RemObjects Pascal Script and + where RemObjects Pascal Script can be found. +4. This notice may not be removed or altered from any source + distribution. + +If you have any questions concerning this license write me (Carlo Kok): + ck@carlo-kok.com or try our newsserver: + news://news.RemObjects.com/ + +Carlo Kok +RemObjects Software + diff --git a/Source/pascalscript.lpk b/Source/pascalscript.lpk new file mode 100644 index 0000000..2587694 --- /dev/null +++ b/Source/pascalscript.lpk @@ -0,0 +1,246 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/Source/pascalscript.lrs b/Source/pascalscript.lrs new file mode 100644 index 0000000..7e88ff2 --- /dev/null +++ b/Source/pascalscript.lrs @@ -0,0 +1,1001 @@ +LazarusResources.Add('tpsdllplugin','XPM',[ + '/* XPM */'#10'static char *tpsdllplugin[] = {'#10'/* width height num_colors' + +' chars_per_pixel */'#10'" 24 24 256 2",'#10'/* colors' + +' */'#10'"`` c None",'#10'"`. c #824b00",'#10'"`# c #955c00",'#10'"`a c #e1a' + +'906",'#10'"`b c #cfb15c",'#10'"`c c #f8e9ab",'#10'"`d c #b67d02",'#10'"`e c' + +' #c19930",'#10'"`f c #c19d3a",'#10'"`g c #fff2ba",'#10'"`h c #fff2b7",'#10 + +'"`i c #e3c66a",'#10'"`j c #aa7909",'#10'"`k c #bf8b06",'#10'"`l c #fff2b8",' + +#10'"`m c #ffeb9a",'#10'"`n c #ffe16a",'#10'"`o c #fed53e",'#10'"`p c #fecb1' + +'9",'#10'"`q c #c99305",'#10'"`r c #ead590",'#10'"`s c #ffed9f",'#10'"`t c #' + +'ffe16e",'#10'"`u c #fed742",'#10'"`v c #fecb1c",'#10'"`w c #fec60c",'#10'"`' + +'x c #c58b03",'#10'"`y c #ad7e0c",'#10'"`z c #ead383",'#10'"`A c #9d6a03",' + +#10'"`B c #bc8b0d",'#10'"`C c #feca18",'#10'"`D c #d5a61a",'#10'"`E c #8b530' + +'0",'#10'"`F c #bb8103",'#10'"`G c #b5891c",'#10'"`H c #ffeea7",'#10'"`I c #' + +'9c6602",'#10'"`J c #dca912",'#10'"`K c #fed02a",'#10'"`L c #fed540",'#10'"`' + +'M c #965f03",'#10'"`N c #c18a04",'#10'"`O c #d5ba69",'#10'"`P c #ffefab",' + +#10'"`Q c #ffe57b",'#10'"`R c #895100",'#10'"`S c #c79917",'#10'"`T c #ffdc5' + +'5",'#10'"`U c #00268c",'#10'"`V c #002c95",'#10'"`W c #0f3695",'#10'"`X c #' + +'9c6401",'#10'"`Y c #a6760b",'#10'"`Z c #d5b862",'#10'"`0 c #ffe681",'#10'"`' + +'1 c #ffda52",'#10'"`2 c #dcb12a",'#10'"`3 c #ffda53",'#10'"`4 c #f0d05a",' + +#10'"`5 c #182d5b",'#10'"`6 c #0073ee",'#10'"`7 c #0a3c9e",'#10'"`8 c #a1d9f' + +'f",'#10'".` c #001f83",'#10'".. c #9d6401",'#10'".# c #9d6903",'#10'".a c #' + +'f0cb49",'#10'".b c #fed02d",'#10'".c c #e9b40d",'#10'".d c #8c5a03",'#10'".' + +'e c #c0921b",'#10'".f c #feda50",'#10'".g c #ffe06a",'#10'".h c #957829",' + +#10'".i c #224995",'#10'".j c #11409e",'#10'".k c #0441ac",'#10'".l c #6ea3d' + +'e",'#10'".m c #70ace6",'#10'".n c #03359d",'#10'".o c #935b00",'#10'".p c #' + +'986403",'#10'".q c #f0c228",'#10'".r c #fec711",'#10'".s c #fece23",'#10'".' + +'t c #fed437",'#10'".u c #fed94e",'#10'".v c #ffe067",'#10'".w c #98d5ff",' + +#10'".x c #6ec2ff",'#10'".y c #43adff",'#10'".z c #1e99ff",'#10'".A c #90580' + +'0",'#10'".B c #996704",'#10'".C c #fec913",'#10'".D c #fec70f",'#10'".E c #' + +'fece21",'#10'".F c #fed335",'#10'".G c #fed94c",'#10'".H c #ffe065",'#10'".' + +'I c #ffe57f",'#10'".J c #4172bd",'#10'".K c #9ad7ff",'#10'".L c #73c4ff",' + +#10'".M c #46afff",'#10'".N c #219aff",'#10'".O c #0688ff",'#10'".P c #844d0' + +'0",'#10'".Q c #8a5702",'#10'".R c #b1810f",'#10'".S c #f0c940",'#10'".T c #' + +'ffde63",'#10'".U c #eacb5e",'#10'".V c #8e6618",'#10'".W c #7d6628",'#10'".' + +'X c #4b7dc5",'#10'".Y c #9dd7ff",'#10'".Z c #00309a",'#10'".0 c #0e42a5",' + +#10'".1 c #0943a9",'#10'".2 c #0782f7",'#10'".3 c #1182ee",'#10'".4 c #40404' + +'0",'#10'".5 c #9ed8ff",'#10'".6 c #000d68",'#10'".7 c #002d96",'#10'".8 c #' + +'0242b0",'#10'"#` c #1392ff",'#10'"#. c #259dff",'#10'"## c #004bbc",'#10'"#' + +'a c #001e81",'#10'"#b c #ffffff",'#10'"#c c #000000",'#10'"#d c #80caff",' + +#10'"#e c #00004c",'#10'"#f c #000e69",'#10'"#g c #043aa3",'#10'"#h c #239cf' + +'f",'#10'"#i c #37a7ff",'#10'"#j c #4eb2ff",'#10'"#k c #c0dcc0",'#10'"#l c #' + +'56b7ff",'#10'"#m c #00095f",'#10'"#n c #001b7d",'#10'"#o c #0941a7",'#10'"#' + +'p c #35a6ff",'#10'"#q c #4cb1ff",'#10'"#r c #052b8c",'#10'"#s c #32a4ff",' + +#10'"#t c #0f88f7",'#10'"#u c #001f82",'#10'"#v c #012489",'#10'"#w c #2989e' + +'6",'#10'"#x c #49b1ff",'#10'"#y c #3882d5",'#10'"#z c #0386ff",'#10'"#A c #' + +'0d8eff",'#10'"#B c #177fe6",'#10'"#C c #47b0ff",'#10'"#D c #5fbbff",'#10'"#' + +'E c #0c8cff",'#10'"#F c #1c98ff",'#10'"#G c #2fa3ff",'#10'"#H c #45afff",' + +#10'"#I c #5dbaff",'#10'"#J c #76c6ff",'#10'"#K c #034fbd",'#10'"#L c #0645a' + +'d",'#10'"#M c #1f7dde",'#10'"#N c #5ab8ff",'#10'"#O c #022588",'#10'"#P c #' + +'51acf7",'#10'"#Q c #000000",'#10'"#R c #000000",'#10'"#S c #000000",'#10'"#' + +'T c #000000",'#10'"#U c #000000",'#10'"#V c #000000",'#10'"#W c #000000",' + +#10'"#X c #000000",'#10'"#Y c #000000",'#10'"#Z c #000000",'#10'"#0 c #00000' + +'0",'#10'"#1 c #000000",'#10'"#2 c #000000",'#10'"#3 c #000000",'#10'"#4 c #' + +'000000",'#10'"#5 c #000000",'#10'"#6 c #000000",'#10'"#7 c #000000",'#10'"#' + +'8 c #000000",'#10'"a` c #000000",'#10'"a. c #000000",'#10'"a# c #000000",' + +#10'"aa c #000000",'#10'"ab c #000000",'#10'"ac c #000000",'#10'"ad c #00000' + +'0",'#10'"ae c #000000",'#10'"af c #000000",'#10'"ag c #000000",'#10'"ah c #' + +'000000",'#10'"ai c #000000",'#10'"aj c #000000",'#10'"ak c #000000",'#10'"a' + +'l c #000000",'#10'"am c #000000",'#10'"an c #000000",'#10'"ao c #000000",' + +#10'"ap c #000000",'#10'"aq c #000000",'#10'"ar c #000000",'#10'"as c #00000' + +'0",'#10'"at c #000000",'#10'"au c #000000",'#10'"av c #000000",'#10'"aw c #' + +'000000",'#10'"ax c #000000",'#10'"ay c #000000",'#10'"az c #000000",'#10'"a' + +'A c #000000",'#10'"aB c #000000",'#10'"aC c #000000",'#10'"aD c #000000",' + +#10'"aE c #000000",'#10'"aF c #000000",'#10'"aG c #000000",'#10'"aH c #00000' + +'0",'#10'"aI c #000000",'#10'"aJ c #000000",'#10'"aK c #000000",'#10'"aL c #' + ,'000000",'#10'"aM c #000000",'#10'"aN c #000000",'#10'"aO c #000000",'#10'"a' + +'P c #000000",'#10'"aQ c #000000",'#10'"aR c #000000",'#10'"aS c #000000",' + +#10'"aT c #000000",'#10'"aU c #000000",'#10'"aV c #000000",'#10'"aW c #00000' + +'0",'#10'"aX c #000000",'#10'"aY c #000000",'#10'"aZ c #000000",'#10'"a0 c #' + +'000000",'#10'"a1 c #000000",'#10'"a2 c #000000",'#10'"a3 c #000000",'#10'"a' + +'4 c #000000",'#10'"a5 c #000000",'#10'"a6 c #000000",'#10'"a7 c #000000",' + +#10'"a8 c #000000",'#10'/* pixels */'#10'"``````````````````````````````````' + +'``````````````",'#10'"`````````````.`.`.``````````````````````````````",'#10 + +'"```````````#`a`b`c`.````````````````````````````",'#10'"`````d`.`.`e`f`g`h' + +'`i`.`.`j``````````````````````",'#10'"`````.`k`g`g`g`l`m`n`o`p`.```````````' + +'```````````",'#10'"`````.`q`r`g`l`s`t`u`v`w`.``````````````````````",'#10'"' + +'```.`x`y`c`g`z`.`A`B`w`C`D`.````````````````````",'#10'"`E`F`G`r`g`H`.```.`' + +'I`J`K`L`M````````````````````",'#10'"`.`N`O`g`P`Q`.```R`.`S`o`T`t`M`U`V`W``' + +'``````````",'#10'"`.`X`Y`Z`0`1`.```.`.`2`3`4`M`5`6`7`8.```````````",'#10'"`' + +'``....#.a.b.c`..d.e.f.g.h.i.j.k.l`8.m.`.`.n````",'#10'"````.o.p.q.r.r.s.t.u' + +'.v`0`M.l`8`8`8.w.x.y.z.`````",'#10'"````.A.B.C.D.E.F.G.H.I`m`M.J`8`8.K.L.M.' + +'N.O.`````",'#10'"````.P.Q`.`..R.S.T.U`M.V.W.X`8.Y.Z.0.1.2.O.3.```",'#10'".4' + +'.4.4.4.4.4.4.4.4.4.4.4.4`8.5.Z``.6.7.8#`#.###a",'#10'".4#b#b#b#b#b#b#b#b#b#' + +'b#b.4#c#d.Z``#e#f#g#h#i#j.`",'#10'".4#b#c#c#c#k#b#k#c#c#c#b.4#c#l.Z``#m#n#o' + +'#p#q###r",'#10'".4#b#c#b#k#c#b#c#k#b#b#b.4#c#s#t.Z#u#v#w#x#y.```",'#10'".4#' + +'b#c#c#c#k#b#k#c#c#k#b.4#c#`#z#A#B#s#C#D.`````",'#10'".4#b#c#k#b#b#b#b#b#k#c' + +'#b.4#c#z#E#F#G#H#I#J.`````",'#10'".4#b#c#b#b#c#c#c#c#c#k#b.4#c#K#L#M.y#N.`.' + +'`.`````",'#10'".4#b#b#b#b#b#b#b#b#b#b#b.4#c#a#a#O#P.```````````",'#10'".4.4' + +'.4.4.4.4.4.4.4.4.4.4.4#c``#a#a.`````````````",'#10'"``#c#c#c#c#c#c#c#c#c#c#' + +'c#c#c````````````````````"'#10'};'#10 +]); +LazarusResources.Add('tpsimport_classes','XPM',[ + '/* XPM */'#10'static char *tpsimport_classes[] = {'#10'/* width height num_c' + +'olors chars_per_pixel */'#10'" 24 24 256 2",'#10'/* c' + +'olors */'#10'"`` c None",'#10'"`. c #035501",'#10'"`# c #045702",'#10'"`a c' + +' #1b830f",'#10'"`b c #2daa18",'#10'"`c c #1d8b10",'#10'"`d c #014f00",'#10 + +'"`e c #0b6a05",'#10'"`f c #27a313",'#10'"`g c #29a615",'#10'"`h c #17970c",' + +#10'"`i c #18780d",'#10'"`j c #139309",'#10'"`k c #35af1c",'#10'"`l c #2f9f1' + +'a",'#10'"`m c #289516",'#10'"`n c #218212",'#10'"`o c #0d8d05",'#10'"`p c #' + +'1f9f10",'#10'"`q c #3eb622",'#10'"`r c #43bb25",'#10'"`s c #4fc52c",'#10'"`' + +'t c #4fbf2d",'#10'"`u c #45af27",'#10'"`v c #097903",'#10'"`w c #0d9006",' + +#10'"`x c #3ab41f",'#10'"`y c #820000",'#10'"`z c #2a8c17",'#10'"`A c #10900' + +'7",'#10'"`B c #f3552d",'#10'"`C c #ff6a36",'#10'"`D c #ff5827",'#10'"`E c #' + +'ff4615",'#10'"`F c #f42805",'#10'"`G c #13740a",'#10'"`H c #147b0a",'#10'"`' + +'I c #eb4924",'#10'"`J c #ff4e20",'#10'"`K c #ff380e",'#10'"`L c #ff2803",' + +#10'"`M c #e71600",'#10'"`N c #379c1f",'#10'"`O c #eb3916",'#10'"`P c #ff360' + +'c",'#10'"`Q c #ff2401",'#10'"`R c #f81800",'#10'"`S c #d00e00",'#10'"`T c #' + +'126d09",'#10'"`U c #096205",'#10'"`V c #d81100",'#10'"`W c #af0801",'#10'"`' + +'X c #278916",'#10'"`Y c #3ca022",'#10'"`Z c #46ac28",'#10'"`0 c #404040",' + +#10'"`1 c #0f3500",'#10'"`2 c #39a11f",'#10'"`3 c #54bd2f",'#10'"`4 c #fffff' + +'f",'#10'"`5 c #000000",'#10'"`6 c #005300",'#10'"`7 c #004b00",'#10'"`8 c #' + +'c0dcc0",'#10'".` c #004600",'#10'".. c #6fdc3e",'#10'".# c #53c52d",'#10'".' + +'a c #46bf27",'#10'".b c #23a411",'#10'".c c #70de40",'#10'".d c #40b623",' + +#10'".e c #2eab18",'#10'".f c #31ad1a",'#10'".g c #000000",'#10'".h c #00000' + +'0",'#10'".i c #000000",'#10'".j c #000000",'#10'".k c #000000",'#10'".l c #' + +'000000",'#10'".m c #000000",'#10'".n c #000000",'#10'".o c #000000",'#10'".' + +'p c #000000",'#10'".q c #000000",'#10'".r c #000000",'#10'".s c #000000",' + +#10'".t c #000000",'#10'".u c #000000",'#10'".v c #000000",'#10'".w c #00000' + +'0",'#10'".x c #000000",'#10'".y c #000000",'#10'".z c #000000",'#10'".A c #' + +'000000",'#10'".B c #000000",'#10'".C c #000000",'#10'".D c #000000",'#10'".' + +'E c #000000",'#10'".F c #000000",'#10'".G c #000000",'#10'".H c #000000",' + +#10'".I c #000000",'#10'".J c #000000",'#10'".K c #000000",'#10'".L c #00000' + +'0",'#10'".M c #000000",'#10'".N c #000000",'#10'".O c #000000",'#10'".P c #' + +'000000",'#10'".Q c #000000",'#10'".R c #000000",'#10'".S c #000000",'#10'".' + +'T c #000000",'#10'".U c #000000",'#10'".V c #000000",'#10'".W c #000000",' + +#10'".X c #000000",'#10'".Y c #000000",'#10'".Z c #000000",'#10'".0 c #00000' + +'0",'#10'".1 c #000000",'#10'".2 c #000000",'#10'".3 c #000000",'#10'".4 c #' + +'000000",'#10'".5 c #000000",'#10'".6 c #000000",'#10'".7 c #000000",'#10'".' + +'8 c #000000",'#10'"#` c #000000",'#10'"#. c #000000",'#10'"## c #000000",' + +#10'"#a c #000000",'#10'"#b c #000000",'#10'"#c c #000000",'#10'"#d c #00000' + +'0",'#10'"#e c #000000",'#10'"#f c #000000",'#10'"#g c #000000",'#10'"#h c #' + +'000000",'#10'"#i c #000000",'#10'"#j c #000000",'#10'"#k c #000000",'#10'"#' + +'l c #000000",'#10'"#m c #000000",'#10'"#n c #000000",'#10'"#o c #000000",' + +#10'"#p c #000000",'#10'"#q c #000000",'#10'"#r c #000000",'#10'"#s c #00000' + +'0",'#10'"#t c #000000",'#10'"#u c #000000",'#10'"#v c #000000",'#10'"#w c #' + +'000000",'#10'"#x c #000000",'#10'"#y c #000000",'#10'"#z c #000000",'#10'"#' + +'A c #000000",'#10'"#B c #000000",'#10'"#C c #000000",'#10'"#D c #000000",' + +#10'"#E c #000000",'#10'"#F c #000000",'#10'"#G c #000000",'#10'"#H c #00000' + +'0",'#10'"#I c #000000",'#10'"#J c #000000",'#10'"#K c #000000",'#10'"#L c #' + +'000000",'#10'"#M c #000000",'#10'"#N c #000000",'#10'"#O c #000000",'#10'"#' + +'P c #000000",'#10'"#Q c #000000",'#10'"#R c #000000",'#10'"#S c #000000",' + +#10'"#T c #000000",'#10'"#U c #000000",'#10'"#V c #000000",'#10'"#W c #00000' + +'0",'#10'"#X c #000000",'#10'"#Y c #000000",'#10'"#Z c #000000",'#10'"#0 c #' + +'000000",'#10'"#1 c #000000",'#10'"#2 c #000000",'#10'"#3 c #000000",'#10'"#' + +'4 c #000000",'#10'"#5 c #000000",'#10'"#6 c #000000",'#10'"#7 c #000000",' + +#10'"#8 c #000000",'#10'"a` c #000000",'#10'"a. c #000000",'#10'"a# c #00000' + +'0",'#10'"aa c #000000",'#10'"ab c #000000",'#10'"ac c #000000",'#10'"ad c #' + +'000000",'#10'"ae c #000000",'#10'"af c #000000",'#10'"ag c #000000",'#10'"a' + +'h c #000000",'#10'"ai c #000000",'#10'"aj c #000000",'#10'"ak c #000000",' + +#10'"al c #000000",'#10'"am c #000000",'#10'"an c #000000",'#10'"ao c #00000' + +'0",'#10'"ap c #000000",'#10'"aq c #000000",'#10'"ar c #000000",'#10'"as c #' + +'000000",'#10'"at c #000000",'#10'"au c #000000",'#10'"av c #000000",'#10'"a' + +'w c #000000",'#10'"ax c #000000",'#10'"ay c #000000",'#10'"az c #000000",' + +#10'"aA c #000000",'#10'"aB c #000000",'#10'"aC c #000000",'#10'"aD c #00000' + +'0",'#10'"aE c #000000",'#10'"aF c #000000",'#10'"aG c #000000",'#10'"aH c #' + +'000000",'#10'"aI c #000000",'#10'"aJ c #000000",'#10'"aK c #000000",'#10'"a' + ,'L c #000000",'#10'"aM c #000000",'#10'"aN c #000000",'#10'"aO c #000000",' + +#10'"aP c #000000",'#10'"aQ c #000000",'#10'"aR c #000000",'#10'"aS c #00000' + +'0",'#10'"aT c #000000",'#10'"aU c #000000",'#10'"aV c #000000",'#10'"aW c #' + +'000000",'#10'"aX c #000000",'#10'"aY c #000000",'#10'"aZ c #000000",'#10'"a' + +'0 c #000000",'#10'"a1 c #000000",'#10'"a2 c #000000",'#10'"a3 c #000000",' + +#10'"a4 c #000000",'#10'"a5 c #000000",'#10'"a6 c #000000",'#10'"a7 c #00000' + +'0",'#10'"a8 c #000000",'#10'/* pixels */'#10'"`````````````````````````````' + +'```````````````````",'#10'"```````````````````.`.``````````````````````````' + +'",'#10'"`````````````````.`#`#``````````````````````````",'#10'"```````````' + +'````.`#`a`#``````````````````````````",'#10'"`````````````.`.`b`c`#````````' + +'``````````````````",'#10'"```````````d`e`f`g`h`.`.`.`.`.``````````````````"' + +','#10'"`````````.`i`j`h`f`b`k`l`l`m`i`.`.``````````````",'#10'"```````.`n`o' + +'`j`j`p`p`b`q`r`s`t`u`n`.````````````",'#10'"`````.`v`w`o`o`j`h`f`f`k`x`y`y`' + +'y`y`y`y`y````````",'#10'"`````.`z`v`o`o`A`h`p`f`b`k`y`B`C`D`E`F`y````````",' + +#10'"```````d`G`v`o`o`j`v`m`a`H`y`I`J`K`L`M`y`.``````",'#10'"`````````d`e`v`' + +'o`j`N`d`d`.`y`O`P`Q`R`S`y`T``````",'#10'"```````````.`U`v`A`l`d`````y`F`Q`R' + +'`V`W`y`X`.````",'#10'"`````````````.`U`v`Y`.`````y`y`y`y`y`y`y`Z`.````",'#10 + +'"`0`0`0`0`0`0`0`0`0`0`0`0`0```````1```.`2`3`.````",'#10'"`0`4`4`4`4`4`4`4`4' + +'`4`4`4`0`5`6`6`7`6`6`7`7`#````",'#10'"`0`4`5`5`5`8`4`8`5`5`5`4`0`5`````````' + +'``U.``.````",'#10'"`0`4`5`4`8`5`4`5`8`4`4`4`0`5```````````.`7`#````",'#10'"' + +'`0`4`5`5`5`8`4`8`5`5`8`4`0`5```````````7..`7````",'#10'"`0`4`5`8`4`4`4`4`4`' + +'8`5`4`0`5`7```````7...#.a`7``",'#10'"`0`4`5`4`4`5`5`5`5`5`8`4`0`5.b`7```7.c' + +'.#.d.e.b`7",'#10'"`0`4`4`4`4`4`4`4`4`4`4`4`0`5`7```````7.a.f.b`7``",'#10'"`' + +'0`0`0`0`0`0`0`0`0`0`0`0`0`5```````````7.b`7````",'#10'"```5`5`5`5`5`5`5`5`5' + +'`5`5`5`5`````````````7``````"'#10'};'#10 +]); +LazarusResources.Add('tpsimport_comobj','XPM',[ + '/* XPM */'#10'static char *tpsimport_comobj[] = {'#10'/* width height num_co' + +'lors chars_per_pixel */'#10'" 24 24 256 2",'#10'/* co' + +'lors */'#10'"`` c None",'#10'"`. c #035501",'#10'"`# c #045702",'#10'"`a c ' + +'#1b830f",'#10'"`b c #2daa18",'#10'"`c c #1d8b10",'#10'"`d c #014f00",'#10'"' + +'`e c #0b6a05",'#10'"`f c #27a313",'#10'"`g c #29a615",'#10'"`h c #17970c",' + +#10'"`i c #18780d",'#10'"`j c #139309",'#10'"`k c #35af1c",'#10'"`l c #2f9f1' + +'a",'#10'"`m c #289516",'#10'"`n c #218212",'#10'"`o c #0d8d05",'#10'"`p c #' + +'1f9f10",'#10'"`q c #3eb622",'#10'"`r c #43bb25",'#10'"`s c #4fc52c",'#10'"`' + +'t c #4fbf2d",'#10'"`u c #45af27",'#10'"`v c #097903",'#10'"`w c #0d9006",' + +#10'"`x c #3ab41f",'#10'"`y c #07409a",'#10'"`z c #0d469f",'#10'"`A c #10479' + +'f",'#10'"`B c #0f4195",'#10'"`C c #0a3f97",'#10'"`D c #0a398c",'#10'"`E c #' + +'2a8c17",'#10'"`F c #109007",'#10'"`G c #0341a3",'#10'"`H c #1354b2",'#10'"`' + +'I c #4989d5",'#10'"`J c #79ade5",'#10'"`K c #8ebbed",'#10'"`L c #7eb1e7",' + +#10'"`M c #5490d5",'#10'"`N c #2360b4",'#10'"`O c #11367f",'#10'"`P c #16286' + +'2",'#10'"`Q c #13740a",'#10'"`R c #05409f",'#10'"`S c #3179d0",'#10'"`T c #' + +'9fcbf8",'#10'"`U c #c5e1fc",'#10'"`V c #a9d1f8",'#10'"`W c #86baf0",'#10'"`' + +'X c #6caaea",'#10'"`Y c #599de3",'#10'"`Z c #3b87da",'#10'"`0 c #1165ce",' + +#10'"`1 c #093b90",'#10'"`2 c #162863",'#10'"`3 c #0341a4",'#10'"`4 c #3079d' + +'3",'#10'"`5 c #b4d8fc",'#10'"`6 c #c1e0fc",'#10'"`7 c #8cc1f7",'#10'"`8 c #' + +'88bff6",'#10'".` c #5ea4ee",'#10'".. c #418ee5",'#10'".# c #3280dc",'#10'".' + +'a c #1c6ccf",'#10'".b c #0959c4",'#10'".c c #0152c9",'#10'".d c #0a388e",' + +#10'".e c #1a2356",'#10'".f c #096205",'#10'".g c #0d52b4",'#10'".h c #90c2f' + +'6",'#10'".i c #bbdcfc",'#10'".j c #82bdfa",'#10'".k c #6cb0f6",'#10'".l c #' + +'79b7f4",'#10'".m c #67a9ef",'#10'".n c #4591e3",'#10'".o c #2c7dda",'#10'".' + +'p c #196acf",'#10'".q c #0958c4",'#10'".r c #014dbd",'#10'".s c #0050c9",' + +#10'".t c #152865",'#10'".u c #0541a0",'#10'".v c #357ed4",'#10'".w c #a6d0f' + +'a",'#10'".x c #82bcf7",'#10'".y c #6aaff6",'#10'".z c #6f96d0",'#10'".A c #' + +'b14f4d",'#10'".B c #e7280d",'#10'".C c #e5270c",'#10'".D c #923f44",'#10'".' + +'E c #1f57ac",'#10'".F c #0451c0",'#10'".G c #004cbc",'#10'".H c #004ec2",' + +#10'".I c #063f9e",'#10'".J c #1c1f4e",'#10'".K c #404040",'#10'".L c #ab4c4' + +'b",'#10'".M c #ff1e00",'#10'".N c #803440",'#10'".O c #004abc",'#10'".P c #' + +'0049bb",'#10'".Q c #004dbf",'#10'".R c #0248b5",'#10'".S c #1d1f4d",'#10'".' + +'T c #ffffff",'#10'".U c #000000",'#10'".V c #dd230a",'#10'".W c #024fbd",' + +#10'".X c #034ebd",'#10'".Y c #004bbf",'#10'".Z c #182359",'#10'".0 c #c0dcc' + +'0",'#10'".1 c #0450bf",'#10'".2 c #1c2051",'#10'".3 c #7b323e",'#10'".4 c #' + +'014bbc",'#10'".5 c #0249b5",'#10'".6 c #7d333e",'#10'".7 c #da230a",'#10'".' + +'8 c #7b313e",'#10'"#` c #0d45a3",'#10'"#. c #004bbc",'#10'"## c #0540a0",' + +#10'"#a c #0351bf",'#10'"#b c #0350bf",'#10'"#c c #132968",'#10'"#d c #064fb' + +'f",'#10'"#e c #0049bc",'#10'"#f c #0047bb",'#10'"#g c #0050c7",'#10'"#h c #' + +'083b93",'#10'"#i c #1d1e4b",'#10'"#j c #014dbf",'#10'"#k c #004cbd",'#10'"#' + +'l c #004cbf",'#10'"#m c #004ec1",'#10'"#n c #0051c9",'#10'"#o c #093a92",' + +#10'"#p c #0146b1",'#10'"#q c #004bbb",'#10'"#r c #0247b4",'#10'"#s c #122b6' + +'b",'#10'"#t c #1c1f4d",'#10'"#u c #1b2152",'#10'"#v c #1d1f4c",'#10'"#w c #' + +'000000",'#10'"#x c #000000",'#10'"#y c #000000",'#10'"#z c #000000",'#10'"#' + +'A c #000000",'#10'"#B c #000000",'#10'"#C c #000000",'#10'"#D c #000000",' + +#10'"#E c #000000",'#10'"#F c #000000",'#10'"#G c #000000",'#10'"#H c #00000' + +'0",'#10'"#I c #000000",'#10'"#J c #000000",'#10'"#K c #000000",'#10'"#L c #' + +'000000",'#10'"#M c #000000",'#10'"#N c #000000",'#10'"#O c #000000",'#10'"#' + +'P c #000000",'#10'"#Q c #000000",'#10'"#R c #000000",'#10'"#S c #000000",' + +#10'"#T c #000000",'#10'"#U c #000000",'#10'"#V c #000000",'#10'"#W c #00000' + +'0",'#10'"#X c #000000",'#10'"#Y c #000000",'#10'"#Z c #000000",'#10'"#0 c #' + +'000000",'#10'"#1 c #000000",'#10'"#2 c #000000",'#10'"#3 c #000000",'#10'"#' + +'4 c #000000",'#10'"#5 c #000000",'#10'"#6 c #000000",'#10'"#7 c #000000",' + +#10'"#8 c #000000",'#10'"a` c #000000",'#10'"a. c #000000",'#10'"a# c #00000' + +'0",'#10'"aa c #000000",'#10'"ab c #000000",'#10'"ac c #000000",'#10'"ad c #' + +'000000",'#10'"ae c #000000",'#10'"af c #000000",'#10'"ag c #000000",'#10'"a' + +'h c #000000",'#10'"ai c #000000",'#10'"aj c #000000",'#10'"ak c #000000",' + +#10'"al c #000000",'#10'"am c #000000",'#10'"an c #000000",'#10'"ao c #00000' + +'0",'#10'"ap c #000000",'#10'"aq c #000000",'#10'"ar c #000000",'#10'"as c #' + +'000000",'#10'"at c #000000",'#10'"au c #000000",'#10'"av c #000000",'#10'"a' + +'w c #000000",'#10'"ax c #000000",'#10'"ay c #000000",'#10'"az c #000000",' + +#10'"aA c #000000",'#10'"aB c #000000",'#10'"aC c #000000",'#10'"aD c #00000' + +'0",'#10'"aE c #000000",'#10'"aF c #000000",'#10'"aG c #000000",'#10'"aH c #' + +'000000",'#10'"aI c #000000",'#10'"aJ c #000000",'#10'"aK c #000000",'#10'"a' + ,'L c #000000",'#10'"aM c #000000",'#10'"aN c #000000",'#10'"aO c #000000",' + +#10'"aP c #000000",'#10'"aQ c #000000",'#10'"aR c #000000",'#10'"aS c #00000' + +'0",'#10'"aT c #000000",'#10'"aU c #000000",'#10'"aV c #000000",'#10'"aW c #' + +'000000",'#10'"aX c #000000",'#10'"aY c #000000",'#10'"aZ c #000000",'#10'"a' + +'0 c #000000",'#10'"a1 c #000000",'#10'"a2 c #000000",'#10'"a3 c #000000",' + +#10'"a4 c #000000",'#10'"a5 c #000000",'#10'"a6 c #000000",'#10'"a7 c #00000' + +'0",'#10'"a8 c #000000",'#10'/* pixels */'#10'"`````````````````````````````' + +'```````````````````",'#10'"```````````````````.`.``````````````````````````' + +'",'#10'"`````````````````.`#`#``````````````````````````",'#10'"```````````' + +'````.`#`a`#``````````````````````````",'#10'"`````````````.`.`b`c`#````````' + +'``````````````````",'#10'"```````````d`e`f`g`h`.`.`.`.`.``````````````````"' + +','#10'"`````````.`i`j`h`f`b`k`l`l`m`i`.`.``````````````",'#10'"```````.`n`o' + +'`j`j`p`p`b`q`r`s`t`u`n`.````````````",'#10'"`````.`v`w`o`o`j`h`f`f`k`x`y`z`' + +'A`B`C`D``````````",'#10'"`````.`E`v`o`o`F`h`p`f`G`H`I`J`K`L`M`N`O`P``````",' + +#10'"```````d`Q`v`o`o`j`v`R`S`T`U`V`W`X`Y`Z`0`1`2````",'#10'"`````````d`e`v`' + +'o`j`3`4`5`6`7`8.`...#.a.b.c.d.e``",'#10'"```````````..f`v`F.g.h.i.j.k.l.m.n' + +'.o.p.q.r.s.t``",'#10'"`````````````..f.u.v.w.x.y.z.A.B.C.D.E.F.G.H.I.J",'#10 + +'".K.K.K.K.K.K.K.K.K.K.K.K.K.L.M.M.M.M.N.O.P.Q.R.S",'#10'".K.T.T.T.T.T.T.T.T' + +'.T.T.T.K.U.M.M.M.M.V.W.X.O.Y.Z",'#10'".K.T.U.U.U.0.T.0.U.U.U.T.K.U.M.M.M.M.' + +'V.W.1.O.Y.2",'#10'".K.T.U.T.0.U.T.U.0.T.T.T.K.U.M.M.M.M.3.4.P.Q.5.J",'#10'"' + +'.K.T.U.U.U.0.T.0.U.U.0.T.K.U.6.7.7.8#`.P#..H##.J",'#10'".K.T.U.0.T.T.T.T.T.' + +'0.U.T.K.U#a.W#b.P#.#.#..s#c``",'#10'".K.T.U.T.T.U.U.U.U.U.0.T.K.U#d#e#f#.#.' + +'#.#g#h#i``",'#10'".K.T.T.T.T.T.T.T.T.T.T.T.K.U#j#e#k#l#m#n#o.J````",'#10'".' + +'K.K.K.K.K.K.K.K.K.K.K.K.K.U#p#q#.#r.I#s#t``````",'#10'"``.U.U.U.U.U.U.U.U.U' + +'.U.U.U.U#u#c#c#u#v``````````"'#10'};'#10 +]); +LazarusResources.Add('tpsimport_controls','XPM',[ + '/* XPM */'#10'static char *tpsimport_controls[] = {'#10'/* width height num_' + +'colors chars_per_pixel */'#10'" 24 24 256 2",'#10'/* ' + +'colors */'#10'"`` c None",'#10'"`. c #035501",'#10'"`# c #045702",'#10'"`a ' + +'c #1b830f",'#10'"`b c #2daa18",'#10'"`c c #1d8b10",'#10'"`d c #014f00",'#10 + +'"`e c #0b6a05",'#10'"`f c #27a313",'#10'"`g c #29a615",'#10'"`h c #17970c",' + +#10'"`i c #18780d",'#10'"`j c #139309",'#10'"`k c #35af1c",'#10'"`l c #2f9f1' + +'a",'#10'"`m c #289516",'#10'"`n c #218212",'#10'"`o c #0d8d05",'#10'"`p c #' + +'1f9f10",'#10'"`q c #3eb622",'#10'"`r c #43bb25",'#10'"`s c #4fc52c",'#10'"`' + +'t c #4fbf2d",'#10'"`u c #45af27",'#10'"`v c #097903",'#10'"`w c #0d9006",' + +#10'"`x c #3ab41f",'#10'"`y c #5ed035",'#10'"`z c #5fca35",'#10'"`A c #3ca02' + +'2",'#10'"`B c #2a8c17",'#10'"`C c #109007",'#10'"`D c #48bc27",'#10'"`E c #' + +'52c42d",'#10'"`F c #6ad83c",'#10'"`G c #46ac28",'#10'"`H c #13740a",'#10'"`' + +'I c #147b0a",'#10'"`J c #2c9518",'#10'"`K c #64d338",'#10'"`L c #72dc41",' + +#10'"`M c #379c1f",'#10'"`N c #53536b",'#10'"`O c #68d13b",'#10'"`P c #126d0' + +'9",'#10'"`Q c #096205",'#10'"`R c #b8abbc",'#10'"`S c #b493a1",'#10'"`T c #' + +'b49fad",'#10'"`U c #b598a6",'#10'"`V c #5c5b78",'#10'"`W c #edeef4",'#10'"`' + +'X c #e9e5ed",'#10'"`Y c #d5b6c0",'#10'"`Z c #d0d3e7",'#10'"`0 c #404040",' + +#10'"`1 c #cfc5d3",'#10'"`2 c #d4c2cc",'#10'"`3 c #ebe0e5",'#10'"`4 c #e2d8d' + +'e",'#10'"`5 c #b8c2de",'#10'"`6 c #9f9ece",'#10'"`7 c #998bcc",'#10'"`8 c #' + +'968cc9",'#10'".` c #ffffff",'#10'".. c #000000",'#10'".# c #cbcede",'#10'".' + +'a c #cbcce0",'#10'".b c #9f9cc7",'#10'".c c #69898c",'#10'".d c #8390c0",' + +#10'".e c #c0dcc0",'#10'".f c #d4d0dc",'#10'".g c #d3d3e3",'#10'".h c #9fa0c' + +'6",'#10'".i c #908bc7",'#10'".j c #ddd8e7",'#10'".k c #a7a3d3",'#10'".l c #' + +'7e8eac",'#10'".m c #e0dcea",'#10'".n c #b0a5e0",'#10'".o c #8482c0",'#10'".' + +'p c #cecbd9",'#10'".q c #dad9ea",'#10'".r c #a4a6d0",'#10'".s c #cbc9d8",' + +#10'".t c #dcdaef",'#10'".u c #84a4a9",'#10'".v c #b1b0c9",'#10'".w c #c5c5d' + +'8",'#10'".x c #dcdcee",'#10'".y c #a1a6d4",'#10'".z c #8c8bcf",'#10'".A c #' + +'a3a3b8",'#10'".B c #bfbfd7",'#10'".C c #8c8cc6",'#10'".D c #000000",'#10'".' + +'E c #000000",'#10'".F c #000000",'#10'".G c #000000",'#10'".H c #000000",' + +#10'".I c #000000",'#10'".J c #000000",'#10'".K c #000000",'#10'".L c #00000' + +'0",'#10'".M c #000000",'#10'".N c #000000",'#10'".O c #000000",'#10'".P c #' + +'000000",'#10'".Q c #000000",'#10'".R c #000000",'#10'".S c #000000",'#10'".' + +'T c #000000",'#10'".U c #000000",'#10'".V c #000000",'#10'".W c #000000",' + +#10'".X c #000000",'#10'".Y c #000000",'#10'".Z c #000000",'#10'".0 c #00000' + +'0",'#10'".1 c #000000",'#10'".2 c #000000",'#10'".3 c #000000",'#10'".4 c #' + +'000000",'#10'".5 c #000000",'#10'".6 c #000000",'#10'".7 c #000000",'#10'".' + +'8 c #000000",'#10'"#` c #000000",'#10'"#. c #000000",'#10'"## c #000000",' + +#10'"#a c #000000",'#10'"#b c #000000",'#10'"#c c #000000",'#10'"#d c #00000' + +'0",'#10'"#e c #000000",'#10'"#f c #000000",'#10'"#g c #000000",'#10'"#h c #' + +'000000",'#10'"#i c #000000",'#10'"#j c #000000",'#10'"#k c #000000",'#10'"#' + +'l c #000000",'#10'"#m c #000000",'#10'"#n c #000000",'#10'"#o c #000000",' + +#10'"#p c #000000",'#10'"#q c #000000",'#10'"#r c #000000",'#10'"#s c #00000' + +'0",'#10'"#t c #000000",'#10'"#u c #000000",'#10'"#v c #000000",'#10'"#w c #' + +'000000",'#10'"#x c #000000",'#10'"#y c #000000",'#10'"#z c #000000",'#10'"#' + +'A c #000000",'#10'"#B c #000000",'#10'"#C c #000000",'#10'"#D c #000000",' + +#10'"#E c #000000",'#10'"#F c #000000",'#10'"#G c #000000",'#10'"#H c #00000' + +'0",'#10'"#I c #000000",'#10'"#J c #000000",'#10'"#K c #000000",'#10'"#L c #' + +'000000",'#10'"#M c #000000",'#10'"#N c #000000",'#10'"#O c #000000",'#10'"#' + +'P c #000000",'#10'"#Q c #000000",'#10'"#R c #000000",'#10'"#S c #000000",' + +#10'"#T c #000000",'#10'"#U c #000000",'#10'"#V c #000000",'#10'"#W c #00000' + +'0",'#10'"#X c #000000",'#10'"#Y c #000000",'#10'"#Z c #000000",'#10'"#0 c #' + +'000000",'#10'"#1 c #000000",'#10'"#2 c #000000",'#10'"#3 c #000000",'#10'"#' + +'4 c #000000",'#10'"#5 c #000000",'#10'"#6 c #000000",'#10'"#7 c #000000",' + +#10'"#8 c #000000",'#10'"a` c #000000",'#10'"a. c #000000",'#10'"a# c #00000' + +'0",'#10'"aa c #000000",'#10'"ab c #000000",'#10'"ac c #000000",'#10'"ad c #' + +'000000",'#10'"ae c #000000",'#10'"af c #000000",'#10'"ag c #000000",'#10'"a' + +'h c #000000",'#10'"ai c #000000",'#10'"aj c #000000",'#10'"ak c #000000",' + +#10'"al c #000000",'#10'"am c #000000",'#10'"an c #000000",'#10'"ao c #00000' + +'0",'#10'"ap c #000000",'#10'"aq c #000000",'#10'"ar c #000000",'#10'"as c #' + +'000000",'#10'"at c #000000",'#10'"au c #000000",'#10'"av c #000000",'#10'"a' + +'w c #000000",'#10'"ax c #000000",'#10'"ay c #000000",'#10'"az c #000000",' + +#10'"aA c #000000",'#10'"aB c #000000",'#10'"aC c #000000",'#10'"aD c #00000' + +'0",'#10'"aE c #000000",'#10'"aF c #000000",'#10'"aG c #000000",'#10'"aH c #' + +'000000",'#10'"aI c #000000",'#10'"aJ c #000000",'#10'"aK c #000000",'#10'"a' + ,'L c #000000",'#10'"aM c #000000",'#10'"aN c #000000",'#10'"aO c #000000",' + +#10'"aP c #000000",'#10'"aQ c #000000",'#10'"aR c #000000",'#10'"aS c #00000' + +'0",'#10'"aT c #000000",'#10'"aU c #000000",'#10'"aV c #000000",'#10'"aW c #' + +'000000",'#10'"aX c #000000",'#10'"aY c #000000",'#10'"aZ c #000000",'#10'"a' + +'0 c #000000",'#10'"a1 c #000000",'#10'"a2 c #000000",'#10'"a3 c #000000",' + +#10'"a4 c #000000",'#10'"a5 c #000000",'#10'"a6 c #000000",'#10'"a7 c #00000' + +'0",'#10'"a8 c #000000",'#10'/* pixels */'#10'"`````````````````````````````' + +'```````````````````",'#10'"```````````````````.`.``````````````````````````' + +'",'#10'"`````````````````.`#`#``````````````````````````",'#10'"```````````' + +'````.`#`a`#``````````````````````````",'#10'"`````````````.`.`b`c`#````````' + +'``````````````````",'#10'"```````````d`e`f`g`h`.`.`.`.`.``````````````````"' + +','#10'"`````````.`i`j`h`f`b`k`l`l`m`i`.`.``````````````",'#10'"```````.`n`o' + +'`j`j`p`p`b`q`r`s`t`u`n`.````````````",'#10'"`````.`v`w`o`o`j`h`f`f`k`x`r`s`' + +'y`z`A`.``````````",'#10'"`````.`B`v`o`o`C`h`p`f`b`k`q`D`E`y`F`G`.````````",' + +#10'"```````d`H`v`o`o`j`v`m`a`I`I`H`J`t`K`L`l`.``````",'#10'"`````````d`e`v`' + +'o`j`M`d`d`.`.`N`N`N`N`O`O`P``````",'#10'"```````````.`Q`v`C`l`d```N`N`R`S`T' + +'`U`N`N`V`.````",'#10'"`````````````.`Q`v`A`N`N`W`X`T`T`T`T`Y`Z`N`.````",'#10 + +'"`0`0`0`0`0`0`0`0`0`0`0`0`0`1`2`3`4`5`6`7`8`N````",'#10'"`0.`.`.`.`.`.`.`.`' + +'.`.`.``0..`1.#.a.b.c.d.d`N````",'#10'"`0.`.......e.`.e.......``0..`1.f.g.h.' + +'d.d.d.i`N``",'#10'"`0.`...`.e...`...e.`.`.``0..`1.f.j.k.l.d.d.d`N``",'#10'"' + +'`0.`.......e.`.e.....e.``0..`1.f.m.n.d.d.d.d.o`N",'#10'"`0.`...e.`.`.`.`.`.' + +'e...``0..`1.p.q.r.d.d.d.d.d`N",'#10'"`0.`...`.`...........e.``0..`1.s.t.u.d' + +'.d.d.d`N`N",'#10'"`0.`.`.`.`.`.`.`.`.`.`.``0...v.w.x.y.d.z`N`N````",'#10'"`' + +'0`0`0`0`0`0`0`0`0`0`0`0`0..`N.A.B.C`N`N````````",'#10'"``..................' + +'........```V`N`N````````````"'#10'};'#10 +]); +LazarusResources.Add('tpsimport_dateutils','XPM',[ + '/* XPM */'#10'static char *tpsimport_dateutils[] = {'#10'/* width height num' + +'_colors chars_per_pixel */'#10'" 24 24 256 2",'#10'/*' + +' colors */'#10'"`` c None",'#10'"`. c #035501",'#10'"`# c #045702",'#10'"`a' + +' c #1b830f",'#10'"`b c #2daa18",'#10'"`c c #1d8b10",'#10'"`d c #014f00",'#10 + +'"`e c #0b6a05",'#10'"`f c #27a313",'#10'"`g c #29a615",'#10'"`h c #17970c",' + +#10'"`i c #18780d",'#10'"`j c #139309",'#10'"`k c #35af1c",'#10'"`l c #2f9f1' + +'a",'#10'"`m c #289516",'#10'"`n c #218212",'#10'"`o c #0d8d05",'#10'"`p c #' + +'1f9f10",'#10'"`q c #3eb622",'#10'"`r c #43bb25",'#10'"`s c #4fc52c",'#10'"`' + +'t c #4fbf2d",'#10'"`u c #45af27",'#10'"`v c #097903",'#10'"`w c #0d9006",' + +#10'"`x c #3ab41f",'#10'"`y c #323232",'#10'"`z c #353232",'#10'"`A c #33333' + +'3",'#10'"`B c #2a8c17",'#10'"`C c #109007",'#10'"`D c #52c42d",'#10'"`E c #' + +'472624",'#10'"`F c #4a2121",'#10'"`G c #691e1e",'#10'"`H c #4a2222",'#10'"`' + +'I c #5c0909",'#10'"`J c #13740a",'#10'"`K c #482929",'#10'"`L c #631c1a",' + +#10'"`M c #691f1c",'#10'"`N c #7a2b28",'#10'"`O c #7b2623",'#10'"`P c #7e2a2' + +'8",'#10'"`Q c #452c2c",'#10'"`R c #813b3c",'#10'"`S c #7a4d52",'#10'"`T c #' + +'6e5358",'#10'"`U c #464143",'#10'"`V c #707478",'#10'"`W c #464646",'#10'"`' + +'X c #379c1f",'#10'"`Y c #706a69",'#10'"`Z c #c54f49",'#10'"`0 c #a7120e",' + +#10'"`1 c #785654",'#10'"`2 c #9a8687",'#10'"`3 c #aaa6a9",'#10'"`4 c #58636' + +'5",'#10'"`5 c #6e7374",'#10'"`6 c #d7e3e7",'#10'"`7 c #dae0e0",'#10'"`8 c #' + +'474a49",'#10'".` c #777777",'#10'".. c #ffffff",'#10'".# c #6b6c6d",'#10'".' + +'a c #096205",'#10'".b c #7f7877",'#10'".c c #d96960",'#10'".d c #9c1210",' + +#10'".e c #a3a1a3",'#10'".f c #8e8c8c",'#10'".g c #5e5e5e",'#10'".h c #d9d9d' + +'8",'#10'".i c #fbfafa",'#10'".j c #e7e7e7",'#10'".k c #a6a6a6",'#10'".l c #' + +'d1d0d0",'#10'".m c #3ca022",'#10'".n c #7d7675",'#10'".o c #d5665d",'#10'".' + +'p c #9d1210",'#10'".q c #a69fa0",'#10'".r c #a09f9f",'#10'".s c #989797",' + +#10'".t c #939292",'#10'".u c #a7a6a6",'#10'".v c #d8d7d7",'#10'".w c #40404' + +'0",'#10'".x c #8f8f8f",'#10'".y c #a9a9a9",'#10'".z c #898888",'#10'".A c #' + +'b7b6b6",'#10'".B c #b6b5b5",'#10'".C c #dad9d9",'#10'".D c #fefefe",'#10'".' + +'E c #000000",'#10'".F c #e2e2e2",'#10'".G c #d9d9d9",'#10'".H c #aaaaaa",' + +#10'".I c #8c8b8b",'#10'".J c #d7d5d5",'#10'".K c #fafafb",'#10'".L c #c0dcc' + +'0",'#10'".M c #fffefe",'#10'".N c #abaaaa",'#10'".O c #211f1f",'#10'".P c #' + +'fcfeff",'#10'".Q c #f2f7fb",'#10'".R c #fffffe",'#10'".S c #838282",'#10'".' + +'T c #646262",'#10'".U c #bcbdbd",'#10'".V c #fafeff",'#10'".W c #eaf3fb",' + +#10'".X c #696868",'#10'".Y c #8b8a8b",'#10'".Z c #e5eef6",'#10'".0 c #e2eef' + +'c",'#10'".1 c #bdbbbb",'#10'".2 c #eeeff2",'#10'".3 c #f7fcff",'#10'".4 c #' + +'d7e3ef",'#10'".5 c #d9ebfc",'#10'".6 c #565658",'#10'".7 c #5b6064",'#10'".' + +'8 c #e0f2ff",'#10'"#` c #d8eeff",'#10'"#. c #fcffff",'#10'"## c #bbc2ca",' + +#10'"#a c #a5afb8",'#10'"#b c #d3e5f3",'#10'"#c c #c4d7e7",'#10'"#d c #78838' + +'f",'#10'"#e c #494d50",'#10'"#f c #f8f8f8",'#10'"#g c #d1d7da",'#10'"#h c #' + +'bac0c4",'#10'"#i c #7d7f82",'#10'"#j c #646668",'#10'"#k c #56595d",'#10'"#' + +'l c #3e4042",'#10'"#m c #414141",'#10'"#n c #60676d",'#10'"#o c #000000",' + +#10'"#p c #000000",'#10'"#q c #000000",'#10'"#r c #000000",'#10'"#s c #00000' + +'0",'#10'"#t c #000000",'#10'"#u c #000000",'#10'"#v c #000000",'#10'"#w c #' + +'000000",'#10'"#x c #000000",'#10'"#y c #000000",'#10'"#z c #000000",'#10'"#' + +'A c #000000",'#10'"#B c #000000",'#10'"#C c #000000",'#10'"#D c #000000",' + +#10'"#E c #000000",'#10'"#F c #000000",'#10'"#G c #000000",'#10'"#H c #00000' + +'0",'#10'"#I c #000000",'#10'"#J c #000000",'#10'"#K c #000000",'#10'"#L c #' + +'000000",'#10'"#M c #000000",'#10'"#N c #000000",'#10'"#O c #000000",'#10'"#' + +'P c #000000",'#10'"#Q c #000000",'#10'"#R c #000000",'#10'"#S c #000000",' + +#10'"#T c #000000",'#10'"#U c #000000",'#10'"#V c #000000",'#10'"#W c #00000' + +'0",'#10'"#X c #000000",'#10'"#Y c #000000",'#10'"#Z c #000000",'#10'"#0 c #' + +'000000",'#10'"#1 c #000000",'#10'"#2 c #000000",'#10'"#3 c #000000",'#10'"#' + +'4 c #000000",'#10'"#5 c #000000",'#10'"#6 c #000000",'#10'"#7 c #000000",' + +#10'"#8 c #000000",'#10'"a` c #000000",'#10'"a. c #000000",'#10'"a# c #00000' + +'0",'#10'"aa c #000000",'#10'"ab c #000000",'#10'"ac c #000000",'#10'"ad c #' + +'000000",'#10'"ae c #000000",'#10'"af c #000000",'#10'"ag c #000000",'#10'"a' + +'h c #000000",'#10'"ai c #000000",'#10'"aj c #000000",'#10'"ak c #000000",' + +#10'"al c #000000",'#10'"am c #000000",'#10'"an c #000000",'#10'"ao c #00000' + +'0",'#10'"ap c #000000",'#10'"aq c #000000",'#10'"ar c #000000",'#10'"as c #' + +'000000",'#10'"at c #000000",'#10'"au c #000000",'#10'"av c #000000",'#10'"a' + +'w c #000000",'#10'"ax c #000000",'#10'"ay c #000000",'#10'"az c #000000",' + +#10'"aA c #000000",'#10'"aB c #000000",'#10'"aC c #000000",'#10'"aD c #00000' + +'0",'#10'"aE c #000000",'#10'"aF c #000000",'#10'"aG c #000000",'#10'"aH c #' + +'000000",'#10'"aI c #000000",'#10'"aJ c #000000",'#10'"aK c #000000",'#10'"a' + ,'L c #000000",'#10'"aM c #000000",'#10'"aN c #000000",'#10'"aO c #000000",' + +#10'"aP c #000000",'#10'"aQ c #000000",'#10'"aR c #000000",'#10'"aS c #00000' + +'0",'#10'"aT c #000000",'#10'"aU c #000000",'#10'"aV c #000000",'#10'"aW c #' + +'000000",'#10'"aX c #000000",'#10'"aY c #000000",'#10'"aZ c #000000",'#10'"a' + +'0 c #000000",'#10'"a1 c #000000",'#10'"a2 c #000000",'#10'"a3 c #000000",' + +#10'"a4 c #000000",'#10'"a5 c #000000",'#10'"a6 c #000000",'#10'"a7 c #00000' + +'0",'#10'"a8 c #000000",'#10'/* pixels */'#10'"`````````````````````````````' + +'```````````````````",'#10'"```````````````````.`.``````````````````````````' + +'",'#10'"`````````````````.`#`#``````````````````````````",'#10'"```````````' + +'````.`#`a`#``````````````````````````",'#10'"`````````````.`.`b`c`#````````' + +'``````````````````",'#10'"```````````d`e`f`g`h`.`.`.`.`.``````````````````"' + +','#10'"`````````.`i`j`h`f`b`k`l`l`m`i`.`.``````````````",'#10'"```````.`n`o' + +'`j`j`p`p`b`q`r`s`t`u`n`.````````````",'#10'"`````.`v`w`o`o`j`h`f`f`k`x`r`s`' + +'y`y`````z`A``````",'#10'"`````.`B`v`o`o`C`h`p`f`b`k`q`y`D`E`y`F`.`G`H`I``",' + +#10'"```````d`J`v`o`o`j`v`m`K`L`M`N`O`P`Q`R`S`T`U`V`W",'#10'"`````````d`e`v`' + +'o`j`X`Y`Z`0`1`2`3`4`5`6`7`8.`...#",'#10'"```````````..a`v`C`l.b.c.d.e.f...g' + +'.h.i.j.k.l...#",'#10'"`````````````..a`v.m.n.o.p.q.f...k.r.s.t.u.v...#",'#10 + +'".w.w.w.w.w.w.w.w.w.w.w.w.w.q.f...x.y.z.A.B.C.D.#",'#10'".w................' + +'.......w.E.f.D.F.G.H.I.J...K.#",'#10'".w...E.E.E.L...L.E.E.E...w.E.f.M...N.' + +'O.O.O.P.Q.#",'#10'".w...E...L.E...E.L.......w.E.f.R...S.O.T.U.V.W.#",'#10'"' + +'.w...E.E.E.L...L.E.E.L...w.E.f.R...r.X.Y.O.Z.0.#",'#10'".w...E.L...........' + +'L.E...w.E.f.R...1.2.3.O.4.5.#",'#10'".w...E.....E.E.E.E.E.L...w.E.f.R...z.6' + +'.O.7.8#`.#",'#10'".w.......................w.E.f....#.###a#b#c#d#e",'#10'".' + +'w.w.w.w.w.w.w.w.w.w.w.w.w.E.f#f#g#h#i#j#k#l````",'#10'"``.E.E.E.E.E.E.E.E.E' + +'.E.E.E.E`y#m#n#n````````````"'#10'};'#10 +]); +LazarusResources.Add('tpsimport_db','XPM',[ + '/* XPM */'#10'static char *tpsimport_db[] = {'#10'/* width height num_colors' + +' chars_per_pixel */'#10'" 24 24 256 2",'#10'/* colors' + +' */'#10'"`` c None",'#10'"`. c #035501",'#10'"`# c #045702",'#10'"`a c #1b8' + +'30f",'#10'"`b c #2daa18",'#10'"`c c #1d8b10",'#10'"`d c #014f00",'#10'"`e c' + +' #0b6a05",'#10'"`f c #27a313",'#10'"`g c #29a615",'#10'"`h c #17970c",'#10 + +'"`i c #18780d",'#10'"`j c #139309",'#10'"`k c #35af1c",'#10'"`l c #2f9f1a",' + +#10'"`m c #289516",'#10'"`n c #218212",'#10'"`o c #0d8d05",'#10'"`p c #1f9f1' + +'0",'#10'"`q c #3eb622",'#10'"`r c #43bb25",'#10'"`s c #4fc52c",'#10'"`t c #' + +'4fbf2d",'#10'"`u c #45af27",'#10'"`v c #097903",'#10'"`w c #0d9006",'#10'"`' + +'x c #a77302",'#10'"`y c #a97402",'#10'"`z c #3ca022",'#10'"`A c #2a8c17",' + +#10'"`B c #109007",'#10'"`C c #e9dab7",'#10'"`D c #fbfcd7",'#10'"`E c #ffffa' + +'5",'#10'"`F c #feff87",'#10'"`G c #fbfe84",'#10'"`H c #e7dc62",'#10'"`I c #' + +'46ac28",'#10'"`J c #13740a",'#10'"`K c #ffffc0",'#10'"`L c #fff68e",'#10'"`' + +'M c #fff777",'#10'"`N c #fefa7d",'#10'"`O c #f6f07b",'#10'"`P c #e0ca45",' + +#10'"`Q c #986802",'#10'"`R c #72dc41",'#10'"`S c #379c1f",'#10'"`T c #fff45' + +'7",'#10'"`U c #fece16",'#10'"`V c #fccb1a",'#10'"`W c #f7dc5b",'#10'"`X c #' + +'d7bf5e",'#10'"`Y c #a5790f",'#10'"`Z c #096205",'#10'"`0 c #fff45b",'#10'"`' + +'1 c #fece15",'#10'"`2 c #fbc918",'#10'"`3 c #edd057",'#10'"`4 c #c2ab54",' + +#10'"`5 c #eade63",'#10'"`6 c #d5b72a",'#10'"`7 c #eabb11",'#10'"`8 c #f7c71' + +'8",'#10'".` c #e3cc53",'#10'".. c #af953c",'#10'".# c #fffb7e",'#10'".a c #' + +'fef880",'#10'".b c #f0d94b",'#10'".c c #404040",'#10'".d c #ad7b08",'#10'".' + +'e c #9f7209",'#10'".f c #92721d",'#10'".g c #fecc1a",'#10'".h c #ffe35e",' + +#10'".i c #f2d76a",'#10'".j c #cc9713",'#10'".k c #ffffff",'#10'".l c #00000' + +'0",'#10'".m c #d8cea9",'#10'".n c #b6ac8a",'#10'".o c #fecb18",'#10'".p c #' + +'ffe15e",'#10'".q c #f3d569",'#10'".r c #ce9915",'#10'".s c #c0dcc0",'#10'".' + +'t c #e7d467",'#10'".u c #bdaa5c",'#10'".v c #faca18",'#10'".w c #fae05b",' + +#10'".x c #e3c14e",'#10'".y c #bc880a",'#10'".z c #e7cc54",'#10'".A c #bba55' + +'0",'#10'".B c #d1b44f",'#10'".C c #c0921a",'#10'".D c #b07d08",'#10'".E c #' + +'b07e0a",'#10'".F c #bf9326",'#10'".G c #c7a140",'#10'".H c #e7cf58",'#10'".' + +'I c #bda754",'#10'".J c #f7f0ab",'#10'".K c #f0e09e",'#10'".L c #eedead",' + +#10'".M c #eee2ba",'#10'".N c #eee1b4",'#10'".O c #e5ce89",'#10'".P c #dec14' + +'a",'#10'".Q c #aa903e",'#10'".R c #fff862",'#10'".S c #ffd723",'#10'".T c #' + +'ffd52c",'#10'".U c #ffea72",'#10'".V c #f7dd78",'#10'".W c #d09e18",'#10'".' + +'X c #a47002",'#10'".Y c #8e6002",'#10'".Z c #fff45c",'#10'".0 c #ffe15c",' + +#10'".1 c #f3d768",'#10'".2 c #ce9a15",'#10'".3 c #fffe64",'#10'".4 c #ffd41' + +'8",'#10'".5 c #ffcf1a",'#10'".6 c #ffe562",'#10'".7 c #f7da6e",'#10'".8 c #' + +'d19e17",'#10'"#` c #ac7d09",'#10'"#. c #cba41d",'#10'"## c #e5b814",'#10'"#' + +'a c #f0bf18",'#10'"#b c #f2d351",'#10'"#c c #debd51",'#10'"#d c #b8860c",' + +#10'"#e c #000000",'#10'"#f c #000000",'#10'"#g c #000000",'#10'"#h c #00000' + +'0",'#10'"#i c #000000",'#10'"#j c #000000",'#10'"#k c #000000",'#10'"#l c #' + +'000000",'#10'"#m c #000000",'#10'"#n c #000000",'#10'"#o c #000000",'#10'"#' + +'p c #000000",'#10'"#q c #000000",'#10'"#r c #000000",'#10'"#s c #000000",' + +#10'"#t c #000000",'#10'"#u c #000000",'#10'"#v c #000000",'#10'"#w c #00000' + +'0",'#10'"#x c #000000",'#10'"#y c #000000",'#10'"#z c #000000",'#10'"#A c #' + +'000000",'#10'"#B c #000000",'#10'"#C c #000000",'#10'"#D c #000000",'#10'"#' + +'E c #000000",'#10'"#F c #000000",'#10'"#G c #000000",'#10'"#H c #000000",' + +#10'"#I c #000000",'#10'"#J c #000000",'#10'"#K c #000000",'#10'"#L c #00000' + +'0",'#10'"#M c #000000",'#10'"#N c #000000",'#10'"#O c #000000",'#10'"#P c #' + +'000000",'#10'"#Q c #000000",'#10'"#R c #000000",'#10'"#S c #000000",'#10'"#' + +'T c #000000",'#10'"#U c #000000",'#10'"#V c #000000",'#10'"#W c #000000",' + +#10'"#X c #000000",'#10'"#Y c #000000",'#10'"#Z c #000000",'#10'"#0 c #00000' + +'0",'#10'"#1 c #000000",'#10'"#2 c #000000",'#10'"#3 c #000000",'#10'"#4 c #' + +'000000",'#10'"#5 c #000000",'#10'"#6 c #000000",'#10'"#7 c #000000",'#10'"#' + +'8 c #000000",'#10'"a` c #000000",'#10'"a. c #000000",'#10'"a# c #000000",' + +#10'"aa c #000000",'#10'"ab c #000000",'#10'"ac c #000000",'#10'"ad c #00000' + +'0",'#10'"ae c #000000",'#10'"af c #000000",'#10'"ag c #000000",'#10'"ah c #' + +'000000",'#10'"ai c #000000",'#10'"aj c #000000",'#10'"ak c #000000",'#10'"a' + +'l c #000000",'#10'"am c #000000",'#10'"an c #000000",'#10'"ao c #000000",' + +#10'"ap c #000000",'#10'"aq c #000000",'#10'"ar c #000000",'#10'"as c #00000' + +'0",'#10'"at c #000000",'#10'"au c #000000",'#10'"av c #000000",'#10'"aw c #' + +'000000",'#10'"ax c #000000",'#10'"ay c #000000",'#10'"az c #000000",'#10'"a' + +'A c #000000",'#10'"aB c #000000",'#10'"aC c #000000",'#10'"aD c #000000",' + +#10'"aE c #000000",'#10'"aF c #000000",'#10'"aG c #000000",'#10'"aH c #00000' + +'0",'#10'"aI c #000000",'#10'"aJ c #000000",'#10'"aK c #000000",'#10'"aL c #' + ,'000000",'#10'"aM c #000000",'#10'"aN c #000000",'#10'"aO c #000000",'#10'"a' + +'P c #000000",'#10'"aQ c #000000",'#10'"aR c #000000",'#10'"aS c #000000",' + +#10'"aT c #000000",'#10'"aU c #000000",'#10'"aV c #000000",'#10'"aW c #00000' + +'0",'#10'"aX c #000000",'#10'"aY c #000000",'#10'"aZ c #000000",'#10'"a0 c #' + +'000000",'#10'"a1 c #000000",'#10'"a2 c #000000",'#10'"a3 c #000000",'#10'"a' + +'4 c #000000",'#10'"a5 c #000000",'#10'"a6 c #000000",'#10'"a7 c #000000",' + +#10'"a8 c #000000",'#10'/* pixels */'#10'"``````````````````````````````````' + +'``````````````",'#10'"```````````````````.`.``````````````````````````",'#10 + +'"`````````````````.`#`#``````````````````````````",'#10'"```````````````.`#' + +'`a`#``````````````````````````",'#10'"`````````````.`.`b`c`#```````````````' + +'```````````",'#10'"```````````d`e`f`g`h`.`.`.`.`.``````````````````",'#10'"' + +'`````````.`i`j`h`f`b`k`l`l`m`i`.`.``````````````",'#10'"```````.`n`o`j`j`p`' + +'p`b`q`r`s`t`u`n`.````````````",'#10'"`````.`v`w`o`o`j`h`f`f`x`y`y`y`y`y`z`.' + +'``````````",'#10'"`````.`A`v`o`o`B`h`p`y`C`D`E`F`G`H`x`I`.````````",'#10'"`' + +'``````d`J`v`o`o`j`v`y`K`L`M`N`O`P`Q`R`l`.``````",'#10'"`````````d`e`v`o`j`S' + +'`y`T`U`V`W`X`Y`x`y`y`y`y`y``",'#10'"```````````.`Z`v`B`l`y`0`1`2`3`4`y`C`D`' + +'E`F`G`5`y",'#10'"`````````````.`Z`v`z`y`6`7`8.`..`y`K`L`M.#.a.b`y",'#10'".c' + +'.c.c.c.c.c.c.c.c.c.c.c.c.d.e.f`y`T`U.g.h.i.j`y",'#10'".c.k.k.k.k.k.k.k.k.k.' + +'k.k.c.l.m.n`y`0`1.o.p.q.r`y",'#10'".c.k.l.l.l.s.k.s.l.l.l.k.c.l.t.u`y`6`7.v' + +'.w.x.y`y",'#10'".c.k.l.k.s.l.k.l.s.k.k.k.c.l.z.A`y.B.C.D.E.F.G`y",'#10'".c.' + +'k.l.l.l.s.k.s.l.l.s.k.c.l.H.I`y.J.K.L.M.N.O`y",'#10'".c.k.l.s.k.k.k.k.k.s.l' + +'.k.c.l.P.Q`y.R.S.T.U.V.W`y",'#10'".c.k.l.k.k.l.l.l.l.l.s.k.c.l.X.Y`y.Z`1.o.' + +'0.1.2`y",'#10'".c.k.k.k.k.k.k.k.k.k.k.k.c.l`````y.3.4.5.6.7.8`y",'#10'".c.c' + +'.c.c.c.c.c.c.c.c.c.c.c.l````#`#.###a#b#c#d`y",'#10'"``.l.l.l.l.l.l.l.l.l.l.' + +'l.l.l```````y`y`y`y`y`y``"'#10'};'#10 +]); +LazarusResources.Add('tpsimport_forms','XPM',[ + '/* XPM */'#10'static char *tpsimport_forms[] = {'#10'/* width height num_col' + +'ors chars_per_pixel */'#10'" 24 24 256 2",'#10'/* col' + +'ors */'#10'"`` c None",'#10'"`. c #035501",'#10'"`# c #045702",'#10'"`a c #' + +'1b830f",'#10'"`b c #2daa18",'#10'"`c c #1d8b10",'#10'"`d c #014f00",'#10'"`' + +'e c #0b6a05",'#10'"`f c #27a313",'#10'"`g c #29a615",'#10'"`h c #17970c",' + +#10'"`i c #18780d",'#10'"`j c #139309",'#10'"`k c #35af1c",'#10'"`l c #2f9f1' + +'a",'#10'"`m c #289516",'#10'"`n c #218212",'#10'"`o c #0d8d05",'#10'"`p c #' + +'1f9f10",'#10'"`q c #3eb622",'#10'"`r c #43bb25",'#10'"`s c #4fc52c",'#10'"`' + +'t c #4fbf2d",'#10'"`u c #45af27",'#10'"`v c #097903",'#10'"`w c #0d9006",' + +#10'"`x c #0041bb",'#10'"`y c #0042bb",'#10'"`z c #2a8c17",'#10'"`A c #10900' + +'7",'#10'"`B c #62a3e9",'#10'"`C c #599ce6",'#10'"`D c #599de6",'#10'"`E c #' + +'569ce6",'#10'"`F c #5299e6",'#10'"`G c #589fe9",'#10'"`H c #13740a",'#10'"`' + +'I c #ffffff",'#10'"`J c #effaff",'#10'"`K c #096205",'#10'"`L c #404040",' + +#10'"`M c #000000",'#10'"`N c #c0dcc0",'#10'"`O c #f7fbff",'#10'"`P c #eaf4f' + +'f",'#10'"`Q c #dcedff",'#10'"`R c #cae5fe",'#10'"`S c #d7efff",'#10'"`T c #' + +'feffff",'#10'"`U c #f6fbff",'#10'"`V c #e7f3fe",'#10'"`W c #d9eefe",'#10'"`' + +'X c #cae6ff",'#10'"`Y c #baddfe",'#10'"`Z c #c4e7ff",'#10'"`0 c #f4faff",' + +#10'"`1 c #e7f3ff",'#10'"`2 c #d8ebfe",'#10'"`3 c #c9e5ff",'#10'"`4 c #b8ddf' + +'e",'#10'"`5 c #aad5fe",'#10'"`6 c #b5e1ff",'#10'"`7 c #fbfeff",'#10'"`8 c #' + +'f2f8ff",'#10'".` c #e5f2ff",'#10'".. c #d5ebff",'#10'".# c #c5e3ff",'#10'".' + +'a c #b6dcff",'#10'".b c #a9d4ff",'#10'".c c #9cceff",'#10'".d c #acdcff",' + +#10'".e c #eff6ff",'#10'".f c #e2f0fe",'#10'".g c #d1eaff",'#10'".h c #c4e2f' + +'e",'#10'".i c #b4dafe",'#10'".j c #a5d3fe",'#10'".k c #9ccefe",'#10'".l c #' + +'95cafe",'#10'".m c #abdaff",'#10'".n c #faffff",'#10'".o c #eafaff",'#10'".' + +'p c #c7e7ff",'#10'".q c #b8e1ff",'#10'".r c #addaff",'#10'".s c #a9d9ff",' + +#10'".t c #a7d8ff",'#10'".u c #c2eaff",'#10'".v c #000000",'#10'".w c #00000' + +'0",'#10'".x c #000000",'#10'".y c #000000",'#10'".z c #000000",'#10'".A c #' + +'000000",'#10'".B c #000000",'#10'".C c #000000",'#10'".D c #000000",'#10'".' + +'E c #000000",'#10'".F c #000000",'#10'".G c #000000",'#10'".H c #000000",' + +#10'".I c #000000",'#10'".J c #000000",'#10'".K c #000000",'#10'".L c #00000' + +'0",'#10'".M c #000000",'#10'".N c #000000",'#10'".O c #000000",'#10'".P c #' + +'000000",'#10'".Q c #000000",'#10'".R c #000000",'#10'".S c #000000",'#10'".' + +'T c #000000",'#10'".U c #000000",'#10'".V c #000000",'#10'".W c #000000",' + +#10'".X c #000000",'#10'".Y c #000000",'#10'".Z c #000000",'#10'".0 c #00000' + +'0",'#10'".1 c #000000",'#10'".2 c #000000",'#10'".3 c #000000",'#10'".4 c #' + +'000000",'#10'".5 c #000000",'#10'".6 c #000000",'#10'".7 c #000000",'#10'".' + +'8 c #000000",'#10'"#` c #000000",'#10'"#. c #000000",'#10'"## c #000000",' + +#10'"#a c #000000",'#10'"#b c #000000",'#10'"#c c #000000",'#10'"#d c #00000' + +'0",'#10'"#e c #000000",'#10'"#f c #000000",'#10'"#g c #000000",'#10'"#h c #' + +'000000",'#10'"#i c #000000",'#10'"#j c #000000",'#10'"#k c #000000",'#10'"#' + +'l c #000000",'#10'"#m c #000000",'#10'"#n c #000000",'#10'"#o c #000000",' + +#10'"#p c #000000",'#10'"#q c #000000",'#10'"#r c #000000",'#10'"#s c #00000' + +'0",'#10'"#t c #000000",'#10'"#u c #000000",'#10'"#v c #000000",'#10'"#w c #' + +'000000",'#10'"#x c #000000",'#10'"#y c #000000",'#10'"#z c #000000",'#10'"#' + +'A c #000000",'#10'"#B c #000000",'#10'"#C c #000000",'#10'"#D c #000000",' + +#10'"#E c #000000",'#10'"#F c #000000",'#10'"#G c #000000",'#10'"#H c #00000' + +'0",'#10'"#I c #000000",'#10'"#J c #000000",'#10'"#K c #000000",'#10'"#L c #' + +'000000",'#10'"#M c #000000",'#10'"#N c #000000",'#10'"#O c #000000",'#10'"#' + +'P c #000000",'#10'"#Q c #000000",'#10'"#R c #000000",'#10'"#S c #000000",' + +#10'"#T c #000000",'#10'"#U c #000000",'#10'"#V c #000000",'#10'"#W c #00000' + +'0",'#10'"#X c #000000",'#10'"#Y c #000000",'#10'"#Z c #000000",'#10'"#0 c #' + +'000000",'#10'"#1 c #000000",'#10'"#2 c #000000",'#10'"#3 c #000000",'#10'"#' + +'4 c #000000",'#10'"#5 c #000000",'#10'"#6 c #000000",'#10'"#7 c #000000",' + +#10'"#8 c #000000",'#10'"a` c #000000",'#10'"a. c #000000",'#10'"a# c #00000' + +'0",'#10'"aa c #000000",'#10'"ab c #000000",'#10'"ac c #000000",'#10'"ad c #' + +'000000",'#10'"ae c #000000",'#10'"af c #000000",'#10'"ag c #000000",'#10'"a' + +'h c #000000",'#10'"ai c #000000",'#10'"aj c #000000",'#10'"ak c #000000",' + +#10'"al c #000000",'#10'"am c #000000",'#10'"an c #000000",'#10'"ao c #00000' + +'0",'#10'"ap c #000000",'#10'"aq c #000000",'#10'"ar c #000000",'#10'"as c #' + +'000000",'#10'"at c #000000",'#10'"au c #000000",'#10'"av c #000000",'#10'"a' + +'w c #000000",'#10'"ax c #000000",'#10'"ay c #000000",'#10'"az c #000000",' + +#10'"aA c #000000",'#10'"aB c #000000",'#10'"aC c #000000",'#10'"aD c #00000' + +'0",'#10'"aE c #000000",'#10'"aF c #000000",'#10'"aG c #000000",'#10'"aH c #' + +'000000",'#10'"aI c #000000",'#10'"aJ c #000000",'#10'"aK c #000000",'#10'"a' + ,'L c #000000",'#10'"aM c #000000",'#10'"aN c #000000",'#10'"aO c #000000",' + +#10'"aP c #000000",'#10'"aQ c #000000",'#10'"aR c #000000",'#10'"aS c #00000' + +'0",'#10'"aT c #000000",'#10'"aU c #000000",'#10'"aV c #000000",'#10'"aW c #' + +'000000",'#10'"aX c #000000",'#10'"aY c #000000",'#10'"aZ c #000000",'#10'"a' + +'0 c #000000",'#10'"a1 c #000000",'#10'"a2 c #000000",'#10'"a3 c #000000",' + +#10'"a4 c #000000",'#10'"a5 c #000000",'#10'"a6 c #000000",'#10'"a7 c #00000' + +'0",'#10'"a8 c #000000",'#10'/* pixels */'#10'"`````````````````````````````' + +'```````````````````",'#10'"```````````````````.`.``````````````````````````' + +'",'#10'"`````````````````.`#`#``````````````````````````",'#10'"```````````' + +'````.`#`a`#``````````````````````````",'#10'"`````````````.`.`b`c`#````````' + +'``````````````````",'#10'"```````````d`e`f`g`h`.`.`.`.`.``````````````````"' + +','#10'"`````````.`i`j`h`f`b`k`l`l`m`i`.`.``````````````",'#10'"```````.`n`o' + +'`j`j`p`p`b`q`r`s`t`u`n`.````````````",'#10'"`````.`v`w`o`o`j`h`x`y`y`y`y`y`' + +'y`y`y`y``````````",'#10'"`````.`z`v`o`o`A`y`B`C`C`C`C`C`D`E`F`G`y````````",' + +#10'"```````d`H`v`o`o`y`I`I`I`I`I`I`I`I`J`I`y`.``````",'#10'"`````````d`e`v`' + +'o`y`I`I`x`y`y`y`y`y`y`y`y`y``````",'#10'"```````````.`K`v`y`I`y`B`C`C`C`C`C' + +'`D`E`F`G`y````",'#10'"`````````````.`K`y`I`y`I`I`I`I`I`I`I`I`J`I`y````",'#10 + +'"`L`L`L`L`L`L`L`L`L`L`L`L`L`x`y`y`y`y`y`y`y`y`y``",'#10'"`L`I`I`I`I`I`I`I`I' + +'`I`I`I`L`M`C`C`C`C`C`D`E`F`G`y",'#10'"`L`I`M`M`M`N`I`N`M`M`M`I`L`M`I`I`I`I`' + +'I`I`I`J`I`y",'#10'"`L`I`M`I`N`M`I`M`N`I`I`I`L`M`I`I`I`I`O`P`Q`R`S`y",'#10'"' + +'`L`I`M`M`M`N`I`N`M`M`N`I`L`M`I`I`T`U`V`W`X`Y`Z`y",'#10'"`L`I`M`N`I`I`I`I`I`' + +'N`M`I`L`M`I`T`0`1`2`3`4`5`6`y",'#10'"`L`I`M`I`I`M`M`M`M`M`N`I`L`M`7`8.`...#' + +'.a.b.c.d`y",'#10'"`L`I`I`I`I`I`I`I`I`I`I`I`L`M.e.f.g.h.i.j.k.l.m`y",'#10'"`' + +'L`L`L`L`L`L`L`L`L`L`L`L`L`M.n.o`S.p.q.r.s.t.u`y",'#10'"```M`M`M`M`M`M`M`M`M' + +'`M`M`M`M`y`y`y`y`y`y`y`y`y`y"'#10'};'#10 +]); +LazarusResources.Add('tpsimport_stdctrls','XPM',[ + '/* XPM */'#10'static char *tpsimport_stdctrls[] = {'#10'/* width height num_' + +'colors chars_per_pixel */'#10'" 24 24 256 2",'#10'/* ' + +'colors */'#10'"`` c None",'#10'"`. c #035501",'#10'"`# c #045702",'#10'"`a ' + +'c #1b830f",'#10'"`b c #2daa18",'#10'"`c c #1d8b10",'#10'"`d c #014f00",'#10 + +'"`e c #0b6a05",'#10'"`f c #27a313",'#10'"`g c #29a615",'#10'"`h c #17970c",' + +#10'"`i c #18780d",'#10'"`j c #139309",'#10'"`k c #35af1c",'#10'"`l c #2f9f1' + +'a",'#10'"`m c #289516",'#10'"`n c #218212",'#10'"`o c #0d8d05",'#10'"`p c #' + +'1f9f10",'#10'"`q c #3eb622",'#10'"`r c #43bb25",'#10'"`s c #4fc52c",'#10'"`' + +'t c #4fbf2d",'#10'"`u c #45af27",'#10'"`v c #097903",'#10'"`w c #0d9006",' + +#10'"`x c #3ab41f",'#10'"`y c #5ed035",'#10'"`z c #5fca35",'#10'"`A c #3ca02' + +'2",'#10'"`B c #2a8c17",'#10'"`C c #109007",'#10'"`D c #48bc27",'#10'"`E c #' + +'52c42d",'#10'"`F c #6ad83c",'#10'"`G c #46ac28",'#10'"`H c #13740a",'#10'"`' + +'I c #147b0a",'#10'"`J c #2c9518",'#10'"`K c #64d338",'#10'"`L c #72dc41",' + +#10'"`M c #379c1f",'#10'"`N c #53536b",'#10'"`O c #68d13b",'#10'"`P c #126d0' + +'9",'#10'"`Q c #096205",'#10'"`R c #b8abbc",'#10'"`S c #b493a1",'#10'"`T c #' + +'b49fad",'#10'"`U c #b598a6",'#10'"`V c #5c5b78",'#10'"`W c #edeef4",'#10'"`' + +'X c #e9e5ed",'#10'"`Y c #ab4c50",'#10'"`Z c #8f1112",'#10'"`0 c #c57b7d",' + +#10'"`1 c #d5b6c0",'#10'"`2 c #d0d3e7",'#10'"`3 c #404040",'#10'"`4 c #cfc5d' + +'3",'#10'"`5 c #d4c2cc",'#10'"`6 c #ebe0e5",'#10'"`7 c #e2d8de",'#10'"`8 c #' + +'b8c2de",'#10'".` c #9f9ece",'#10'".. c #998bcc",'#10'".# c #968cc9",'#10'".' + +'a c #ffffff",'#10'".b c #000000",'#10'".c c #afb0cb",'#10'".d c #cbcede",' + +#10'".e c #cbcce0",'#10'".f c #9f9cc7",'#10'".g c #69898c",'#10'".h c #37874' + +'a",'#10'".i c #568e75",'#10'".j c #c0dcc0",'#10'".k c #487dc4",'#10'".l c #' + +'d4d0dc",'#10'".m c #d3d3e3",'#10'".n c #9fa0c6",'#10'".o c #006500",'#10'".' + +'p c #908bc7",'#10'".q c #4b7dc0",'#10'".r c #9db5d9",'#10'".s c #ddd8e7",' + +#10'".t c #a7a3d3",'#10'".u c #7e8eac",'#10'".v c #668e91",'#10'".w c #4679c' + +'0",'#10'".x c #9db4d8",'#10'".y c #e0dcea",'#10'".z c #b0a5e0",'#10'".A c #' + +'45895f",'#10'".B c #808eb6",'#10'".C c #8390c0",'#10'".D c #8482c0",'#10'".' + +'E c #3d76c1",'#10'".F c #cecbd9",'#10'".G c #dad9ea",'#10'".H c #a4a6d0",' + +#10'".I c #678b92",'#10'".J c #9a90de",'#10'".K c #9190d5",'#10'".L c #9192d' + +'9",'#10'".M c #9fa6c6",'#10'".N c #cbc9d8",'#10'".O c #dcdaef",'#10'".P c #' + +'84a4a9",'#10'".Q c #9c91e2",'#10'".R c #9292d9",'#10'".S c #8f8fd7",'#10'".' + +'T c #b1b0c9",'#10'".U c #c5c5d8",'#10'".V c #dcdcee",'#10'".W c #a1a6d4",' + +#10'".X c #9298cf",'#10'".Y c #8c8bcf",'#10'".Z c #a3a3b8",'#10'".0 c #bfbfd' + +'7",'#10'".1 c #8c8cc6",'#10'".2 c #000000",'#10'".3 c #000000",'#10'".4 c #' + +'000000",'#10'".5 c #000000",'#10'".6 c #000000",'#10'".7 c #000000",'#10'".' + +'8 c #000000",'#10'"#` c #000000",'#10'"#. c #000000",'#10'"## c #000000",' + +#10'"#a c #000000",'#10'"#b c #000000",'#10'"#c c #000000",'#10'"#d c #00000' + +'0",'#10'"#e c #000000",'#10'"#f c #000000",'#10'"#g c #000000",'#10'"#h c #' + +'000000",'#10'"#i c #000000",'#10'"#j c #000000",'#10'"#k c #000000",'#10'"#' + +'l c #000000",'#10'"#m c #000000",'#10'"#n c #000000",'#10'"#o c #000000",' + +#10'"#p c #000000",'#10'"#q c #000000",'#10'"#r c #000000",'#10'"#s c #00000' + +'0",'#10'"#t c #000000",'#10'"#u c #000000",'#10'"#v c #000000",'#10'"#w c #' + +'000000",'#10'"#x c #000000",'#10'"#y c #000000",'#10'"#z c #000000",'#10'"#' + +'A c #000000",'#10'"#B c #000000",'#10'"#C c #000000",'#10'"#D c #000000",' + +#10'"#E c #000000",'#10'"#F c #000000",'#10'"#G c #000000",'#10'"#H c #00000' + +'0",'#10'"#I c #000000",'#10'"#J c #000000",'#10'"#K c #000000",'#10'"#L c #' + +'000000",'#10'"#M c #000000",'#10'"#N c #000000",'#10'"#O c #000000",'#10'"#' + +'P c #000000",'#10'"#Q c #000000",'#10'"#R c #000000",'#10'"#S c #000000",' + +#10'"#T c #000000",'#10'"#U c #000000",'#10'"#V c #000000",'#10'"#W c #00000' + +'0",'#10'"#X c #000000",'#10'"#Y c #000000",'#10'"#Z c #000000",'#10'"#0 c #' + +'000000",'#10'"#1 c #000000",'#10'"#2 c #000000",'#10'"#3 c #000000",'#10'"#' + +'4 c #000000",'#10'"#5 c #000000",'#10'"#6 c #000000",'#10'"#7 c #000000",' + +#10'"#8 c #000000",'#10'"a` c #000000",'#10'"a. c #000000",'#10'"a# c #00000' + +'0",'#10'"aa c #000000",'#10'"ab c #000000",'#10'"ac c #000000",'#10'"ad c #' + +'000000",'#10'"ae c #000000",'#10'"af c #000000",'#10'"ag c #000000",'#10'"a' + +'h c #000000",'#10'"ai c #000000",'#10'"aj c #000000",'#10'"ak c #000000",' + +#10'"al c #000000",'#10'"am c #000000",'#10'"an c #000000",'#10'"ao c #00000' + +'0",'#10'"ap c #000000",'#10'"aq c #000000",'#10'"ar c #000000",'#10'"as c #' + +'000000",'#10'"at c #000000",'#10'"au c #000000",'#10'"av c #000000",'#10'"a' + +'w c #000000",'#10'"ax c #000000",'#10'"ay c #000000",'#10'"az c #000000",' + +#10'"aA c #000000",'#10'"aB c #000000",'#10'"aC c #000000",'#10'"aD c #00000' + +'0",'#10'"aE c #000000",'#10'"aF c #000000",'#10'"aG c #000000",'#10'"aH c #' + +'000000",'#10'"aI c #000000",'#10'"aJ c #000000",'#10'"aK c #000000",'#10'"a' + ,'L c #000000",'#10'"aM c #000000",'#10'"aN c #000000",'#10'"aO c #000000",' + +#10'"aP c #000000",'#10'"aQ c #000000",'#10'"aR c #000000",'#10'"aS c #00000' + +'0",'#10'"aT c #000000",'#10'"aU c #000000",'#10'"aV c #000000",'#10'"aW c #' + +'000000",'#10'"aX c #000000",'#10'"aY c #000000",'#10'"aZ c #000000",'#10'"a' + +'0 c #000000",'#10'"a1 c #000000",'#10'"a2 c #000000",'#10'"a3 c #000000",' + +#10'"a4 c #000000",'#10'"a5 c #000000",'#10'"a6 c #000000",'#10'"a7 c #00000' + +'0",'#10'"a8 c #000000",'#10'/* pixels */'#10'"`````````````````````````````' + +'```````````````````",'#10'"```````````````````.`.``````````````````````````' + +'",'#10'"`````````````````.`#`#``````````````````````````",'#10'"```````````' + +'````.`#`a`#``````````````````````````",'#10'"`````````````.`.`b`c`#````````' + +'``````````````````",'#10'"```````````d`e`f`g`h`.`.`.`.`.``````````````````"' + +','#10'"`````````.`i`j`h`f`b`k`l`l`m`i`.`.``````````````",'#10'"```````.`n`o' + +'`j`j`p`p`b`q`r`s`t`u`n`.````````````",'#10'"`````.`v`w`o`o`j`h`f`f`k`x`r`s`' + +'y`z`A`.``````````",'#10'"`````.`B`v`o`o`C`h`p`f`b`k`q`D`E`y`F`G`.````````",' + +#10'"```````d`H`v`o`o`j`v`m`a`I`I`H`J`t`K`L`l`.``````",'#10'"`````````d`e`v`' + +'o`j`M`d`d`.`.`N`N`N`N`O`O`P``````",'#10'"```````````.`Q`v`C`l`d```N`N`R`S`T' + +'`U`N`N`V`.````",'#10'"`````````````.`Q`v`A`N`N`W`X`Y`Z`Z`0`1`2`N`.````",'#10 + +'"`3`3`3`3`3`3`3`3`3`3`3`3`3`4`5`6`7`8.`...#`N````",'#10'"`3.a.a.a.a.a.a.a.a' + +'.a.a.a`3.b.c.d.e.f.g.h.i`N````",'#10'"`3.a.b.b.b.j.a.j.b.b.b.a`3.b.k.l.m.n.' + +'o.o.o.p`N``",'#10'"`3.a.b.a.j.b.a.b.j.a.a.a`3.b.q.r.s.t.u.o.o.v`N``",'#10'"' + +'`3.a.b.b.b.j.a.j.b.b.j.a`3.b.w.x.y.z.A.o.B.C.D`N",'#10'"`3.a.b.j.a.a.a.a.a.' + +'j.b.a`3.b.E.F.G.H.o.I.J.K.L`N",'#10'"`3.a.b.a.a.b.b.b.b.b.j.a`3.b.M.N.O.P.o' + +'.Q.R.S`N`N",'#10'"`3.a.a.a.a.a.a.a.a.a.a.a`3.b.T.U.V.W.X.Y`N`N````",'#10'"`' + +'3`3`3`3`3`3`3`3`3`3`3`3`3.b`N.Z.0.1`N`N````````",'#10'"``.b.b.b.b.b.b.b.b.b' + +'.b.b.b.b```V`N`N````````````"'#10'};'#10 +]); +LazarusResources.Add('tpsscript','XPM',[ + '/* XPM */'#10'static char *tpsscript[] = {'#10'/* width height num_colors ch' + +'ars_per_pixel */'#10'" 24 24 256 2",'#10'/* colors */' + +#10'"`` c None",'#10'"`. c #515151",'#10'"`# c #535353",'#10'"`a c #4b4b4b",' + +#10'"`b c #d8d8d8",'#10'"`c c #efefef",'#10'"`d c #f2f2f2",'#10'"`e c #f3f3f' + +'3",'#10'"`f c #f4f4f4",'#10'"`g c #f2f2f3",'#10'"`h c #f0f0f2",'#10'"`i c #' + +'ebebeb",'#10'"`j c #e6e6e6",'#10'"`k c #e0e0e1",'#10'"`l c #d9d9d9",'#10'"`' + +'m c #d3d3d3",'#10'"`n c #cfcfcf",'#10'"`o c #cacacb",'#10'"`p c #c7c7c7",' + +#10'"`q c #c5c5c5",'#10'"`r c #c2c2c2",'#10'"`s c #676768",'#10'"`t c #31313' + +'1",'#10'"`u c #e9e9e9",'#10'"`v c #eeeeee",'#10'"`w c #ededed",'#10'"`x c #' + +'eaeaea",'#10'"`y c #e3e3e3",'#10'"`z c #dadada",'#10'"`A c #cecece",'#10'"`' + +'B c #c1c1c1",'#10'"`C c #b1b1b1",'#10'"`D c #a4a4a5",'#10'"`E c #9c9c9c",' + +#10'"`F c #959595",'#10'"`G c #8c8c8c",'#10'"`H c #888889",'#10'"`I c #83838' + +'3",'#10'"`J c #efeff0",'#10'"`K c #e7e7e7",'#10'"`L c #e2e2e2",'#10'"`M c #' + +'d0d0d0",'#10'"`N c #c6c6c6",'#10'"`O c #b6b6b7",'#10'"`P c #aaaaaa",'#10'"`' + +'Q c #9d9d9d",'#10'"`R c #939395",'#10'"`S c #888888",'#10'"`T c #7f7f82",' + +#10'"`U c #67676b",'#10'"`V c #dadadc",'#10'"`W c #d5d5d5",'#10'"`X c #ccccc' + +'e",'#10'"`Y c #c6c6c7",'#10'"`Z c #bdbdbf",'#10'"`0 c #b6b6b6",'#10'"`1 c #' + +'ababab",'#10'"`2 c #9e9e9f",'#10'"`3 c #959596",'#10'"`4 c #8f8f8f",'#10'"`' + +'5 c #878787",'#10'"`6 c #828282",'#10'"`7 c #7f7f87",'#10'"`8 c #66676d",' + +#10'".` c #cfcfd0",'#10'".. c #cccccc",'#10'".# c #c4c4c5",'#10'".a c #bcbcb' + +'d",'#10'".b c #b5b5b5",'#10'".c c #acacad",'#10'".d c #a9a9aa",'#10'".e c #' + +'9f9f9f",'#10'".f c #979797",'#10'".g c #8e8e8e",'#10'".h c #868686",'#10'".' + +'i c #7f7f83",'#10'".j c #7f7f88",'#10'".k c #7e7f8e",'#10'".l c #676770",' + +#10'".m c #e0e0e0",'#10'".n c #bcbcbc",'#10'".o c #b2b2b4",'#10'".p c #a1a1a' + +'3",'#10'".q c #939393",'#10'".r c #818182",'#10'".s c #7e7e89",'#10'".t c #' + +'7e7f8f",'#10'".u c #7e7e92",'#10'".v c #666675",'#10'".w c #c4c4c4",'#10'".' + +'x c #e3e3e4",'#10'".y c #ffffff",'#10'".z c #b9b9bb",'#10'".A c #7e7f89",' + +#10'".B c #7f7f8f",'#10'".C c #7e7e98",'#10'".D c #656677",'#10'".E c #d3d3d' + +'4",'#10'".F c #e5e5e5",'#10'".G c #e4e4e4",'#10'".H c #7f7f84",'#10'".I c #' + +'7e7f8a",'#10'".J c #7e7e93",'#10'".K c #7d7e9e",'#10'".L c #65657a",'#10'".' + +'M c #f0f0f0",'#10'".N c #e1e1e1",'#10'".O c #bebebf",'#10'".P c #989899",' + +#10'".Q c #7b7da3",'#10'".R c #65657e",'#10'".S c #afafb0",'#10'".T c #aaaaa' + +'b",'#10'".U c #9e9e9e",'#10'".V c #a6a6a6",'#10'".W c #7e7f8b",'#10'".X c #' + +'7f7f90",'#10'".Y c #7e7e95",'#10'".Z c #7d7d99",'#10'".0 c #7d7e9f",'#10'".' + +'1 c #7a7ba9",'#10'".2 c #656580",'#10'".3 c #e9e9ea",'#10'".4 c #d0d0d1",' + +#10'".5 c #a7a7a7",'#10'".6 c #a3a3a3",'#10'".7 c #c1c1c2",'#10'".8 c #a3a3a' + +'6",'#10'"#` c #eeeff0",'#10'"#. c #7f7f91",'#10'"## c #7e7e97",'#10'"#a c #' + +'7d7d9a",'#10'"#b c #7d7ea0",'#10'"#c c #7b7da4",'#10'"#d c #7a7baa",'#10'"#' + +'e c #7b7baf",'#10'"#f c #646584",'#10'"#g c #999999",'#10'"#h c #909090",' + +#10'"#i c #d1d1d1",'#10'"#j c #a3a3a9",'#10'"#k c #efeff1",'#10'"#l c #7b7ba' + +'a",'#10'"#m c #7b7daf",'#10'"#n c #7a7bb4",'#10'"#o c #646587",'#10'"#p c #' + +'404040",'#10'"#q c #b8b8c9",'#10'"#r c #cbccda",'#10'"#s c #a0a2bf",'#10'"#' + +'t c #7b7bab",'#10'"#u c #7b7db0",'#10'"#v c #7a7bb5",'#10'"#w c #7a7bb8",' + +#10'"#x c #000000",'#10'"#y c #dddee8",'#10'"#z c #7b7bac",'#10'"#A c #7b7db' + +'1",'#10'"#B c #c0dcc0",'#10'"#C c #7b7da7",'#10'"#D c #7a7bb7",'#10'"#E c #' + +'7a7bb2",'#10'"#F c #626283",'#10'"#G c #000000",'#10'"#H c #000000",'#10'"#' + +'I c #000000",'#10'"#J c #000000",'#10'"#K c #000000",'#10'"#L c #000000",' + +#10'"#M c #000000",'#10'"#N c #000000",'#10'"#O c #000000",'#10'"#P c #00000' + +'0",'#10'"#Q c #000000",'#10'"#R c #000000",'#10'"#S c #000000",'#10'"#T c #' + +'000000",'#10'"#U c #000000",'#10'"#V c #000000",'#10'"#W c #000000",'#10'"#' + +'X c #000000",'#10'"#Y c #000000",'#10'"#Z c #000000",'#10'"#0 c #000000",' + +#10'"#1 c #000000",'#10'"#2 c #000000",'#10'"#3 c #000000",'#10'"#4 c #00000' + +'0",'#10'"#5 c #000000",'#10'"#6 c #000000",'#10'"#7 c #000000",'#10'"#8 c #' + +'000000",'#10'"a` c #000000",'#10'"a. c #000000",'#10'"a# c #000000",'#10'"a' + +'a c #000000",'#10'"ab c #000000",'#10'"ac c #000000",'#10'"ad c #000000",' + +#10'"ae c #000000",'#10'"af c #000000",'#10'"ag c #000000",'#10'"ah c #00000' + +'0",'#10'"ai c #000000",'#10'"aj c #000000",'#10'"ak c #000000",'#10'"al c #' + +'000000",'#10'"am c #000000",'#10'"an c #000000",'#10'"ao c #000000",'#10'"a' + +'p c #000000",'#10'"aq c #000000",'#10'"ar c #000000",'#10'"as c #000000",' + +#10'"at c #000000",'#10'"au c #000000",'#10'"av c #000000",'#10'"aw c #00000' + +'0",'#10'"ax c #000000",'#10'"ay c #000000",'#10'"az c #000000",'#10'"aA c #' + +'000000",'#10'"aB c #000000",'#10'"aC c #000000",'#10'"aD c #000000",'#10'"a' + +'E c #000000",'#10'"aF c #000000",'#10'"aG c #000000",'#10'"aH c #000000",' + +#10'"aI c #000000",'#10'"aJ c #000000",'#10'"aK c #000000",'#10'"aL c #00000' + ,'0",'#10'"aM c #000000",'#10'"aN c #000000",'#10'"aO c #000000",'#10'"aP c #' + +'000000",'#10'"aQ c #000000",'#10'"aR c #000000",'#10'"aS c #000000",'#10'"a' + +'T c #000000",'#10'"aU c #000000",'#10'"aV c #000000",'#10'"aW c #000000",' + +#10'"aX c #000000",'#10'"aY c #000000",'#10'"aZ c #000000",'#10'"a0 c #00000' + +'0",'#10'"a1 c #000000",'#10'"a2 c #000000",'#10'"a3 c #000000",'#10'"a4 c #' + +'000000",'#10'"a5 c #000000",'#10'"a6 c #000000",'#10'"a7 c #000000",'#10'"a' + +'8 c #000000",'#10'/* pixels */'#10'"```````````````````````````````````````' + +'`````````",'#10'"`````.`.`.`.`.`.`.`.`.`.`.`.`.`.`.`#`.`.`.`.````",'#10'"``' + +'`a`b`c`d`e`f`e`g`h`c`i`j`k`l`m`n`o`p`q`r`s`t``",'#10'"```a`c`u`v`h`h`c`w`x`' + +'y`z`A`B`C`D`E`F`G`H`I`s`t``",'#10'"```a`d`v`g`J`v`i`K`L`z`M`N`O`P`Q`R`G`S`I' + +'`T`U`t``",'#10'"```a`e`J`v`V`b`W`X`Y`Z`O`0`1`2`3`4`5`6`T`7`8`t``",'#10'"```' + +'a`e`v`j.``m...#.a.b.c.d.e.f.g.h`6.i.j.k.l`t``",'#10'"```a`e`i.m`X`n`p.n.o`1' + +'.p`E.q`G.h.r.i.s.t.u.v`t``",'#10'"```a`g`u`z.w.#.x.y.y.y.y.y.y.y.y.z.A.B.u.' + +'C.D`t``",'#10'"```a`d`j.E`Z..`x`z.F.G.g.y.y.r.H.I.B.J.C.K.L`t``",'#10'"```a' + +'.M.N`X`0`p.O.P`y`L`S.y.y.H.I.B.J.C.K.Q.R`t``",'#10'"```a`v`z`N.S.T.U`C`L`M.' + +'V.y`J.W.X.Y.Z.0.Q.1.2`t``",'#10'"```a.3.4.a.5.6.f.7.M`A.8.y#`#.###a#b#c#d#e' + +'#f`t``",'#10'"```a`L`B`C.e#g#h#i.y.z#j.y#k###a#b#c#l#m#n#o`t``",'#10'"#p#p#' + +'p#p#p#p#p#p#p#p#p#p#p.y#q#r#s#t#u#v#w#o`t``",'#10'"#p.y.y.y.y.y.y.y.y.y.y.y' + +'#p#x.y#y#z#A#v#w#w#o`t``",'#10'"#p.y#x#x#x#B.y#B#x#x#x.y#p#x#C#z#A#D#w#w#w#' + +'o`t``",'#10'"#p.y#x.y#B#x.y#x#B.y.y.y#p#x#z#E#w#w#w#w#w#o`t``",'#10'"#p.y#x' + +'#x#x#B.y#B#x#x#B.y#p#x#E#w#w#w#w#w#w#o`t``",'#10'"#p.y#x#B.y.y.y.y.y#B#x.y#' + +'p#x#w#w#w#w#w#w#w#o`t``",'#10'"#p.y#x.y.y#x#x#x#x#x#B.y#p#x#w#w#w#w#w#w#w#o' + +'`t``",'#10'"#p.y.y.y.y.y.y.y.y.y.y.y#p#x#o#o#o#o#o#o#o#F`t``",'#10'"#p#p#p#' + +'p#p#p#p#p#p#p#p#p#p#x`t`t`t`t`t`t`t`t````",'#10'"``#x#x#x#x#x#x#x#x#x#x#x#x' + +'#x````````````````````"'#10'};'#10 +]); +LazarusResources.Add('tpsscriptdebugger','XPM',[ + '/* XPM */'#10'static char *tpsscriptdebugger[] = {'#10'/* width height num_c' + +'olors chars_per_pixel */'#10'" 24 24 256 2",'#10'/* c' + +'olors */'#10'"`` c #000000",'#10'"`. c #000055",'#10'"`# c #0000aa",'#10'"`' + +'a c #0000ff",'#10'"`b c #002400",'#10'"`c c #002455",'#10'"`d c #0024aa",' + +#10'"`e c #0024ff",'#10'"`f c #004800",'#10'"`g c #004855",'#10'"`h c #0048a' + +'a",'#10'"`i c #0048ff",'#10'"`j c #006d00",'#10'"`k c #006d55",'#10'"`l c #' + +'006daa",'#10'"`m c #006dff",'#10'"`n c #009100",'#10'"`o c #009155",'#10'"`' + +'p c #0091aa",'#10'"`q c #0091ff",'#10'"`r c #00b600",'#10'"`s c #00b655",' + +#10'"`t c #00b6aa",'#10'"`u c #00b6ff",'#10'"`v c #00da00",'#10'"`w c #00da5' + +'5",'#10'"`x c #00daaa",'#10'"`y c #00daff",'#10'"`z c #00ff00",'#10'"`A c #' + +'00ff55",'#10'"`B c #00ffaa",'#10'"`C c #00ffff",'#10'"`D c #240000",'#10'"`' + +'E c #240055",'#10'"`F c #2400aa",'#10'"`G c #2400ff",'#10'"`H c #242400",' + +#10'"`I c #242455",'#10'"`J c #2424aa",'#10'"`K c #2424ff",'#10'"`L c #24480' + +'0",'#10'"`M c #244855",'#10'"`N c #2448aa",'#10'"`O c #2448ff",'#10'"`P c #' + +'246d00",'#10'"`Q c #246d55",'#10'"`R c #246daa",'#10'"`S c #246dff",'#10'"`' + +'T c #249100",'#10'"`U c #249155",'#10'"`V c #2491aa",'#10'"`W c #2491ff",' + +#10'"`X c #24b600",'#10'"`Y c #24b655",'#10'"`Z c #24b6aa",'#10'"`0 c #24b6f' + +'f",'#10'"`1 c #24da00",'#10'"`2 c #24da55",'#10'"`3 c #24daaa",'#10'"`4 c #' + +'24daff",'#10'"`5 c #24ff00",'#10'"`6 c #24ff55",'#10'"`7 c #24ffaa",'#10'"`' + +'8 c #24ffff",'#10'".` c #480000",'#10'".. c #480055",'#10'".# c #4800aa",' + +#10'".a c #4800ff",'#10'".b c #482400",'#10'".c c #482455",'#10'".d c #4824a' + +'a",'#10'".e c #4824ff",'#10'".f c #484800",'#10'".g c #484855",'#10'".h c #' + +'4848aa",'#10'".i c #4848ff",'#10'".j c #486d00",'#10'".k c #486d55",'#10'".' + +'l c #486daa",'#10'".m c #486dff",'#10'".n c #489100",'#10'".o c #489155",' + +#10'".p c #4891aa",'#10'".q c #4891ff",'#10'".r c #48b600",'#10'".s c #48b65' + +'5",'#10'".t c #48b6aa",'#10'".u c #48b6ff",'#10'".v c #48da00",'#10'".w c #' + +'48da55",'#10'".x c #48daaa",'#10'".y c #48daff",'#10'".z c #48ff00",'#10'".' + +'A c #48ff55",'#10'".B c #48ffaa",'#10'".C c #48ffff",'#10'".D c #6d0000",' + +#10'".E c #6d0055",'#10'".F c #6d00aa",'#10'".G c #6d00ff",'#10'".H c #6d240' + +'0",'#10'".I c #6d2455",'#10'".J c #6d24aa",'#10'".K c #6d24ff",'#10'".L c #' + +'6d4800",'#10'".M c #6d4855",'#10'".N c #6d48aa",'#10'".O c #6d48ff",'#10'".' + +'P c #6d6d00",'#10'".Q c #6d6d55",'#10'".R c #6d6daa",'#10'".S c #6d6dff",' + +#10'".T c #6d9100",'#10'".U c #6d9155",'#10'".V c #6d91aa",'#10'".W c #6d91f' + +'f",'#10'".X c #6db600",'#10'".Y c #6db655",'#10'".Z c #6db6aa",'#10'".0 c #' + +'6db6ff",'#10'".1 c #6dda00",'#10'".2 c #6dda55",'#10'".3 c #6ddaaa",'#10'".' + +'4 c #6ddaff",'#10'".5 c #6dff00",'#10'".6 c #6dff55",'#10'".7 c #6dffaa",' + +#10'".8 c #6dffff",'#10'"#` c #910000",'#10'"#. c #910055",'#10'"## c #9100a' + +'a",'#10'"#a c #9100ff",'#10'"#b c #912400",'#10'"#c c #912455",'#10'"#d c #' + +'9124aa",'#10'"#e c #9124ff",'#10'"#f c #914800",'#10'"#g c #914855",'#10'"#' + +'h c #9148aa",'#10'"#i c #9148ff",'#10'"#j c #916d00",'#10'"#k c #916d55",' + +#10'"#l c #916daa",'#10'"#m c #916dff",'#10'"#n c #919100",'#10'"#o c #91915' + +'5",'#10'"#p c #9191aa",'#10'"#q c #9191ff",'#10'"#r c #91b600",'#10'"#s c #' + +'91b655",'#10'"#t c #91b6aa",'#10'"#u c #91b6ff",'#10'"#v c #91da00",'#10'"#' + +'w c #91da55",'#10'"#x c #91daaa",'#10'"#y c #91daff",'#10'"#z c #91ff00",' + +#10'"#A c #91ff55",'#10'"#B c #91ffaa",'#10'"#C c #91ffff",'#10'"#D c #b6000' + +'0",'#10'"#E c #b60055",'#10'"#F c #b600aa",'#10'"#G c #b600ff",'#10'"#H c #' + +'b62400",'#10'"#I c #b62455",'#10'"#J c #b624aa",'#10'"#K c #b624ff",'#10'"#' + +'L c #b64800",'#10'"#M c #b64855",'#10'"#N c #b648aa",'#10'"#O c #b648ff",' + +#10'"#P c #b66d00",'#10'"#Q c #b66d55",'#10'"#R c #b66daa",'#10'"#S c #b66df' + +'f",'#10'"#T c #b69100",'#10'"#U c #b69155",'#10'"#V c #b691aa",'#10'"#W c #' + +'b691ff",'#10'"#X c #b6b600",'#10'"#Y c #b6b655",'#10'"#Z c #b6b6aa",'#10'"#' + +'0 c #b6b6ff",'#10'"#1 c #b6da00",'#10'"#2 c #b6da55",'#10'"#3 c #b6daaa",' + +#10'"#4 c #b6daff",'#10'"#5 c #b6ff00",'#10'"#6 c #b6ff55",'#10'"#7 c #b6ffa' + +'a",'#10'"#8 c #b6ffff",'#10'"a` c #da0000",'#10'"a. c #da0055",'#10'"a# c #' + +'da00aa",'#10'"aa c #da00ff",'#10'"ab c #da2400",'#10'"ac c #da2455",'#10'"a' + +'d c #da24aa",'#10'"ae c #da24ff",'#10'"af c #da4800",'#10'"ag c #da4855",' + +#10'"ah c #da48aa",'#10'"ai c #da48ff",'#10'"aj c #da6d00",'#10'"ak c #da6d5' + +'5",'#10'"al c #da6daa",'#10'"am c #da6dff",'#10'"an c #da9100",'#10'"ao c #' + +'da9155",'#10'"ap c #da91aa",'#10'"aq c #da91ff",'#10'"ar c #dab600",'#10'"a' + +'s c #dab655",'#10'"at c #dab6aa",'#10'"au c #dab6ff",'#10'"av c #dada00",' + +#10'"aw c #dada55",'#10'"ax c #dadaaa",'#10'"ay c #dadaff",'#10'"az c #daff0' + +'0",'#10'"aA c #daff55",'#10'"aB c #daffaa",'#10'"aC c #daffff",'#10'"aD c #' + +'ff0000",'#10'"aE c #ff0055",'#10'"aF c #ff00aa",'#10'"aG c None",'#10'"aH c' + +' #ff2400",'#10'"aI c #ff2455",'#10'"aJ c #ff24aa",'#10'"aK c #ff24ff",'#10 + ,'"aL c #ff4800",'#10'"aM c #ff4855",'#10'"aN c #ff48aa",'#10'"aO c #ff48ff",' + +#10'"aP c #ff6d00",'#10'"aQ c #ff6d55",'#10'"aR c #ff6daa",'#10'"aS c #ff6df' + +'f",'#10'"aT c #ff9100",'#10'"aU c #ff9155",'#10'"aV c #ff91aa",'#10'"aW c #' + +'ff91ff",'#10'"aX c #ffb600",'#10'"aY c #ffb655",'#10'"aZ c #ffb6aa",'#10'"a' + +'0 c #ffb6ff",'#10'"a1 c #ffda00",'#10'"a2 c #ffda55",'#10'"a3 c #ffdaaa",' + +#10'"a4 c #ffdaff",'#10'"a5 c #ffff00",'#10'"a6 c #ffff55",'#10'"a7 c #ffffa' + +'a",'#10'"a8 c #ffffff",'#10'/* pixels */'#10'"aGaGaGaGaGaGaGaGaGaGaGaGaGaGa' + +'GaGaGaGaGaGaGaGaGaG",'#10'"aGaG.g.g.g.g.g.g.g.Q.g.g.g.g.g.g.g.Q.g.g.g.gaGaG' + +'",'#10'"aG.gayaya8aya8aya8aya8aya8axayaxay#Zay#Zay.Q.gaG",'#10'"aG.ga8a8aya' + +'8a8a8aya8ayayax#Z#Z#Z#p#p#p#p#o.Q`IaG",'#10'"aG.ga8aya8aya8axa8ayay#Zay#Z#Z' + +'#p#Z#p#p.Q#p.Q.gaG",'#10'"aG.ga8a8a8ayaxayaxay#Z#Z#Z#Z#p#p#p#p.Q#p#p.R`IaG"' + +','#10'"aG.ga8aya8#Zay#Zay#Z#0#Z#Z#p#Z#o#p.Q#p.Q#p.Q.gaG",'#10'"aG.ga8a8ayay' + +'axay#Z#Z#Z#Z#p#p#p#p#o#p.R#p.R.R`IaG",'#10'"aG.ga8axay#Zayaxa8a8a8a8a8a8a8a' + +'8ay.Q#p.Q#p.Q.gaG",'#10'"aG.ga8ayay#Z#Za8aya8ay#pa8a8.Q#p#p#p.R#p.V.R`HaG",' + +#10'"aG.ga8axay#Zay#Z#Zaxa8#oa8atao#Laj#Laj#P#p.Q.gaG",'#10'"aG.ga8ay#Z#Z#Z#' + +'Z#Zayax#ZaoafaYaZaZaYaUaUaf#k`IaG",'#10'"aG.ga8#Zay#p#Z#oayayayakajaZa3aUaU' + +'aPaUaPaQ#L.gaG",'#10'"aG.gay#Z#Z#Z#p#paya8atafaZaZaPaPaPaPaPaPaPaP#LaG",'#10 + +'".g.g.g.g.g.g.g.g.g.g.g.g.gaPaPa8aYaUa8afaPafaj.H",'#10'".ga8a8a8a8a8a8a8a8' + +'a8a8a8.g``aPa8aUaUa8aPafafaf#f",'#10'".ga8``````#3a8#3``````a8.g``aPa8aYaUa' + +'8afajafaj#b",'#10'".ga8``a8#3``a8``#3a8a8a8.g``aPa8aUaUa8afafaf#L#f",'#10'"' + +'.ga8``````#3a8#3````aya8.g``aPa8aUaoa8afaj#Laf.H",'#10'".ga8``aya8a8a8a8a8#' + +'3``a8.g``aja8aoaoa8afafaf.baG",'#10'".ga8``a8a8``````````aya8.g``ajafajafaj' + +'#Laj#f.HaG",'#10'".ga8a8a8a8a8a8a8a8a8a8a8.g``afaf#Laf#L#L#f.baGaG",'#10'".' + +'g.g.g.g.g.g.g.g.g.g.g.g.g``.L#L#L#f#L.b.HaGaGaG",'#10'"aG``````````````````' + +'````````aG.H.H.H.HaGaGaGaGaG"'#10'};'#10 +]); +LazarusResources.Add('tpsscriptextension','XPM',[ + '/* XPM */'#10'static char *tpsscriptdebugger[] = {'#10'/* width height num_c' + +'olors chars_per_pixel */'#10'" 24 24 256 2",'#10'/* c' + +'olors */'#10'"`` c #000000",'#10'"`. c #000055",'#10'"`# c #0000aa",'#10'"`' + +'a c #0000ff",'#10'"`b c #002400",'#10'"`c c #002455",'#10'"`d c #0024aa",' + +#10'"`e c #0024ff",'#10'"`f c #004800",'#10'"`g c #004855",'#10'"`h c #0048a' + +'a",'#10'"`i c #0048ff",'#10'"`j c #006d00",'#10'"`k c #006d55",'#10'"`l c #' + +'006daa",'#10'"`m c #006dff",'#10'"`n c #009100",'#10'"`o c #009155",'#10'"`' + +'p c #0091aa",'#10'"`q c #0091ff",'#10'"`r c #00b600",'#10'"`s c #00b655",' + +#10'"`t c #00b6aa",'#10'"`u c #00b6ff",'#10'"`v c #00da00",'#10'"`w c #00da5' + +'5",'#10'"`x c #00daaa",'#10'"`y c #00daff",'#10'"`z c #00ff00",'#10'"`A c #' + +'00ff55",'#10'"`B c #00ffaa",'#10'"`C c #00ffff",'#10'"`D c #240000",'#10'"`' + +'E c #240055",'#10'"`F c #2400aa",'#10'"`G c #2400ff",'#10'"`H c #242400",' + +#10'"`I c #242455",'#10'"`J c #2424aa",'#10'"`K c #2424ff",'#10'"`L c #24480' + +'0",'#10'"`M c #244855",'#10'"`N c #2448aa",'#10'"`O c #2448ff",'#10'"`P c #' + +'246d00",'#10'"`Q c #246d55",'#10'"`R c #246daa",'#10'"`S c #246dff",'#10'"`' + +'T c #249100",'#10'"`U c #249155",'#10'"`V c #2491aa",'#10'"`W c #2491ff",' + +#10'"`X c #24b600",'#10'"`Y c #24b655",'#10'"`Z c #24b6aa",'#10'"`0 c #24b6f' + +'f",'#10'"`1 c #24da00",'#10'"`2 c #24da55",'#10'"`3 c #24daaa",'#10'"`4 c #' + +'24daff",'#10'"`5 c #24ff00",'#10'"`6 c #24ff55",'#10'"`7 c #24ffaa",'#10'"`' + +'8 c #24ffff",'#10'".` c #480000",'#10'".. c #480055",'#10'".# c #4800aa",' + +#10'".a c #4800ff",'#10'".b c #482400",'#10'".c c #482455",'#10'".d c #4824a' + +'a",'#10'".e c #4824ff",'#10'".f c #484800",'#10'".g c #484855",'#10'".h c #' + +'4848aa",'#10'".i c #4848ff",'#10'".j c #486d00",'#10'".k c #486d55",'#10'".' + +'l c #486daa",'#10'".m c #486dff",'#10'".n c #489100",'#10'".o c #489155",' + +#10'".p c #4891aa",'#10'".q c #4891ff",'#10'".r c #48b600",'#10'".s c #48b65' + +'5",'#10'".t c #48b6aa",'#10'".u c #48b6ff",'#10'".v c #48da00",'#10'".w c #' + +'48da55",'#10'".x c #48daaa",'#10'".y c #48daff",'#10'".z c #48ff00",'#10'".' + +'A c #48ff55",'#10'".B c #48ffaa",'#10'".C c #48ffff",'#10'".D c #6d0000",' + +#10'".E c #6d0055",'#10'".F c #6d00aa",'#10'".G c #6d00ff",'#10'".H c #6d240' + +'0",'#10'".I c #6d2455",'#10'".J c #6d24aa",'#10'".K c #6d24ff",'#10'".L c #' + +'6d4800",'#10'".M c #6d4855",'#10'".N c #6d48aa",'#10'".O c #6d48ff",'#10'".' + +'P c #6d6d00",'#10'".Q c #6d6d55",'#10'".R c #6d6daa",'#10'".S c #6d6dff",' + +#10'".T c #6d9100",'#10'".U c #6d9155",'#10'".V c #6d91aa",'#10'".W c #6d91f' + +'f",'#10'".X c #6db600",'#10'".Y c #6db655",'#10'".Z c #6db6aa",'#10'".0 c #' + +'6db6ff",'#10'".1 c #6dda00",'#10'".2 c #6dda55",'#10'".3 c #6ddaaa",'#10'".' + +'4 c #6ddaff",'#10'".5 c #6dff00",'#10'".6 c #6dff55",'#10'".7 c #6dffaa",' + +#10'".8 c #6dffff",'#10'"#` c #910000",'#10'"#. c #910055",'#10'"## c #9100a' + +'a",'#10'"#a c #9100ff",'#10'"#b c #912400",'#10'"#c c #912455",'#10'"#d c #' + +'9124aa",'#10'"#e c #9124ff",'#10'"#f c #914800",'#10'"#g c #914855",'#10'"#' + +'h c #9148aa",'#10'"#i c #9148ff",'#10'"#j c #916d00",'#10'"#k c #916d55",' + +#10'"#l c #916daa",'#10'"#m c #916dff",'#10'"#n c #919100",'#10'"#o c #91915' + +'5",'#10'"#p c #9191aa",'#10'"#q c #9191ff",'#10'"#r c #91b600",'#10'"#s c #' + +'91b655",'#10'"#t c #91b6aa",'#10'"#u c #91b6ff",'#10'"#v c #91da00",'#10'"#' + +'w c #91da55",'#10'"#x c #91daaa",'#10'"#y c #91daff",'#10'"#z c #91ff00",' + +#10'"#A c #91ff55",'#10'"#B c #91ffaa",'#10'"#C c #91ffff",'#10'"#D c #b6000' + +'0",'#10'"#E c #b60055",'#10'"#F c #b600aa",'#10'"#G c #b600ff",'#10'"#H c #' + +'b62400",'#10'"#I c #b62455",'#10'"#J c #b624aa",'#10'"#K c #b624ff",'#10'"#' + +'L c #b64800",'#10'"#M c #b64855",'#10'"#N c #b648aa",'#10'"#O c #b648ff",' + +#10'"#P c #b66d00",'#10'"#Q c #b66d55",'#10'"#R c #b66daa",'#10'"#S c #b66df' + +'f",'#10'"#T c #b69100",'#10'"#U c #b69155",'#10'"#V c #b691aa",'#10'"#W c #' + +'b691ff",'#10'"#X c #b6b600",'#10'"#Y c #b6b655",'#10'"#Z c #b6b6aa",'#10'"#' + +'0 c #b6b6ff",'#10'"#1 c #b6da00",'#10'"#2 c #b6da55",'#10'"#3 c #b6daaa",' + +#10'"#4 c #b6daff",'#10'"#5 c #b6ff00",'#10'"#6 c #b6ff55",'#10'"#7 c #b6ffa' + +'a",'#10'"#8 c #b6ffff",'#10'"a` c #da0000",'#10'"a. c #da0055",'#10'"a# c #' + +'da00aa",'#10'"aa c #da00ff",'#10'"ab c #da2400",'#10'"ac c #da2455",'#10'"a' + +'d c #da24aa",'#10'"ae c #da24ff",'#10'"af c #da4800",'#10'"ag c #da4855",' + +#10'"ah c #da48aa",'#10'"ai c #da48ff",'#10'"aj c #da6d00",'#10'"ak c #da6d5' + +'5",'#10'"al c #da6daa",'#10'"am c #da6dff",'#10'"an c #da9100",'#10'"ao c #' + +'da9155",'#10'"ap c #da91aa",'#10'"aq c #da91ff",'#10'"ar c #dab600",'#10'"a' + +'s c #dab655",'#10'"at c #dab6aa",'#10'"au c #dab6ff",'#10'"av c #dada00",' + +#10'"aw c #dada55",'#10'"ax c #dadaaa",'#10'"ay c #dadaff",'#10'"az c #daff0' + +'0",'#10'"aA c #daff55",'#10'"aB c #daffaa",'#10'"aC c #daffff",'#10'"aD c #' + +'ff0000",'#10'"aE c #ff0055",'#10'"aF c #ff00aa",'#10'"aG c None",'#10'"aH c' + +' #ff2400",'#10'"aI c #ff2455",'#10'"aJ c #ff24aa",'#10'"aK c #ff24ff",'#10 + ,'"aL c #ff4800",'#10'"aM c #ff4855",'#10'"aN c #ff48aa",'#10'"aO c #ff48ff",' + +#10'"aP c #ff6d00",'#10'"aQ c #ff6d55",'#10'"aR c #ff6daa",'#10'"aS c #ff6df' + +'f",'#10'"aT c #ff9100",'#10'"aU c #ff9155",'#10'"aV c #ff91aa",'#10'"aW c #' + +'ff91ff",'#10'"aX c #ffb600",'#10'"aY c #ffb655",'#10'"aZ c #ffb6aa",'#10'"a' + +'0 c #ffb6ff",'#10'"a1 c #ffda00",'#10'"a2 c #ffda55",'#10'"a3 c #ffdaaa",' + +#10'"a4 c #ffdaff",'#10'"a5 c #ffff00",'#10'"a6 c #ffff55",'#10'"a7 c #ffffa' + +'a",'#10'"a8 c #ffffff",'#10'/* pixels */'#10'"aGaGaGaGaGaGaGaGaGaGaGaGaGaGa' + +'GaGaGaGaGaGaGaGaGaG",'#10'"aGaG.g.g.g.g.g.g.g.Q.g.g.g.g.g.g.g.Q.g.g.g.gaGaG' + +'",'#10'"aG.gayaya8aya8aya8aya8aya8axayaxay#Zay#Zay.Q.gaG",'#10'"aG.ga8a8aya' + +'8a8a8aya8ayayax#Z#Z#Z#p#p#p#p#o.Q`IaG",'#10'"aG.ga8aya8aya8axa8ayay#Zay#Z#Z' + +'#p#Z#p#p.Q#p.Q.gaG",'#10'"aG.ga8a8a8ayaxayaxay#Z#Z#Z#Z#p#p#p#p.Q#p#p.R`IaG"' + +','#10'"aG.ga8aya8#Zay#Zay#Z#0#Z#Z#p#Z#o#p.Q#p.Q#p.Q.gaG",'#10'"aG.ga8a8ayay' + +'axay#Z#Z#Z#Z#p#p#p#p#o#p.R#p.R.R`IaG",'#10'"aG.ga8axay#Zayaxa8a8a8a8a8a8a8a' + +'8ay.Q#p.Q#p.Q.gaG",'#10'"aG.ga8ayay#Z#Za8aya8ay#pa8a8.Q#p#p#p.R#p.V.R`HaG",' + +#10'"aG.ga8axay#Zay#Z#Zaxa8#oa8atao#Laj#Laj#P#p.Q.gaG",'#10'"aG.ga8ay#Z#Z#Z#' + +'Z#Zayax#ZaoafaYaZaZaYaUaUaf#k`IaG",'#10'"aG.ga8#Zay#p#Z#oayayayakajaZa3aUaU' + +'aPaUaPaQ#L.gaG",'#10'"aG.gay#Z#Z#Z#p#paya8atafaZaZaPaPaPaPaPaPaPaP#LaG",'#10 + +'".g.g.g.g.g.g.g.g.g.g.g.g.gaPaPa8aYaUa8afaPafaj.H",'#10'".ga8a8a8a8a8a8a8a8' + +'a8a8a8.g``aPa8aUaUa8aPafafaf#f",'#10'".ga8``````#3a8#3``````a8.g``aPa8aYaUa' + +'8afajafaj#b",'#10'".ga8``a8#3``a8``#3a8a8a8.g``aPa8aUaUa8afafaf#L#f",'#10'"' + +'.ga8``````#3a8#3````aya8.g``aPa8aUaoa8afaj#Laf.H",'#10'".ga8``aya8a8a8a8a8#' + +'3``a8.g``aja8aoaoa8afafaf.baG",'#10'".ga8``a8a8``````````aya8.g``ajafajafaj' + +'#Laj#f.HaG",'#10'".ga8a8a8a8a8a8a8a8a8a8a8.g``afaf#Laf#L#L#f.baGaG",'#10'".' + +'g.g.g.g.g.g.g.g.g.g.g.g.g``.L#L#L#f#L.b.HaGaGaG",'#10'"aG``````````````````' + +'````````aG.H.H.H.HaGaGaGaGaG"'#10'};'#10 +]); diff --git a/Source/pascalscript.pas b/Source/pascalscript.pas new file mode 100644 index 0000000..c90dd91 --- /dev/null +++ b/Source/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/Source/readme.txt b/Source/readme.txt new file mode 100644 index 0000000..343992a --- /dev/null +++ b/Source/readme.txt @@ -0,0 +1,32 @@ +RemObjects Pascal + +Files in this distribution: +help/ - Help documents (html format) and examples +demo/ - Test application. +demo_import/ - Test application with class library. +demo_kylix/ - Kylix test application. +ifps3.pas - The runtime interpreter +ifpscomp.pas - The compiler +ifps3common.pas - The Common types and constants used by IFPS3 +ifps3lib_std.pas - The standard library +ifps3lib_stdr.pas - The standard library (runtime) +ifps3utl.pas - The utility unit +ifps3_def.inc - The include file +readme.txt - Readme (this file) +license.txt - License Agreement +ifpidll2runtime.pas - runtime dll support. +ifpidll2.pas - Compiler dll loading support. +ifpicall.pas - Call library used by all runtime calling units. +ifpii_*.pas - Import libraries (compiler) +ifpiir_*.pas - Import libraries (runtime) +IFPS3CompExec.pas - A component wrapper around IFPS3 + +http://www.carlo-kok.com/ + +Installing: + +The .dpk file was build with Delphi 7, if you don't have Delphi 7, it might +complain about missing packages, you can remove those from the requires list +and remove and compiler directives it will complain about. Install the .dpk +file, and add the IFPS3 directory to your search paths. + diff --git a/Source/uPSC_DB.pas b/Source/uPSC_DB.pas new file mode 100644 index 0000000..d9c1ed3 --- /dev/null +++ b/Source/uPSC_DB.pas @@ -0,0 +1,888 @@ +{ 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'); +{$ELSE} + RegisterMethod('Function FIELDBYNAME( const FIELDNAME : STRING) : TFIELD'); +{$ENDIF} + RegisterMethod('Function FINDFIELD( const FIELDNAME : STRING) : TFIELD'); + 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('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/Source/uPSC_buttons.pas b/Source/uPSC_buttons.pas new file mode 100644 index 0000000..52c0873 --- /dev/null +++ b/Source/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/Source/uPSC_classes.pas b/Source/uPSC_classes.pas new file mode 100644 index 0000000..e1f35bb --- /dev/null +++ b/Source/uPSC_classes.pas @@ -0,0 +1,316 @@ +{ 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)'); + RegisterMethod('function COPYFROM(SOURCE:TSTREAM;COUNT:LONGINT):LONGINT'); + 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').Value.tchar := #0; + cl.AddConstantN('toSymbol', 'Char').Value.tchar := #1; + cl.AddConstantN('toString', 'Char').Value.tchar := #2; + cl.AddConstantN('toInteger', 'Char').Value.tchar := #3; + cl.AddConstantN('toFloat', 'Char').Value.tchar := #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/Source/uPSC_comobj.pas b/Source/uPSC_comobj.pas new file mode 100644 index 0000000..3573a6e --- /dev/null +++ b/Source/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/Source/uPSC_controls.pas b/Source/uPSC_controls.pas new file mode 100644 index 0000000..681fbd0 --- /dev/null +++ b/Source/uPSC_controls.pas @@ -0,0 +1,234 @@ +{ 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} + RegisterMethod('Function GetName : string'); + RegisterMethod('Procedure HideDragImage'); + RegisterMethod('Function Instance : Longint'); + 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/Source/uPSC_dateutils.pas b/Source/uPSC_dateutils.pas new file mode 100644 index 0000000..4dd2709 --- /dev/null +++ b/Source/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/Source/uPSC_dll.pas b/Source/uPSC_dll.pas new file mode 100644 index 0000000..ccc9d27 --- /dev/null +++ b/Source/uPSC_dll.pas @@ -0,0 +1,138 @@ +{ 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 Name, FExternal: string): TPSRegProc; +type + + TDllCallingConvention = (clRegister + , clPascal + , ClCdecl + , ClStdCall + ); + +var + DefaultCC: TDllCallingConvention; + +procedure RegisterDll_Compiletime(cs: TPSPascalCompiler); + +implementation + +function rpos(ch: char; const s: string): 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: string): string; +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 Name, FExternal: string): TPSRegProc; +var + FuncName, + FuncCC, s: string; + CC: TDllCallingConvention; + DelayLoad: Boolean; + +begin + DelayLoad := False; + FuncCC := FExternal; + if (pos('@', FuncCC) = 0) then + begin + Sender.MakeError('', ecCustomError, RPS_Invalid_External); + Result := nil; + exit; + end; + FuncName := copy(FuncCC, 1, rpos('@', FuncCC)-1)+#0; + delete(FuncCc, 1, length(FuncName)); + if pos(' ', Funccc) <> 0 then + begin + if FuncCC[1] = '"' then + begin + Delete(FuncCC, 1, 1); + FuncName := RemoveQuotes(copy(FuncCC, 1, pos('"', FuncCC)-1))+#0+FuncName; + Delete(FuncCC,1, pos('"', FuncCC)); + if (FuncCC <> '') and( FuncCC[1] = ' ') then delete(FuncCC,1,1); + end else + begin + FuncName := copy(FuncCc, 1, pos(' ',FuncCC)-1)+#0+FuncName; + Delete(FuncCC, 1, pos(' ', FuncCC)); + end; + if pos(' ', FuncCC) > 0 then + begin + s := Copy(FuncCC, pos(' ', Funccc)+1, MaxInt); + FuncCC := FastUpperCase(Copy(FuncCC, 1, pos(' ', FuncCC)-1)); + Delete(FuncCC, pos(' ', Funccc), MaxInt); + if FastUppercase(s) = 'DELAYLOAD' then + DelayLoad := True + else + begin + Sender.MakeError('', ecCustomError, RPS_Invalid_External); + Result := nil; + exit; + end; + 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, RPS_InvalidCallingConvention); + Result := nil; + exit; + end; + end else + begin + FuncName := RemoveQuotes(FuncCC)+#0+FuncName; + FuncCC := ''; + cc := DefaultCC; + end; + FuncName := 'dll:'+FuncName+char(cc)+char(bytebool(DelayLoad)) + declToBits(Decl); + Result := TPSRegProc.Create; + Result.ImportDecl := FuncName; + Result.Decl.Assign(Decl); + Result.Name := Name; + 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/Source/uPSC_extctrls.pas b/Source/uPSC_extctrls.pas new file mode 100644 index 0000000..9a4dfb2 --- /dev/null +++ b/Source/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/Source/uPSC_forms.pas b/Source/uPSC_forms.pas new file mode 100644 index 0000000..4a02b5d --- /dev/null +++ b/Source/uPSC_forms.pas @@ -0,0 +1,267 @@ +{ 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', 'STRING', 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'); + RegisterMethod('function MESSAGEBOX(TEXT,CAPTION:PCHAR;FLAGS:WORD):INTEGER'); + RegisterMethod('procedure MINIMIZE'); + RegisterMethod('procedure PROCESSMESSAGES'); + RegisterMethod('procedure RESTORE'); + RegisterMethod('procedure TERMINATE'); + RegisterProperty('ACTIVE', 'BOOLEAN', iptr); + RegisterProperty('EXENAME', 'STRING', iptr); + {$IFNDEF CLX} + RegisterProperty('HANDLE', 'LONGINT', iptrw); + RegisterProperty('UPDATEFORMATSETTINGS', 'BOOLEAN', iptrw); + {$ENDIF} + RegisterProperty('HINT', 'STRING', iptrw); + RegisterProperty('MAINFORM', 'TFORM', iptr); + RegisterProperty('SHOWHINT', 'BOOLEAN', iptrw); + RegisterProperty('SHOWMAINFORM', 'BOOLEAN', iptrw); + RegisterProperty('TERMINATED', 'BOOLEAN', iptr); + RegisterProperty('TITLE', 'STRING', 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:STRING):BOOLEAN'); + RegisterProperty('DIALOGHANDLE', 'LONGINT', iptrw); + RegisterMethod('procedure CREATEHANDLE'); +// RegisterMethod('procedure HOOKMAINWINDOW(HOOK:TWINDOWHOOK)'); +// RegisterMethod('procedure UNHOOKMAINWINDOW(HOOK:TWINDOWHOOK)'); + {$ENDIF} + RegisterProperty('HELPFILE', 'STRING', 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/Source/uPSC_graphics.pas b/Source/uPSC_graphics.pas new file mode 100644 index 0000000..37279d3 --- /dev/null +++ b/Source/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/Source/uPSC_menus.pas b/Source/uPSC_menus.pas new file mode 100644 index 0000000..a544578 --- /dev/null +++ b/Source/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/Source/uPSC_std.pas b/Source/uPSC_std.pas new file mode 100644 index 0000000..d9b85bb --- /dev/null +++ b/Source/uPSC_std.pas @@ -0,0 +1,86 @@ +{ 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/Source/uPSC_stdctrls.pas b/Source/uPSC_stdctrls.pas new file mode 100644 index 0000000..e131529 --- /dev/null +++ b/Source/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/Source/uPSCompiler.pas b/Source/uPSCompiler.pas new file mode 100644 index 0000000..732fd56 --- /dev/null +++ b/Source/uPSCompiler.pas @@ -0,0 +1,14555 @@ +unit uPSCompiler; +{$I PascalScript.inc} +{$DEFINE PS_USESSUPPORT} +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); + + + {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: string; + FOrgName: string; + FMode: TPSParameterMode; + FType: TPSType; + {$IFDEF PS_USESSUPPORT} + FDeclareUnit: String; + {$ENDIF} + FDeclarePos: Cardinal; + FDeclareRow: Cardinal; + FDeclareCol: Cardinal; + procedure SetName(const s: string); + public + + property Name: string read FName; + + property OrgName: string read FOrgName write SetName; + + property aType: TPSType read FType write FType; + + property Mode: TPSParameterMode read FMode write FMode; + + {$IFDEF PS_USESSUPPORT} + property DeclareUnit: String 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: string; + FDecl: TPSParametersDecl; + FExportName: Boolean; + FImportDecl: string; + FOrgName: string; + procedure SetName(const Value: string); + public + + property OrgName: string read FOrgName write FOrgName; + + property Name: string read FName write SetName; + + property NameHash: Longint read FNameHash; + + property Decl: TPSParametersDecl read FDecl; + + property ExportName: Boolean read FExportName write FExportName; + + property ImportDecl: string 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); + end; + + TPSRecordFieldTypeDef = class(TObject) + private + FFieldOrgName: string; + FFieldName: string; + FFieldNameHash: Longint; + FType: TPSType; + procedure SetFieldOrgName(const Value: string); + public + + property FieldOrgName: string read FFieldOrgName write SetFieldOrgName; + + property FieldName: string read FFieldName; + + property FieldNameHash: Longint read FFieldNameHash; + + property aType: TPSType read FType write FType; + end; + + PIFPSRecordFieldTypeDef = TPSRecordFieldTypeDef; + + TPSType = class(TObject) + private + FNameHash: Longint; + FName: string; + FBaseType: TPSBaseType; + {$IFDEF PS_USESSUPPORT} + FDeclareUnit: String; + {$ENDIF} + FDeclarePos: Cardinal; + FDeclareRow: Cardinal; + FDeclareCol: Cardinal; + FUsed: Boolean; + FExportName: Boolean; + FOriginalName: string; + FAttributes: TPSAttributes; + FFinalTypeNo: cardinal; + procedure SetName(const Value: string); + public + + constructor Create; + + destructor Destroy; override; + + property Attributes: TPSAttributes read FAttributes; + + + property FinalTypeNo: cardinal read FFinalTypeNo; + + + property OriginalName: string read FOriginalName write FOriginalName; + + property Name: string read FName write SetName; + + property NameHash: Longint read FNameHash; + + property BaseType: TPSBaseType read FBaseType write FBaseType; + + {$IFDEF PS_USESSUPPORT} + property DeclareUnit: String 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: string; 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: string; + FFieldName: string; + FFieldNameHash: Longint; + FFieldType: TPSType; + FHidden: Boolean; + procedure SetFieldOrgName(const Value: string); + public + + constructor Create(AOwner: TPSAttributeType); + + property Owner: TPSAttributeType read FOwner; + + property FieldOrgName: string read FFieldOrgName write SetFieldOrgName; + + property FieldName: string 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: string; + FOrgname: string; + FNameHash: Longint; + FAAProc: TPSApplyAttributeToProc; + FAAType: TPSApplyAttributeToType; + function GetField(I: Longint): TPSAttributeTypeField; + function GetFieldCount: Longint; + procedure SetName(const s: string); + 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: string read FName; + + property OrgName: string 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: string): TPSAttribute; + + constructor Create; + + destructor Destroy; override; + end; + + + TPSProcVar = class(TObject) + private + FNameHash: Longint; + FName: string; + FOrgName: string; + FType: TPSType; + FUsed: Boolean; + {$IFDEF PS_USESSUPPORT} + FDeclareUnit: String; + {$ENDIF} + FDeclarePos, FDeclareRow, FDeclareCol: Cardinal; + procedure SetName(const Value: string); + public + + property OrgName: string read FOrgName write FOrgname; + + property NameHash: Longint read FNameHash; + + property Name: string read FName write SetName; + + property AType: TPSType read FType write FType; + + property Used: Boolean read FUsed; + + {$IFDEF PS_USESSUPPORT} + property DeclareUnit: String 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: string; + FNameHash: Longint; + FName: string; + FDecl: TPSParametersDecl; + FProcVars: TPSList; + FUsed: Boolean; + FOutputDeclPosition: Cardinal; + FResultUsed: Boolean; + FLabels: TIfStringList; + FGotos: TIfStringList; + FDeclareRow: Cardinal; + {$IFDEF PS_USESSUPPORT} + FDeclareUnit: String; + {$ENDIF} + FDeclarePos: Cardinal; + FDeclareCol: Cardinal; + FOriginalName: string; + procedure SetName(const Value: string); + public + + constructor Create; + + destructor Destroy; override; + {Attributes} + + + property Forwarded: Boolean read FForwarded write FForwarded; + + property Data: string read FData write FData; + + property Decl: TPSParametersDecl read FDecl; + + property OriginalName: string read FOriginalName write FOriginalName; + + property Name: string read FName write SetName; + + property NameHash: Longint read FNameHash; + + property ProcVars: TPSList read FProcVars; + + property Used: Boolean read FUsed; + + {$IFDEF PS_USESSUPPORT} + property DeclareUnit: String 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: string; + FName: string; + FType: TPSType; + FUsed: Boolean; + FExportName: string; + FDeclareRow: Cardinal; + {$IFDEF PS_USESSUPPORT} + FDeclareUnit: String; + {$ENDIF} + FDeclarePos: Cardinal; + FDeclareCol: Cardinal; + FSaveAsPointer: Boolean; + procedure SetName(const Value: string); + public + + property SaveAsPointer: Boolean read FSaveAsPointer write FSaveAsPointer; + + property ExportName: string read FExportName write FExportName; + + property Used: Boolean read FUsed; + + property aType: TPSType read FType write FType; + + property OrgName: string read FOrgName write FOrgName; + + property Name: string read FName write SetName; + + property NameHash: Longint read FNameHash; + + {$IFDEF PS_USESSUPPORT} + property DeclareUnit: String 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) + + FOrgName: string; + + FNameHash: Longint; + + FName: string; + + FDeclareRow: Cardinal; + {$IFDEF PS_USESSUPPORT} + FDeclareUnit: String; + {$ENDIF} + FDeclarePos: Cardinal; + FDeclareCol: Cardinal; + + FValue: PIfRVariant; + private + procedure SetName(const Value: string); + public + + property OrgName: string read FOrgName write FOrgName; + + property Name: string read FName write SetName; + + property NameHash: Longint read FNameHash; + + property Value: PIfRVariant read FValue write FValue; + + {$IFDEF PS_USESSUPPORT} + property DeclareUnit: String 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: string); + + procedure SetChar(c: Char); + {$IFNDEF PS_NOWIDESTRING} + + procedure SetWideChar(const val: WideChar); + + procedure SetWideString(const val: WideString); + {$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: string; + + FParam: string; + + FPosition: Cardinal; + + procedure SetParserPos(Parser: TPSPascalParser); + public + + property ModuleName: string read FModuleName write FModuleName; + + property Param: string 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: string; virtual; abstract; + + procedure SetCustomPos(Pos, Row, Col: Cardinal); + + function MessageToString: string; virtual; + + function ShortMessageToString: string; virtual; abstract; + end; + + TPSPascalCompilerError = class(TPSPascalCompilerMessage) + protected + + FError: TPSPascalCompilerErrorType; + public + + property Error: TPSPascalCompilerErrorType read FError; + + function ErrorType: string; override; + function ShortMessageToString: string; override; + end; + + TPSPascalCompilerHint = class(TPSPascalCompilerMessage) + protected + + FHint: TPSPascalCompilerHintType; + public + + property Hint: TPSPascalCompilerHintType read FHint; + + function ErrorType: string; override; + function ShortMessageToString: string; override; + end; + + TPSPascalCompilerWarning = class(TPSPascalCompilerMessage) + protected + + FWarning: TPSPascalCompilerWarningType; + public + + property Warning: TPSPascalCompilerWarningType read FWarning; + + function ErrorType: string; override; + function ShortMessageToString: string; 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: string); + + TPSOnUses = function(Sender: TPSPascalCompiler; const Name: string): Boolean; + + TPSOnExportCheck = function(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure; const ProcDecl: string): Boolean; + + {$IFNDEF PS_USESSUPPORT} + TPSOnWriteLineEvent = function (Sender: TPSPascalCompiler; Position: Cardinal): Boolean; + {$ELSE} + TPSOnWriteLineEvent = function (Sender: TPSPascalCompiler; FileName: String; Position: Cardinal): Boolean; + {$ENDIF} + + TPSOnExternalProc = function (Sender: TPSPascalCompiler; Decl: TPSParametersDecl; const Name, FExternal: string): TPSRegProc; + + TPSOnTranslateLineInfoProc = procedure (Sender: TPSPascalCompiler; var Pos, Row, Col: Cardinal; var Name: string); + TPSOnNotify = function (Sender: TPSPascalCompiler): Boolean; + + + TPSPascalCompiler = class + protected + FID: Pointer; + FOnExportCheck: TPSOnExportCheck; + FDefaultBoolType: TPSType; + FRegProcs: TPSList; + FConstants: TPSList; + FProcs: TPSList; + FTypes: TPSList; + FAttributeTypes: TPSList; + FVars: TPSList; + FOutput: string; + FParser: TPSPascalParser; + FParserHadError: Boolean; + FMessages: TPSList; + FOnUses: TPSOnUses; + FUtf8Decode: Boolean; + FIsUnit: Boolean; + FAllowNoBegin: Boolean; + FAllowNoEnd: Boolean; + FAllowUnit: Boolean; + FBooleanShortCircuit: Boolean; + FDebugOutput: string; + FOnExternalProc: TPSOnExternalProc; + FOnUseVariable: TPSOnUseVariable; + FOnBeforeOutput: TPSOnNotify; + FOnBeforeCleanup: TPSOnNotify; + FOnWriteLine: TPSOnWriteLineEvent; + FContinueOffsets, FBreakOffsets: TPSList; + FOnTranslateLineInfo: TPSOnTranslateLineInfoProc; + FAutoFreeList: TPSList; + FClasses: TPSList; + + {$IFDEF PS_USESSUPPORT} + FUses : TIFStringList; + fModule : String; + fInCompile : Integer; + {$ENDIF} +{$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): WideString; + {$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): string; + + + procedure DefineStandardTypes; + + procedure DefineStandardProcedures; + + function ReadReal(const s: string): PIfRVariant; + function ReadString: PIfRVariant; + function ReadInteger(const s: string): 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: string; FParser: TPSPascalParser): TPSType; + function ProcessLabel(Proc: TPSInternalProcedure): Boolean; + function ProcessSub(BlockInfo: TPSBlockInfo): Boolean; + function ProcessLabelForwards(Proc: TPSInternalProcedure): Boolean; + + procedure WriteDebugData(const s: string); + + 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: string; const check: TPSDuplicCheck): Boolean; + + function NewProc(const OriginalName, Name: string): 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: string; FParser: TPSPascalParser): TPSType; + + function VarIsDuplicate(Proc: TPSInternalProcedure; const VarNames, s: string): Boolean; + + function IsProcDuplicLabel(Proc: TPSInternalProcedure; const s: string): Boolean; + + procedure CheckForUnusedVars(Func: TPSInternalProcedure); + function ProcIsDuplic(Decl: TPSParametersDecl; const FunctionName, FunctionParamNames: string; const s: string; Func: TPSInternalProcedure): Boolean; + public + function GetConstant(const Name: string): TPSConstant; + + function UseExternalProc(const Name: string): TPSParametersDecl; + + function FindProc(const Name: string): 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: string): TPSAttributeType; + + procedure AddToFreeList(Obj: TObject); + + property ID: Pointer read FID write FID; + + function MakeError(const Module: string; E: TPSPascalCompilerErrorType; const + Param: string): TPSPascalCompilerMessage; + + function MakeWarning(const Module: string; E: TPSPascalCompilerWarningType; + const Param: string): TPSPascalCompilerMessage; + + function MakeHint(const Module: string; E: TPSPascalCompilerHintType; + const Param: string): TPSPascalCompilerMessage; + +{$IFNDEF PS_NOINTERFACES} + + function AddInterface(InheritedFrom: TPSInterface; Guid: TGuid; const Name: string): TPSInterface; + + function FindInterface(const Name: string): TPSInterface; + +{$ENDIF} + function AddClass(InheritsFrom: TPSCompileTimeClass; aClass: TClass): TPSCompileTimeClass; + + function AddClassN(InheritsFrom: TPSCompileTimeClass; const aClass: string): TPSCompileTimeClass; + + + function FindClass(const aClass: string): TPSCompileTimeClass; + + function AddFunction(const Header: string): TPSRegProc; + + function AddDelphiFunction(const Decl: string): TPSRegProc; + + function AddType(const Name: string; const BaseType: TPSBaseType): TPSType; + + function AddTypeS(const Name, Decl: string): TPSType; + + function AddTypeCopy(const Name: string; TypeNo: TPSType): TPSType; + + function AddTypeCopyN(const Name, FType: string): TPSType; + + function AddConstant(const Name: string; FType: TPSType): TPSConstant; + + function AddConstantN(const Name, FType: string): TPSConstant; + + function AddVariable(const Name: string; FType: TPSType): TPSVar; + + function AddVariableN(const Name, FType: string): TPSVar; + + function AddUsedVariable(const Name: string; FType: TPSType): TPSVar; + + function AddUsedVariableN(const Name, FType: string): TPSVar; + + function AddUsedPtrVariable(const Name: string; FType: TPSType): TPSVar; + + function AddUsedPtrVariableN(const Name, FType: string): TPSVar; + + function FindType(const Name: string): TPSType; + + function MakeDecl(decl: TPSParametersDecl): string; + + function Compile(const s: string): Boolean; + + function GetOutput(var s: string): Boolean; + + function GetDebugOutput(var s: string): 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 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; + 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; + 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: string; + 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: string): Boolean; + + procedure RegisterProperty(const PropertyName, PropertyType: string; PropAC: TPSPropType); + + procedure RegisterPublishedProperties; + + function RegisterPublishedProperty(const Name: string): Boolean; + + procedure SetDefaultPropery(const Name: string); + + constructor Create(ClassName: string; 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: string; var Index: Cardinal): Boolean; + + function Property_Get(Index: Cardinal; var ProcNo: Cardinal): Boolean; + + function Property_Set(Index: Cardinal; var ProcNo: Cardinal): Boolean; + + function Property_GetHeader(Index: Cardinal; Dest: TPSParametersDecl): Boolean; + + + function Func_Find(const Name: string; var Index: Cardinal): Boolean; + + function Func_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; + + + function ClassFunc_Find(const Name: string; var Index: Cardinal): Boolean; + + function ClassFunc_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; + end; + + TPSDelphiClassItem = class(TObject) + private + FOwner: TPSCompileTimeClass; + FOrgName: string; + FName: string; + FNameHash: Longint; + FDecl: TPSParametersDecl; + procedure SetName(const s: string); + public + + constructor Create(Owner: TPSCompileTimeClass); + + destructor Destroy; override; + + property Decl: TPSParametersDecl read FDecl; + + property Name: string read FName; + + property OrgName: string 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: string; + FNameHash: Longint; + procedure SetInheritedFrom(p: TPSInterface); + public + + constructor Create(Owner: TPSPascalCompiler; InheritedFrom: TPSInterface; Guid: TGuid; const Name: string; 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: string read FName write FName; + + property NameHash: Longint read FNameHash; + + + function RegisterMethod(const Declaration: string; 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: string; var Index: Cardinal): Boolean; + + function Func_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; + end; + + + TPSInterfaceMethod = class(TObject) + private + FName: string; + FDecl: TPSParametersDecl; + FNameHash: Longint; + FCC: TPSCallingConvention; + FScriptProcNo: Cardinal; + FOrgName: string; + FOwner: TPSInterface; + FOffsetCache: Cardinal; + function GetAbsoluteProcOffset: Cardinal; + public + + property AbsoluteProcOffset: Cardinal read GetAbsoluteProcOffset; + + property ScriptProcNo: Cardinal read FScriptProcNo; + + property OrgName: string read FOrgName; + + property Name: string 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: string; var Index: Cardinal): Boolean; virtual; + + function ClassFunc_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; virtual; + + function Func_Find(const Name: string; 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: string); + +function AddImportedClassVariable(Sender: TPSPascalCompiler; const VarName, VarType: string): 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): string; + +function ParseMethod(Owner: TPSPascalCompiler; const FClassName: string; Decl: string; var OrgName: string; DestDecl: TPSParametersDecl; var Func: TPMFuncType): Boolean; + +function DeclToBits(const Decl: TPSParametersDecl): string; + +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 = 'Close round 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 = 'open round (''('')expected'; + RPS_CommaExpected = 'comma ('','') expected'; + RPS_ToExpected = '''TO'' expected'; + RPS_IsExpected = 'is (''='') expected'; + RPS_OfExpected = '''OF'' expected'; + RPS_CloseBlockExpected = 'Close block('']'') 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 = 'Open Block (''['') 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): string; +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 + Char(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); +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; + 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 + BlockWriteData(BlockInfo, p^.tu32, 1) + else if TPSEnumType(p^.FType).HighValue <=65536 then + BlockWriteData(BlockInfo, p^.tu32, 2) + else + BlockWriteData(BlockInfo, p^.tu32, 4); + 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: string); +begin + if p <> nil then + p.exportname := ExpName; +end; + +function FindAndAddType(Owner: TPSPascalCompiler; const Name, Decl: string): 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: string; Decl: string; var OrgName: string; DestDecl: TPSParametersDecl; var Func: TPMFuncType): Boolean; +var + Parser: TPSPascalParser; + FuncType: Byte; + VNames: string; + 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', 'array of PChar'); + 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'); + btWideChar: VCType := FindAndAddType(Owner, '!OPENARRAYOFWIDECHAR', 'array of WideChar'); + {$ENDIF} + btClass: VCType := FindAndAddType(Owner, '!OPENARRAYOFTOBJECT', 'array of TObject'); + btRecord: VCType := FindAndAddType(Owner, '!OPENARRAYOFRECORD_'+UpperCase(Parser.OriginalToken), 'array of ' +UpperCase(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('|', 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('|', VNames) - 1); + aType := VCType; + end; + Delete(VNames, 1, Pos('|', 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 Name: string): Cardinal; +var + l, h: Longint; + x: TPSProcedure; + xr: TPSRegProc; + +begin + h := MakeHash(Name); + 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: string): 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): string; +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): string; +begin + Result := #0#0#0#0; + Cardinal((@Result[1])^) := i; +end; + + + + +function TPSPascalCompiler.AddType(const Name: string; 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: string): TPSRegProc; +var + Parser: TPSPascalParser; + i: Integer; + IsFunction: Boolean; + VNames, Name: string; + 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('|', VNames) > 0 do + begin + with Decl.AddParam do + begin + Mode := modifier; + OrgName := copy(VNames, 1, Pos('|', VNames) - 1); + aType := VCType; + end; + Delete(VNames, 1, Pos('|', 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: string; E: TPSPascalCompilerHintType; const Param: string): 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: string; E: + TPSPascalCompilerErrorType; const Param: string): 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: string; E: + TPSPascalCompilerWarningType; const Param: string): 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} + 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; +{$IFDEF FPC} +procedure Finalize(var s: string); overload; begin s := ''; end; +procedure Finalize(var s: widestring); overload; begin s := ''; end; +{$ENDIF} + +procedure FinalizeVariant(var p: TIfRVariant); +begin + if (p.FType.BaseType = btString) or (p.FType.basetype = btSet) then + finalize(tbtstring(p.tstring)) + {$IFNDEF PS_NOWIDESTRING} + else if p.FType.BaseType = btWideString then + finalize(tbtWideString(p.twidestring)); // widestring + {$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): string; +begin + case Src.FType.BaseType of + btChar: Result := Src^.tchar; + btString: Result := tbtstring(src^.tstring); + {$IFNDEF PS_NOWIDESTRING} + btWideChar: Result := src^.twidechar; + btWideString: Result := tbtWideString(src^.twidestring); + {$ENDIF} + else + begin + s := False; + Result := ''; + end; + end; +end; + +{$IFNDEF PS_NOWIDESTRING} +function TPSPascalCompiler.GetWideString(Src: PIfRVariant; var s: Boolean): WideString; +begin + case Src.FType.BaseType of + btChar: Result := Src^.tchar; + btString: Result := tbtstring(src^.tstring); + btWideChar: Result := src^.twidechar; + btWideString: Result := tbtWideString(src^.twidestring); + 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: string); +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 ConvertToWideString(SE: TPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIFRVariant; const s: WideString); +var + atype: TPSType; +begin + FinalizeVariant(var1^); + atype := se.FindBaseType(btWideString); + if FUseUsedTypes then + InitializeVariant(var1, se.at2ut(atype)) + else + InitializeVariant(var1, atype); + tbtwidestring(var1^.twidestring) := s; +end; +{$ENDIF} +procedure ConvertToFloat(SE: TPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIfRVariant; NewType: TPSType); +var + vartemp: PIfRVariant; + b: Boolean; +begin + New(vartemp); + 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 + ((p1.BaseType = btWidestring) and (p2.BaseType = btWidestring)) or + (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btWideString)) 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)) 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 + else if p1.BaseType = btclass then + Result := TPSClassType(p1).cl.IsCompatibleWith(p2) +{$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); + btWidechar: + begin + ConvertToWideString(Self, FUseUsedTypes, var1, GetWideString(Var1, b)+GetWideString(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); + btWideChar: b := var1^.twidechar <> GetWideString(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); + btWideChar: b := var1^.twidechar = GetWideString(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, e.Message); + Exit; + end; + on E: Exception do + begin + Result := False; + MakeError('', ecInternalError, 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: string; 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: string; FParser: TPSPascalParser): TPSType; +var + IsFunction: Boolean; + VNames: string; + 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('|', VNames) > 0 do + begin + with Decl.AddParam do + begin + Mode := modifier; + OrgName := copy(VNames, 1, Pos('|', VNames) - 1); + FType := VCType; + end; + Delete(VNames, 1, Pos('|', 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: string; FParser: TPSPascalParser): TPSType; // InvalidVal = Invalid +var + TypeNo: TPSType; + h, l: Longint; + FieldName,fieldorgname,s: string; + 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('|', s) > 0 do + begin + fieldorgname := copy(s, 1, pos('|', 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: string): Boolean; +var + h, l: Longint; + x: TPSProcedure; + v: string; +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 + (TPSVar(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('|', v) > 0 do + begin + if copy(v, 1, Pos('|', v) - 1) = s then + begin + Result := True; + exit; + end; + Delete(v, 1, Pos('|', 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: string; + 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 + 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('|', VarName) > 0 do + begin + s := copy(VarName, 1, Pos('|', VarName) - 1); + Delete(VarName, 1, Pos('|', 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: string): 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: string): Boolean; +var + i: Longint; + h: Longint; + u: string; +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: string; +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: string; +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); + WriteDebugData(#4 + s + #1 + PS_mi2s(ProcNo) + PS_mi2s(Length(Proc.Data)) + PS_mi2s(Pos) + PS_mi2s(Row)+ PS_mi2s(Col)); +end; + +procedure TPSPascalCompiler.Debug_WriteParams(ProcNo: Cardinal; Proc: TPSInternalProcedure); +var + I: Longint; + s: string; +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('', 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('', ehVariableNotUsed, 'Result') do + begin + FRow := Func.DeclareRow; + FCol := Func.DeclareCol; + FPosition := Func.DeclarePos; + end; + end; +end; + +function TPSPascalCompiler.ProcIsDuplic(Decl: TPSParametersDecl; const FunctionName, FunctionParamNames: string; const s: string; Func: TPSInternalProcedure): Boolean; +var + i: Longint; + u: string; +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('|', u) > 0 do + begin + if copy(u, 1, Pos('|', u) - 1) = s then + begin + Result := True; + exit; + end; + Delete(u, 1, Pos('|', 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: string; + FunctionParamNames: string; + 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; + FParser.Next; + Result := False; + if FParser.CurrTokenId <> CSTI_Identifier then + begin + MakeError('', ecIdentifierExpected, ''); + att.free; + exit; + end; + 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; + 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('|', FunctionParamNames) > 0 do + begin + with FunctionDecl.AddParam do + begin + OrgName := copy(FunctionParamNames, 1, Pos('|', FunctionParamNames) - 1); + Mode := modifier; + aType := FunctionTempType; + {$IFDEF PS_USESSUPPORT} + DeclareUnit:=fModule; + {$ENDIF} + DeclarePos:=E2Pos; + DeclareRow:=E2Row; + DeclareCol:=E2Col; + end; + Delete(FunctionParamNames, 1, Pos('|', 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, FunctionName, 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); + 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)) then + begin + Params[c].ExpectedType := GetTypeNo(BlockInfo, Params[c].Val); + 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: string; + 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: string): PIfRVariant; +var + C: Integer; +begin + New(Result); + InitializeVariant(Result, FindBaseType(btExtended)); + Val(s, Result^.textended, C); +end; + +function TPSPascalCompiler.ReadString: PIfRVariant; +{$IFNDEF PS_NOWIDESTRING}var wchar: Boolean;{$ENDIF} + + function ParseString({$IFNDEF PS_NOWIDESTRING}var res: widestring{$ELSE}var res: string{$ENDIF}): Boolean; + var + temp3: {$IFNDEF PS_NOWIDESTRING}widestring{$ELSE}string{$ENDIF}; + + function ChrToStr(s: string): {$IFNDEF PS_NOWIDESTRING}widechar{$ELSE}char{$ENDIF}; + var + w: Longint; + begin + Delete(s, 1, 1); {First char : #} + w := StrToInt(s); + Result := {$IFNDEF PS_NOWIDESTRING}widechar{$ELSE}char{$ENDIF}(w); + {$IFNDEF PS_NOWIDESTRING}if w > $FF then wchar := true;{$ENDIF} + end; + + function PString(s: string): string; + 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.UTF8Decode{$ENDIF}{$ENDIF}(PString(FParser.GetToken)); + {$IFNDEF PS_NOWIDESTRING}wchar:=true;{$ENDIF} + end else + temp3 := temp3 + 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: widestring; +{$ENDIF} + s: string; +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(btwidestring))); + tbtwidestring(Result^.twidestring) := w; + end; + end else begin + s := 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: string): PIfRVariant; +var + R: {$IFNDEF PS_NOINT64}Int64;{$ELSE}Longint;{$ENDIF} +begin + New(Result); +{$IFNDEF PS_NOINT64} + r := StrToInt64Def(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; + 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; + 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; + 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 string + 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 + Cardinal((@BlockInfo.Proc.FData[jover+1])^) := Cardinal(Length(BlockInfo.Proc.FData)) - jend; + 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'); + + 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: string; 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))); + string(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))); + string(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: string; 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 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 + 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 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 + l := FindProc('STRGET'); + if l = -1 then + begin + MakeError('', ecUnknownIdentifier, 'StrGet'); + tmp.Free; + x.Free; + x := nil; + exit; + end; + tmp3 := TPSValueProcNo.Create; + 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; + 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 + 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, Idx: Cardinal; + 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: string; + + 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, Idx: Cardinal; + FType: TPSType; + TempP: TPSValue; + Decl: TPSParametersDecl; + s: string; + + pinfo, pinfonew: string; + ppos: Cardinal; + + begin + FType := GetTypeNo(BlockInfo, p); + if FType = nil then exit; + 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; + + 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: string; + + 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, Idx: Cardinal; + 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: string; + t: TPSConstant; + Temp1: TPSType; + temp2: CArdinal; + bi: TPSBlockInfo; + + 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; + 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 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; + 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 = 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 = 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)) and + ((t2.BaseType = btString) or (t2.BaseType = btChar) or (t2.BaseType = btPchar) or (t2.BaseType = btWideString) or (t2.BaseType = btWideChar)) 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) 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){$ENDIF}) and + ((t2.BaseType = btString) or (t2.BaseType = btChar) {$IFNDEF PS_NOWIDESTRING} or (t2.BaseType = btWideString) or (t2.BaseType = btWideChar){$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){$ENDIF}) and + ((t2.BaseType = btString) or (t2.BaseType = btChar) {$IFNDEF PS_NOWIDESTRING} or (t2.BaseType = btWideString) or (t2.BaseType = btWideChar){$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.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 := chr(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8); + btS8: TPSValueData(preplace).Data.tchar := chr(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8); + btU16: TPSValueData(preplace).Data.tchar := chr(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16); + btS16: TPSValueData(preplace).Data.tchar := chr(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16); + btU32: TPSValueData(preplace).Data.tchar := chr(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32); + btS32: TPSValueData(preplace).Data.tchar := chr(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32); + {$IFNDEF PS_NOINT64} + btS64: TPSValueData(preplace).Data.tchar := chr(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 + Result.Free; + Result := nil; + exit; + end; + + if not ValidateParameters(BlockInfo, TPSValueProc(Result).Parameters, Decl) then + begin + 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: string; 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)); + string(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): Boolean; + var + i: Longint; + begin + Result := False; + if Where.ClassType = TPSUnValueOp then + begin + if CheckOutReg(TPSUnValueOp(Where).Val1, OutReg) then + Result := True; + end else if Where.ClassType = TPSBinValueOp then + begin + if CheckOutreg(TPSBinValueOp(Where).Val1, OutReg) or CheckOutreg(TPSBinValueOp(Where).Val2, OutReg) 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) 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)) 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)) 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; + 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; + tmp.TempVar := AllocPointer(GetTypeNo(BlockInfo, Tmp.FValue)); +// tmp.TempVar := AllocStackReg2(Tmp.ExpectedType); + 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 + 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: string; + 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, 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); + 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; + 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; + case GetTypeNo(BlockInfo, VariableVar).BaseType of + btU8, btS8, btU16, btS16, btU32, btS32: ; + 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; + 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; + if not ProcessSub(Block) then + begin + Block.Free; + TempBool.Free; + VariableVar.Free; + FBreakOffsets.Free; + FContinueOffsets.Free; + FContinueOffsets := OldCO; + FBreakOffsets := OldBo; + 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; + 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; + exit; + end; + AfterWriteOutRec(VariableVar); + BlockWriteByte(BlockInfo, Cm_G); + BlockWriteLong(BlockInfo, Longint(NPos - Length(BlockInfo.Proc.Data) - 4)); + Longint((@BlockInfo.Proc.Data[EPos + 1])^) := Length(BlockInfo.Proc.Data) - RPos; + for i := 0 to FBreakOffsets.Count -1 do + begin + EPos := Cardinal(FBreakOffsets[I]); + Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos); + end; + for i := 0 to FContinueOffsets.Count -1 do + begin + EPos := Cardinal(FContinueOffsets[I]); + Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(FPos) - Longint(EPos); + end; + FBreakOffsets.Free; + FContinueOffsets.Free; + FContinueOffsets := OldCO; + FBreakOffsets := OldBo; + 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; + 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; + if not ProcessSub(Block) then + begin + Block.Free; + vin.Free; + FBreakOffsets.Free; + FContinueOffsets.Free; + FContinueOffsets := OldCO; + FBreakOffsets := OldBo; + exit; + end; + Block.Free; + Debug_WriteLine(BlockInfo); + BlockWriteByte(BlockInfo, Cm_G); + BlockWriteLong(BlockInfo, Longint(SPos) - Length(BlockInfo.Proc.Data) - 4); + Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos) - 5; + for i := 0 to FBreakOffsets.Count -1 do + begin + EPos := Cardinal(FBreakOffsets[I]); + Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos); + end; + for i := 0 to FContinueOffsets.Count -1 do + begin + EPos := Cardinal(FContinueOffsets[I]); + Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(SPos) - Longint(EPos); + end; + FBreakOffsets.Free; + FContinueOffsets.Free; + FContinueOffsets := OldCO; + FBreakOffsets := OldBo; + 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; + 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; + if not ProcessSub(Block) then + begin + Block.Free; + FBreakOffsets.Free; + FContinueOffsets.Free; + FContinueOffsets := OldCO; + FBreakOffsets := OldBo; + 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; + 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; + 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; + exit; + end; + Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(SPos) - + Length(BlockInfo.Proc.Data); + for i := 0 to FBreakOffsets.Count -1 do + begin + EPos := Cardinal(FBreakOffsets[I]); + Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo. Proc.Data) - Longint(EPos); + end; + for i := 0 to FContinueOffsets.Count -1 do + begin + EPos := Cardinal(FContinueOffsets[I]); + Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(CPos) - Longint(EPos); + end; + FBreakOffsets.Free; + FContinueOffsets.Free; + FContinueOffsets := OldCO; + FBreakOffsets := OldBo; + 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); + Longint((@BlockInfo.Proc.Data[SPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(SPos); + FParser.Next; + Block := TPSBlockInfo.Create(BlockInfo); + Block.SubType := tOneLiner; + if not ProcessSub(Block) then + begin + Block.Free; + exit; + end; + Block.Free; + Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos); + end + else + begin + Longint((@BlockInfo.Proc.Data[SPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(SPos) + 5 - 5; + end; + Result := True; + end; {ProcessIf} + + function ProcessLabel: Longint; {0 = failed; 1 = successful; 2 = no label} + var + I, H: Longint; + s: string; + 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, 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): 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 := otOr; + 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} + p := TPSBinValueOp.Create; + p.SetParserPos(FParser); + p.Operator := otEqual; + p.aType := at2ut(FDefaultBoolType); + p.Val1 := Val; + p.Val2 := NewRec(TempRec); + V1 := Combine(V1, P); + 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))); + Cardinal((@BlockInfo.Proc.Data[CurrP - 3])^) := Cardinal(Length(BlockInfo.Proc.Data)) - CurrP - 5; + 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 + Cardinal((@BlockInfo.Proc.Data[Cardinal(EndReloc[I])- 3])^) := Cardinal(Length(BlockInfo.Proc.Data)) - Cardinal(EndReloc[I]); + 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 + Byte((@BlockInfo.Proc.Data[Longint(FContinueOffsets[i]) - 4])^) := Cm_P2G; + end; + end; + end; + if FBreakOffsets <> nil then + begin + for i := 0 to FBreakOffsets.Count -1 do + begin + if Cardinal(FBreakOffsets[i]) >= SPos then + begin + Byte((@BlockInfo.Proc.Data[Longint(FBreakOffsets[i]) - 4])^) := Cm_P2G; + 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: string; + 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; + 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; + TPSValueReplace(aReplace).NewValue := AllocStackReg(GetTypeNo(BlockInfo, aVar)); + if not WriteCalculation(aVar, TPSValueReplace(aReplace).NewValue) then + begin + aReplace.Free; + Block.Free; + Result := False; + exit; + end; + 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; + + if not ProcessSub(Block) then + begin + Block.Free; + Result := False; + exit; + end; + Block.Free; + Result := True; + end; + + function ProcessTry: Boolean; + var + FStartOffset: Cardinal; + 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; + if ProcessSub(Block) then + begin + 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; + Block := TPSBlockInfo.Create(BlockInfo); + Block.SubType := tTryEnd; + if ProcessSub(Block) then + begin + 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; + Block := TPSBlockInfo.Create(BlockInfo); + Block.SubType := tTryEnd; + FParser.Next; + if ProcessSub(Block) then + begin + 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; 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; 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; + Block := TPSBlockInfo.Create(BlockInfo); + Block.SubType := tTryEnd; + if ProcessSub(Block) then + begin + 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; + FParser.Next; + Block := TPSBlockInfo.Create(BlockInfo); + Block.SubType := tTryEnd; + if ProcessSub(Block) then + begin + 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; 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; exit; end; + end; + end else begin Block.Free; Result := False; exit; end; + Cardinal((@BlockInfo.Proc.Data[FStartOffset + 12])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15; + Result := True; + end; {ProcessTry} + +var + Block: TPSBlockInfo; + +begin + ProcessSub := False; + if (BlockInfo.SubType = tProcBegin) or (BlockInfo.SubType= tMainBegin) or (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 + FParser.Next; + if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then + break; + 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; + 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; + 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; + 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} + end; + 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) then + 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) then + begin + Debug_WriteLine(BlockInfo); + BlockWriteByte(BlockInfo, Cm_R); + FParser.Next; // skip end + if (BlockInfo.SubType = tMainBegin) 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; + 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 + 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.Use; + p.FFinalTypeNo := FCurrUsedTypeNo; + inc(FCurrUsedTypeNo); + end; + Result := p; +end; + +function TPSPascalCompiler.ProcessLabelForwards(Proc: TPSInternalProcedure): Boolean; +var + i: Longint; + s, s2: string; +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: string): Boolean; +var + Position: TCompilerState; + i: Longint; + {$IFDEF PS_USESSUPPORT} + OldFileName: String; + 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; + + 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} + FUses.Free; + FUses:=nil; + fInCompile:=0; + {$ENDIF} + end; + + function MakeOutput: Boolean; + + procedure WriteByte(b: Byte); + begin + FOutput := FOutput + Char(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; + 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: string; + FExportName: string; + 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 + WriteLong(TPSStaticArrayType(x).Length); + 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: string; + 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; + + 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; + procedure CreateDebugData; + var + I: Longint; + p: TPSProcedure; + pv: TPSVar; + s: string; + 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; + begin + if @FOnBeforeOutput <> nil then + begin + if not FOnBeforeOutput(Self) then + begin + Result := false; + exit; + end; + end; + + CreateDebugData; + WriteLong(PSValidHeader); + WriteLong(PSCurrentBuildNo); + WriteLong(FCurrUsedTypeNo); + WriteLong(FProcs.Count); + WriteLong(FVars.Count); + WriteLong(FindMainProc); + 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: string; + 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, ''); + 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: string; + {$IFDEF PS_USESSUPPORT} + Parse: Boolean; + ParseUnit: String; + 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, 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; + +begin + Result := False; + + {$IFDEF PS_USESSUPPORT} + if fInCompile=0 then + begin + {$ENDIF} + 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} + 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} + DefineStandardTypes; + DefineStandardProcedures; + if @FOnUses <> nil then + begin + try + if not OnUses(Self, 'SYSTEM') then + begin + Cleanup; + exit; + end; + except + on e: Exception do + begin + MakeError('', ecCustomError, 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; + 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 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 + Position := csUses; + if not ProcessLabel(FGlobalBlock.Proc) then + begin + Cleanup; + exit; + end; + end + else if (FParser.CurrTokenId = CSTII_Var) then + begin + Position := csUses; + if not DoVarBlock(nil) then + begin + Cleanup; + exit; + end; + end + else if (FParser.CurrTokenId = CSTII_Const) then + begin + Position := csUses; + if not DoConstBlock then + begin + Cleanup; + exit; + end; + end + else if (FParser.CurrTokenId = CSTII_Type) then + begin + Position := csUses; + if not DoTypeBlock(FParser) then + begin + Cleanup; + exit; + end; + end + else if (FParser.CurrTokenId = CSTII_Begin) then + begin + {$IFDEF PS_USESSUPPORT} + if FIsUnit then + begin + MakeError('',ecNotAllowed,'begin'); + CleanUp; + exit; + end + else + begin + {$ENDIF} + {$IFDEF PS_USESSUPPORT} + 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 + 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; + 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('', 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: string): 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; + AddType('Char', btChar); + {$IFNDEF PS_NOWIDESTRING} + AddType('WideChar', btWideChar); + AddType('WideString', btWideString); + {$ENDIF} + 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('string', btString); + {$IFNDEF PS_NOINT64} + AddType('Int64', btS64); + {$ENDIF} + AddType('Single', btSingle); + AddType('Double', btDouble); + AddType('Extended', btExtended); + AddType('Currency', btCurrency); + AddType('PChar', 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: string; v: Variant);') do + begin + Name := '!NOTIFICATIONVARIANTSET'; + end; + with AddFunction('function _T(Name: string): Variant;') do + begin + Name := '!NOTIFICATIONVARIANTGET'; + end; +end; + + +function TPSPascalCompiler.FindType(const Name: string): TPSType; +var + i, n: Longint; + RName: string; +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: string; 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: string; +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'); +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: string; + 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} + 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: string); +begin + FDebugOutput := FDebugOutput + s; +end; + +function TPSPascalCompiler.GetDebugOutput(var s: string): 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 + AddFunction('function inttostr(i: Longint): string;'); + AddFunction('function strtoint(s: string): Longint;'); + AddFunction('function strtointdef(s: string; def: Longint): Longint;'); + AddFunction('function copy(s: string; ifrom, icount: Longint): string;'); + AddFunction('function pos(substr, s: string): Longint;'); + AddFunction('procedure delete(var s: string; ifrom, icount: Longint);'); + AddFunction('procedure insert(s: string; var s2: string; 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);'); + AddFunction('Function AnsiUppercase(s : string) : string;'); + AddFunction('Function AnsiLowercase(s : string) : string;'); + AddFunction('Function Uppercase(s : string) : string;'); + AddFunction('Function Lowercase(s : string) : string;'); + AddFunction('Function Trim(s : string) : string;'); + AddFunction('Function Length(s : String) : Longint;'); + AddFunction('procedure SetLength(var S: String; L: Longint);'); + 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 : string;I : longInt) : string;'); + AddFunction('Function Padr(s : string;I : longInt) : string;'); + AddFunction('Function Padz(s : string;I : longInt) : string;'); + 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; + 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: string; 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); + if p <> nil then + p.exportname := FastUppercase(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: string): TPSAttributeType; +var + h, i: Integer; + n: string; +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: string): TPSConstant; +begin + Result := AddConstant(Name, FindType(FType)); +end; + +function TPSPascalCompiler.AddTypeCopy(const Name: string; + 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: string): TPSType; +begin + Result := AddTypeCopy(Name, FindType(FType)); +end; + + +function TPSPascalCompiler.AddUsedVariable(const Name: string; + FType: TPSType): TPSVar; +begin + Result := AddVariable(Name, FType); + if Result <> nil then + Result.Use; +end; + +function TPSPascalCompiler.AddUsedVariableN(const Name, + FType: string): TPSVar; +begin + Result := AddVariable(Name, FindType(FType)); + if Result <> nil then + Result.Use; +end; + +function TPSPascalCompiler.AddVariableN(const Name, + FType: string): TPSVar; +begin + Result := AddVariable(Name, FindType(FType)); +end; + +function TPSPascalCompiler.AddUsedPtrVariable(const Name: string; 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: string): 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: string): 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): string; +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: string): TPSRegProc; +var + p: TPSRegProc; + pDecl: TPSParametersDecl; + DOrgName: string; + 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: string): 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: string): TPSInterface; +var + n: string; + 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(aClass.ClassName); + if Result <> nil then exit; + f := AddType(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: string): 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: string): TPSCompileTimeClass; +var + i: Longint; + Cl: string; + 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): string; +begin + SetLength(Result, SizeOf(Double)); + Double((@Result[1])^) := D; +end; + +function TransSingleToStr(D: Single): string; +begin + SetLength(Result, SizeOf(Single)); + Single((@Result[1])^) := D; +end; + +function TransExtendedToStr(D: Extended): string; +begin + SetLength(Result, SizeOf(Extended)); + Extended((@Result[1])^) := D; +end; + +function TransLongintToStr(D: Longint): string; +begin + SetLength(Result, SizeOf(Longint)); + Longint((@Result[1])^) := D; +end; + +function TransCardinalToStr(D: Cardinal): string; +begin + SetLength(Result, SizeOf(Cardinal)); + Cardinal((@Result[1])^) := D; +end; + +function TransWordToStr(D: Word): string; +begin + SetLength(Result, SizeOf(Word)); + Word((@Result[1])^) := D; +end; + +function TransSmallIntToStr(D: SmallInt): string; +begin + SetLength(Result, SizeOf(SmallInt)); + SmallInt((@Result[1])^) := D; +end; + +function TransByteToStr(D: Byte): string; +begin + SetLength(Result, SizeOf(Byte)); + Byte((@Result[1])^) := D; +end; + +function TransShortIntToStr(D: ShortInt): string; +begin + SetLength(Result, SizeOf(ShortInt)); + ShortInt((@Result[1])^) := D; +end; + +function TPSPascalCompiler.GetConstant(const Name: string): TPSConstant; +var + h, i: Longint; + n: string; + +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: string); +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: string); +begin + FName := Value; + FNameHash := MakeHash(FName); +end; + +{ TPSRecordFieldTypeDef } + +procedure TPSRecordFieldTypeDef.SetFieldOrgName(const Value: string); +begin + FFieldOrgName := Value; + FFieldName := FastUppercase(Value); + FFieldNameHash := MakeHash(FFieldName); +end; + +{ TPSProcVar } + +procedure TPSProcVar.SetName(const Value: string); +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: string); +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: string); +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: Char); +begin + if (FValue <> nil) then + begin + case FValue.FType.BaseType of + btChar: FValue.tchar := c; + btString: string(FValue.tstring) := c; + {$IFNDEF PS_NOWIDESTRING} + btWideString: widestring(FValue.twidestring) := 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: string); +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: string); +begin + if (FValue <> nil) then + begin + case FValue.FType.BaseType of + btChar: FValue.tchar := (Val+#0)[1]; + btString: string(FValue.tstring) := val; + {$IFNDEF PS_NOWIDESTRING} + btWideString: widestring(FValue.twidestring) := 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: string(FValue.tstring) := val; + btWideChar: FValue.twidechar := val; + btWideString: widestring(FValue.twidestring) := val; + else + raise EPSCompilerException.Create(RPS_ConstantValueMismatch); + end; + end else + raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned) +end; + +procedure TPSConstant.SetWideString(const val: WideString); +begin + if (FValue <> nil) then + begin + case FValue.FType.BaseType of + btString: string(FValue.tstring) := val; + btWideString: widestring(FValue.twidestring) := val; + else + raise EPSCompilerException.Create(RPS_ConstantValueMismatch); + end; + end else + raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned) +end; +{$ENDIF} +{ TPSPascalCompilerError } + +function TPSPascalCompilerError.ErrorType: string; +begin + Result := RPS_Error; +end; + +function TPSPascalCompilerError.ShortMessageToString: string; +begin + case Error of + ecUnknownIdentifier: Result := Format (RPS_UnknownIdentifier, [Param]); + ecIdentifierExpected: Result := RPS_IdentifierExpected; + ecCommentError: Result := RPS_CommentError; + ecStringError: Result := RPS_StringError; + ecCharError: Result := RPS_CharError; + ecSyntaxError: Result := RPS_SyntaxError; + ecUnexpectedEndOfFile: Result := RPS_EOF; + ecSemicolonExpected: Result := RPS_SemiColonExpected; + ecBeginExpected: Result := RPS_BeginExpected; + ecPeriodExpected: Result := RPS_PeriodExpected; + ecDuplicateIdentifier: Result := Format (RPS_DuplicateIdent, [Param]); + ecColonExpected: Result := RPS_ColonExpected; + ecUnknownType: Result := Format (RPS_UnknownType, [Param]); + ecCloseRoundExpected: Result := RPS_CloseRoundExpected; + ecTypeMismatch: Result := RPS_TypeMismatch; + ecInternalError: Result := Format (RPS_InternalError, [Param]); + ecAssignmentExpected: Result := RPS_AssignmentExpected; + ecThenExpected: Result := RPS_ThenExpected; + ecDoExpected: Result := RPS_DoExpected; + ecNoResult: Result := RPS_NoResult; + ecOpenRoundExpected: Result := RPS_OpenRoundExpected; + ecCommaExpected: Result := RPS_CommaExpected; + ecToExpected: Result := RPS_ToExpected; + ecIsExpected: Result := RPS_IsExpected; + ecOfExpected: Result := RPS_OfExpected; + ecCloseBlockExpected: Result := RPS_CloseBlockExpected; + ecVariableExpected: Result := RPS_VariableExpected; + ecStringExpected: result := RPS_StringExpected; + ecEndExpected: Result := RPS_EndExpected; + ecUnSetLabel: Result := Format (RPS_UnSetLabel, [Param]); + ecNotInLoop: Result := RPS_NotInLoop; + ecInvalidJump: Result := RPS_InvalidJump; + ecOpenBlockExpected: Result := RPS_OpenBlockExpected; + ecWriteOnlyProperty: Result := RPS_WriteOnlyProperty; + ecReadOnlyProperty: Result := RPS_ReadOnlyProperty; + ecClassTypeExpected: Result := RPS_ClassTypeExpected; + ecCustomError: Result := Param; + ecDivideByZero: Result := RPS_DivideByZero; + ecMathError: Result := RPS_MathError; + ecUnsatisfiedForward: Result := Format (RPS_UnsatisfiedForward, [Param]); + ecForwardParameterMismatch: Result := RPS_ForwardParameterMismatch; + ecInvalidnumberOfParameters: Result := RPS_InvalidNumberOfParameter; + {$IFDEF PS_USESSUPPORT} + ecNotAllowed : Result:=Format(RPS_NotAllowed,[Param]); + ecUnitNotFoundOrContainsErrors: Result:=Format(RPS_UnitNotFound,[Param]); + {$ENDIF} + else + Result := RPS_UnknownError; + end; + Result := Result; +end; + + +{ TPSPascalCompilerHint } + +function TPSPascalCompilerHint.ErrorType: string; +begin + Result := RPS_Hint; +end; + +function TPSPascalCompilerHint.ShortMessageToString: string; +begin + case Hint of + ehVariableNotUsed: Result := Format (RPS_VariableNotUsed, [Param]); + ehFunctionNotUsed: Result := Format (RPS_FunctionNotUsed, [Param]); + ehCustomHint: Result := Param; + else + Result := RPS_UnknownHint; + end; +end; + +{ TPSPascalCompilerWarning } + +function TPSPascalCompilerWarning.ErrorType: string; +begin + Result := RPS_Warning; +end; + +function TPSPascalCompilerWarning.ShortMessageToString: string; +begin + case Warning of + ewCustomWarning: Result := Param; + ewCalculationAlwaysEvaluatesTo: Result := Format (RPS_CalculationAlwaysEvaluatesTo, [Param]); + ewIsNotNeeded: Result := Format (RPS_IsNotNeeded, [Param]); + ewAbstractClass: Result := RPS_AbstractClass; + else + Result := RPS_UnknownWarning; + end; +end; + +{ TPSPascalCompilerMessage } + +function TPSPascalCompilerMessage.MessageToString: string; +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 + Char(CM_PO); + end; + inherited Destroy; +end; + + + + +function AddImportedClassVariable(Sender: TPSPascalCompiler; const VarName, VarType: string): 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: Cardinal; + var ProcNo: Cardinal): Boolean; +var + C: TPSDelphiClassItemConstructor; + P: TPSExternalProcedure; + s: string; + 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: string; + var Index: Cardinal): 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(FClass.ClassName), aOwner, aType); + Result.FClass := FClass; +end; + +constructor TPSCompileTimeClass.Create(ClassName: string; 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: Cardinal; + var ProcNo: Cardinal): Boolean; +var + C: TPSDelphiClassItemMethod; + P: TPSExternalProcedure; + i: Longint; + s: string; + +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: string; + var Index: Cardinal): 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: string; + var Index: Cardinal): 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: Cardinal; + var ProcNo: Cardinal): Boolean; +var + C: TPSDelphiClassItemProperty; + P: TPSExternalProcedure; + s: string; + +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: Cardinal; + 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: Cardinal; + var ProcNo: Cardinal): Boolean; +var + C: TPSDelphiClassItemProperty; + P: TPSExternalProcedure; + s: string; + +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: string): Boolean; +var + DOrgName: string; + 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: string; PropAC: TPSPropType); +var + FType: TPSType; + Param: TPSParameterDecl; + p: TPSDelphiClassItemProperty; + PT: string; +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: string): Boolean; +var + p: PPropInfo; + a: TPSPropType; +begin + if (Fclass = nil) or (Fclass.ClassInfo = nil) then begin Result := False; exit; end; + p := GetPropInfo(fclass.ClassInfo, 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: string); +var + i,h: Longint; + p: TPSDelphiClassItem; + s: string; + +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: string); +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: string); +begin + FOrgname := s; + FName := Uppercase(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 + TPSType(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: string): 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: string); +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: TPSParameter; +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: string); +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: string; 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: string; + 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 := 'intf:.' + PS_mi2s(c.AbsoluteProcOffset) + chr(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: string; + 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: string; + const cc: TPSCallingConvention): Boolean; +var + M: TPSInterfaceMethod; + DOrgName: string; + 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: string; + 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: string; + 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: string; var Index: Cardinal): Boolean; +begin + result := false; +end; + +function TPSExternalClass.ClassFunc_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; +begin + result := false; +end; + + + +{ + +Internal error counter: 00020 (increase and then use) + +} +end. + diff --git a/Source/uPSComponent.dcr b/Source/uPSComponent.dcr new file mode 100644 index 0000000000000000000000000000000000000000..9577f61fb5796967b1fbcdba1c7b106625c61e46 GIT binary patch literal 17052 zcmeI3&u<&Y8HUGpP*FV@Xb!!oTA`I?x&Voy1=vFYO=>xXfHV!{1}GqVJ5ms*W>FHA zfbbvzn!lsEENa!46gAKo)un~z+`plR1*(&)06D}Y41(A`-^~6XB{@w|Uy|-f4`=y) zv)?YM^}hLLCrT+5L6!yBoN2%Mno>VP$+D~J=W1QOsoqg{)%Vq!dW)ZT;9d0-^tbc9 zu3!JgYej;aY;d0#O1EQl+$l z2-wgDEF|C{Rmv!cKm%`#g#;X=`Eet94F)VE;2>3sO_fBT!GMJX9HgA2f(SGiu#kX* zR4IN{8i57_77}ofDy=w86@mO1u#kX*G<>uuqSs)+LIMub@UeA7ufc$Y1RSK{D=`th z1_KrnaFB+t%SQAX3|L6OK^nfwB%;?~z(N8J((pCAh+cyM3kf(#{hvUm5xoWj77}of zD$D1$DgycB2IMCJ2dT1=f(SGiu#kX*H2m3gM6bbsg#;X=;ZJHJdJP6FB;X(oe{K$9 ztp)=Y5^#`)OCgEqH5jmvfP*w#CN84aV8B8G4pM&!*)*cpV8B8G4pQa#{7yxn!GMJX zXx0uIt}nY)Nyg8>VP`gEMBBgR?saR>3ga-(4j`0@7~=`U|_TEMu?YP0 zlcJrSK0;soR*0N7hVw-`6g>~1mw})!`dp_&+Wcn=|2mtWKg_atg(iWsVKyB076vz# zy`IHwiNrB_HrF2v+N~oQ&mJ9#EQ;P39FLY;e+fE)4uP}baI5?6!Kl{@d1R0AYP)?l ze7e84^S$kP&dTTUfpO<-xWE6mt(!OJIV(9I-^SzdSvK5nY&V~CR`W;b?anHy=-F^I zYGi!o)6uLhXO}&D_Uvd5{ev)mmGQovefH=%8*#rgKA?@yik8RY_(?c`9Ax#N_}XQc z_(?~^PP@G_CHqMH#0U7I@-#)~)2+5wo}3Rzx`R&pgA2Mp(BLv%BKdIfs5QB!&Uw^r z-02P6>aMy2wO7?%mEuPVBG6#KLIMs_{769r8Vp!Sz(J}k*IDgV-0Kzhdd0n-Z=?1q zxfvBVx!FEmqO$-wqui{O}7gXK_ukt$wPeqeG zf>)_Hmc#qK!V3YsN_l&mIaSHqQDSd1vb>4Mirf690Sth^{c4xes}5#&DZOgUjeaUu zrQ5^#`mXHpP>{1~v1fP<8pNkIe}3|L6OK}yY}AOZ~rEF|C{RY(wl1_Krn zaF8m7Lj)QOSV+J@sz?P9XfR+Q0S75Qq#yzf1}r4tAjO9iM4-Wdg#;Yb9>v$E>UyfW zB~Nd?+^5PL>GbfanrcR#s;MsOp{APEtD5SZUe;9S^`fS_cwV8VDjlKP(brT{-cm+l zDO75oD!vb_^7Cq{m(^2i>W=!cpYOZet*&4H`gi!J=UYAZ=W4I2y^8rg>P5V|p8Mmr zAZ3YkzPbrzNpVY}A2D-9lu>L=`4lr-qboGJA-+@k!Dx6*U3u~1in=zGIl*G?FB=UR zj(&xW8J{A}3mSI%){nb8Id>jAk+}{uUMKk++>NZ~WOSOhyg;sl$!H+B?;A(HGy{Yyl%fAP4 zByUQWdsBD2xM^2C-t~vS+4ITk8vLV?R zPg`o<+Fn^H$2S_pMBi#Qm(Yvx=p0wtQnR_;-tZYnQOa4j*=%k-6+u$aWU$QjZL>#n zX=%G#jSbJG{YJy@uiouA!LFy4&(P+v0eFS9$Gz)h3hNs|duW<5LFaw&syK`<@^B)-s}|!^84OuQep>LV zl?Ptm+$0oqcEGFJUiZVZQ$KzZyh?ON%MPN?cvTo4bn&FZtIq54jOno)H#DE8SVQsn z^z?KyNAeeID8`Q;#G4#V;Osf@>>3KuLL*YGp(sS(vunAAVkVHM^J^&11>`_}4aIrg z@56lGMO`Af{IYd^p^kc!r&Aj|pQ=5I1y^{JhT5a*=Ta7bsy*tzS?Bk8^^}@zWj!V9 z7plerhPtI>QAb6auBZNQ)=p@?s>|ysc_#HXwbTZERZZ2kl&Nc}x|XVa3ZH&e zK2^BIA6^ezGxL7$FW-C6zqha;E;2pu*B>nO`U|a==u_O}b&T9Nyw_^A{v?_5S}M!7dtPt*1LX65A1z&dxceKg_xs^geJ%BH zZ>PC?>$^M8Hy`!ne56S&wY9gux4W~`eE9pI$!n;k_W$~nS-zVObDgT8n)kceY<^tm z)3p?Na=D!M+uxfz>h64eao%t5?C{UO{YtIzd$~{D#iQ2LZSPdIPu2BQ#5|t{1NEF= zT~B>+pOOik|1jq_Gv|~0)cUzLHRm@ye0^%pZ!(d6@|USOzsY1sD7>ss@_K4rvdFw) zc#*f>r@USr!M~L`zsq#-srAWGn11xH97dY>)a0lz7M5t_dhn^DG@=)M#;1xSi$3jB z<+qXR#5*Vgng^)C{x!_wLjH$ z)T^(fdcEavKcA|j&{}=|x7%Ki&{Q4O8?=`@2h=)VFY2fV%Y&1_VD;eOxN%Ib>Y3DF zaB^~RuzGNE((3oBI;zz|Kl$*(!D?r<(~%>DI_gG$aB|Et!_i=MH55|enG~lo7!Bt} z^CL3Jk@NKvHwcJ6H##}-XOyp>XfKz#oR75NPwg8wLY|h-GUHDy9h}Qo2+sJ^oSaZd zQmvmDk0sA1gx`I_5K@P CO3VWQ literal 0 HcmV?d00001 diff --git a/Source/uPSComponent.pas b/Source/uPSComponent.pas new file mode 100644 index 0000000..6651a3e --- /dev/null +++ b/Source/uPSComponent.pas @@ -0,0 +1,1383 @@ +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) + protected + + 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; + public + end; + + TIFPS3Plugin = class(TPSPlugin); + + TPSDllPlugin = class(TPSPlugin) + protected + 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: string): Variant of object; + TPSOnSetNotVariant = procedure (Sender: TPSScript; const Name: string; V: Variant) of object; + TPSCompOptions = set of (icAllowNoBegin, icAllowUnit, icAllowNoEnd, icBooleanShortCircuit); + + TPSVerifyProc = procedure (Sender: TPSScript; Proc: TPSInternalProcedure; const Decl: string; 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: string; var FileName, Output: string): Boolean of object; + + TPSOnProcessDirective = procedure ( + Sender: TPSPreProcessor; + Parser: TPSPascalPreProcessorParser; + const Active: Boolean; + const DirectiveName, DirectiveParam: String; + 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: string; + FOnNeedFile: TPSOnNeedFile; + FUsePreProcessor: Boolean; + FDefines: TStrings; + FOnVerifyProc: TPSVerifyProc; + FOnProcessDirective: TPSOnProcessDirective; + FOnProcessUnknowDirective: TPSOnProcessDirective; + function GetRunning: Boolean; + procedure SetScript(const Value: TStrings); + function GetCompMsg(i: Integer): TPSPascalCompilerMessage; + function GetCompMsgCount: Longint; + function GetAbout: string; + function ScriptUses(Sender: TPSPascalCompiler; const Name: string): Boolean; + function GetExecErrorByteCodePosition: Cardinal; + function GetExecErrorCode: TIFError; + function GetExecErrorParam: string; + function GetExecErrorProcNo: Cardinal; + function GetExecErrorString: string; + function GetExecErrorPosition: Cardinal; + function GetExecErrorCol: Cardinal; + function GetExecErrorRow: Cardinal; + function GetExecErrorFileName: string; + 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: string); virtual; + + //--jgv new + function DoOnNeedFile (Sender: TObject; const OrginFileName: string; var FileName, Output: string): Boolean; virtual; + function DoOnUnknowUses (Sender: TPSPascalCompiler; const Name: string): Boolean; virtual; // return true if processed + procedure DoOnCompImport; virtual; + procedure DoOnCompile; virtual; + function DoVerifyProc (Sender: TPSScript; Proc: TPSInternalProcedure; const Decl: string): Boolean; virtual; + + procedure DoOnExecImport (RunTimeImporter: TPSRuntimeClassImporter); virtual; + procedure DoOnExecute (RunTimeImporter: TPSRuntimeClassImporter); virtual; + procedure DoAfterExecute; virtual; + function DoOnGetNotificationVariant (const Name: string): Variant; virtual; + procedure DoOnSetNotificationVariant (const Name: string; V: Variant); virtual; + + procedure DoOnProcessDirective (Sender: TPSPreProcessor; + Parser: TPSPascalPreProcessorParser; + const Active: Boolean; + const DirectiveName, DirectiveParam: String; + Var Continue: Boolean); virtual; + procedure DoOnProcessUnknowDirective (Sender: TPSPreProcessor; + Parser: TPSPascalPreProcessorParser; + const Active: Boolean; + const DirectiveName, DirectiveParam: String; + Var Continue: Boolean); virtual; + public + + function FindNamedType(const Name: string): 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: string); + + procedure SetCompiled(const Data: string); + + 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): string; + + property ExecErrorCode: TIFError read GetExecErrorCode; + + property ExecErrorParam: string read GetExecErrorParam; + + property ExecErrorToString: string 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: string read GetExecErrorFileName; + + function AddFunctionEx(Ptr: Pointer; const Decl: string; CallingConv: TDelphiCallingConvention): Boolean; + + function AddFunction(Ptr: Pointer; const Decl: string): Boolean; + + + function AddMethodEx(Slf, Ptr: Pointer; const Decl: string; CallingConv: TDelphiCallingConvention): Boolean; + + function AddMethod(Slf, Ptr: Pointer; const Decl: string): Boolean; + + function AddRegisteredVariable(const VarName, VarType: string): Boolean; + function AddNotificationVariant(const VarName: string): Boolean; + + function AddRegisteredPTRVariable(const VarName, VarType: string): Boolean; + + function GetVariable(const Name: string): PIFVariant; + + function SetVarToInstance(const VarName: string; cl: TObject): Boolean; + + procedure SetPointerToData(const VarName: string; Data: Pointer; aType: TIFTypeRec); + + function TranslatePositionPos(Proc, Position: Cardinal; var Pos: Cardinal; var fn: string): Boolean; + + function TranslatePositionRC(Proc, Position: Cardinal; var Row, Col: Cardinal; var fn: string): Boolean; + + function GetProcMethod(const ProcName: string): TMethod; + + function ExecuteFunction(const Params: array of Variant; const ProcName: string): Variant; + published + + property About: string read GetAbout; + + 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: string 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; + + 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: string; + procedure SetFileName(const Value: string); + public + + property FileName: string read FFileName write SetFileName; + + property FileNameHash: Longint read FFileNameHash; + + property Line: Longint read FLine write FLine; + end; + + TPSOnLineInfo = procedure (Sender: TObject; const FileName: string; 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: string); 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: string; Line: Longint); + + procedure ClearBreakPoint(const Fn: string; Line: Longint); + + property BreakPointCount: Longint read GetBreakPointCount; + + property BreakPoint[I: Longint]: TPSBreakPointInfo read GetBreakPoint; + + function HasBreakPoint(const Fn: string; Line: Longint): Boolean; + + procedure ClearBreakPoints; + + function GetVarContents(const Name: string): string; + 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); + +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: string): Variant; +begin + Result := TPSScript (Sender.Id).DoOnGetNotificationVariant(Name); +end; + +procedure MySetVariant(Sender: TPSExec; const Name: string; V: Variant); +begin + TPSScript (Sender.Id).DoOnSetNotificationVariant(Name, V); +end; + +function CompScriptUses(Sender: TPSPascalCompiler; const Name: string): 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: string): Boolean; +begin + Result := TPSScript(Sender.ID).DoVerifyProc (Sender.ID, Proc, ProcDecl); +end; + + +procedure callObjectOnProcessDirective ( + Sender: TPSPreProcessor; + Parser: TPSPascalPreProcessorParser; + const Active: Boolean; + const DirectiveName, DirectiveParam: String; + 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: String; + 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: string): Boolean; +begin + Result := AddFunctionEx(Ptr, Decl, cdRegister); +end; + +function TPSScript.AddFunctionEx(Ptr: Pointer; const Decl: string; + 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: string): 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: string; var FileName, Output: string): Boolean; +begin + Result := TPSScript (Sender.ID).DoOnNeedFile(Sender.ID, CallingFileName, FileName, Output); +end; + +procedure CompTranslateLineInfo(Sender: TPSPascalCompiler; var Pos, Row, Col: Cardinal; var Name: string); +var + res: TPSLineInfoResults; +begin + if TPSScript(Sender.ID).FPP.CurrentLineInfo.GetLineInfo(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: string; +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 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 then + TPSPluginItem(FPlugins.Items[i]).Plugin.ExecImport2(Self, ri); + end; + RegisterClassLibraryRuntime(Exec, RI); + for i := 0 to FPlugins.Count -1 do + begin + 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.Defines.Assign(FDefines); + FComp.OnTranslateLineInfo := CompTranslateLineInfo; + Fpp.OnProcessDirective := callObjectOnProcessDirective; + Fpp.OnProcessUnknowDirective := callObjectOnProcessUnknowDirective; + Fpp.MainFile := FScript.Text; + Fpp.MainFileName := FMainFileName; + try + 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); + finally + FPP.Clear; + end; + 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): string; +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; + 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: string; +begin + Result := TPSExec.About; +end; + +procedure TPSScript.GetCompiled(var data: string); +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: string; +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: string; +begin + Result := TIFErrorToString(Exec.ExceptionCode, Exec.ExceptionString); +end; + +function TPSScript.GetVariable(const Name: string): PIFVariant; +begin + Result := FExec.GetVar2(name); +end; + +function TPSScript.LoadExec: Boolean; +var + s: string; +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: string): Boolean; +var + i: Longint; +begin + if Name = 'SYSTEM' then + begin + for i := 0 to FPlugins.Count -1 do + begin + TPSPluginItem(FPlugins.Items[i]).Plugin.CompOnUses(Self); + end; + for i := 0 to FPlugins.Count -1 do + begin + TPSPluginItem(FPlugins.Items[i]).Plugin.CompileImport1(self); + end; + + DoOnCompImport; + + for i := 0 to FPlugins.Count -1 do + begin + TPSPluginItem(FPlugins.Items[i]).Plugin.CompileImport2(Self); + end; + + DoOnCompile; + + Result := True; + end + else begin + Result := DoOnUnknowUses (Sender, Name); + If Not Result then + Sender.MakeError('', ecUnknownIdentifier, Name); + end; +end; + +procedure TPSScript.SetCompiled(const Data: string); +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 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 then + TPSPluginItem(FPlugins.Items[i]).Plugin.ExecImport2(Self, ri); + end; + RegisterClassLibraryRuntime(Exec, RI); + for i := 0 to FPlugins.Count -1 do + begin + TPSPluginItem(FPlugins.Items[i]).Plugin.ExecOnUses(Self); + end; + if not FExec.LoadData(Data) then + raise Exception.Create(GetExecErrorString); +end; + +function TPSScript.SetVarToInstance(const VarName: string; 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: string): Boolean; +begin + Result := AddMethodEx(Slf, Ptr, Decl, cdRegister); +end; + +function TPSScript.AddMethodEx(Slf, Ptr: Pointer; const Decl: string; + 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: string; + 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: string): 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: string): Boolean; +var + d1: Cardinal; +begin + Result := Exec.TranslatePositionEx(Proc, Position, d1, Row, Col, fn); +end; + + +function TPSScript.GetExecErrorRow: Cardinal; +var + D1: Cardinal; + s: string; +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: string): TMethod; +begin + Result := FExec.GetProcAsMethodN(ProcName) +end; + +procedure TPSScript.SetMainFileName(const Value: string); +begin + FMainFileName := Value; +end; + +function TPSScript.GetExecErrorFileName: string; +var + D1, D2: Cardinal; +begin + if not TranslatePositionRC(Exec.ExceptionProcNo, Exec.ExceptionPos, D1, D2, Result) then + Result := ''; +end; + +procedure TPSScript.SetPointerToData(const VarName: string; + 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: string): 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: string): Variant; +begin + Result := Exec.RunProcPN(Params, ProcName); +end; + +function TPSScript.FindBaseType(Bt: TPSBaseType): TPSTypeRec; +begin + Result := Exec.FindType2(Bt); +end; + +function TPSScript.FindNamedType(const Name: string): 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: string): Boolean; +begin + Result := AddRegisteredVariable(VarName, '!NOTIFICATIONVARIANT'); +end; + +procedure TPSScript.DoOnProcessDirective(Sender: TPSPreProcessor; + Parser: TPSPascalPreProcessorParser; const Active: Boolean; + const DirectiveName, DirectiveParam: String; 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: String; var Continue: Boolean); +begin + If Assigned (OnProcessUnknowDirective) then + OnProcessUnknowDirective (Sender, Parser, Active, DirectiveName, DirectiveParam, Continue); +end; + +function TPSScript.DoOnNeedFile(Sender: TObject; + const OrginFileName: string; var FileName, Output: string): Boolean; +begin + If Assigned (OnNeedFile) then + Result := OnNeedFile(Sender, OrginFileName, FileName, Output) + else + Result := False; +end; + +function TPSScript.DoOnUnknowUses(Sender: TPSPascalCompiler; + const Name: string): Boolean; +begin + Result := False; +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: string): 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: string): Variant; +begin + if Not Assigned (OnGetNotificationVariant) then + raise Exception.Create(RPS_UnableToReadVariant); + Result := OnGetNotificationVariant(Self, Name); +end; + +procedure TPSScript.DoOnSetNotificationVariant(const Name: string; + 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: string; Position, Row, Col: Cardinal); +var + Dc: TPSScriptDebugger; + h, i: Longint; + bi: TPSBreakPointInfo; +begin + Dc := Sender.Id; + if @dc.FOnLineInfo <> nil then dc.FOnLineInfo(dc, FileName, Position, Row, Col); + if row = dc.FLastRow then exit; + dc.FLastRow := row; + h := MakeHash(filename); + bi := nil; + for i := DC.FBreakPoints.Count -1 downto 0 do + begin + bi := Dc.FBreakpoints[i]; + if (h = bi.FileNameHash) and (FileName = 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, FileName, 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: string; 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: string): string; +var + i: Longint; + pv: PIFVariant; + s1, s: string; +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: string; 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: string; 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: string); +var + OldFn: string; + 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 := FPlugin.Name + else + Result := ''; +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: string); +begin + FFileName := Value; + FFileNameHash := MakeHash(Value); +end; + +end. diff --git a/Source/uPSComponentExt.pas b/Source/uPSComponentExt.pas new file mode 100644 index 0000000..74e6ecf --- /dev/null +++ b/Source/uPSComponentExt.pas @@ -0,0 +1,949 @@ +{ +@abstract(Component wrapper for IFPS3 compiler and executer) +A component wrapper for IFPS3, including debugging support. + +} +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: String; OnTop: Boolean) of object; + TPSOnException = procedure (Sender: TPSExec; ExError: TPSError; const ExParam: string; + ExObject: TObject; ProcNo, Position: Cardinal) of object; + + TMethodList = class; + TProcObj = Class + private + FName : String; + fOwner : TMethodList; + procedure SetName(const Value: String); + public + ProcType : TStringList; + Method : TMethod; + constructor create(aOwner: TMethodList); + destructor Destroy; override; + property Name: String read FName write SetName; + end; + + TMethodObj = Class + Instance : TPersistent; + PropName : String; + ProcName : String; + 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: String): String; + procedure SetMethodName(Instance: TObject; PropName: String; const Value: String); + procedure CreateProc(ProcName: string; aPropType: TTypeData); + public + constructor create(aOwner: TPSScriptExtension); + destructor Destroy; override; + function methodIndexOf(Instance: TObject; PropName: String):Integer; + Function ProcIndexOf(Name: String): Integer; + Procedure ListEventsName(EventType:string; List : TStrings); + + Procedure AddProcedure(ProcName, ProcType:String); + procedure InsertMethod(NewProc: String; 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:String]: String 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: STring; + + Procedure GetCodeProps ; + function GetProcName(Instance: TObject; PropName: String): string; + procedure SetProcName(Instance: TObject; PropName: String; const Value: string); + + protected + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + + procedure DoVerifyProc(Sender: TPSScript; Proc: TPSInternalProcedure; + const Decl: string; 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: String=''; 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:String]: string read GetProcName write SetProcName; + property MethodList : TMethodList read FMethodList; + + published + + property OnBeforeCleanUp: TPSOnCompCleanup read FOnBeforeCleanUp write FOnBeforeCleanUp; // + 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: string): Boolean; +begin + Result := True; + TPSScriptExtension(Sender.ID).DoVerifyProc(Sender.Id, Proc, ProcDecl, 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: string; 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 := false; +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; + inherited Destroy; +end; + +procedure TPSScriptExtension.DoVerifyProc(Sender: TPSScript; + Proc: TPSInternalProcedure; const Decl: string; var Error: Boolean); +var + n{,m,p} : Integer; + tstType : TPSProceduralType; +begin + 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 string = ('','\style{+B}out\style{-B} ','\style{+B}Var\style{-B} '); + +Procedure TPSScriptExtension.GetCodeProps; + + Function existsItem(aName:String):Boolean; + Begin + result := FInserts.indexof(aName)<> -1; + end; + + Procedure addListItem(aType, aName:String; aDef:String=''); + 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 :string); + 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:string = ''):Boolean; forward; + + Function getClassDef(xc: TPSCompileTimeClass; aZoek:string = ''):Boolean; + var + Show : Boolean; + Zoek,bZoek : String; + tci : TPSDelphiClassItem; + n : Integer; + T,v : String; + + 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:string = ''):Boolean; + var + Show : Boolean; + Zoek : String; + 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:string; aZoek : string= ''):Boolean; + var +// cv : String; + hh, h, i : Longint; + proc : TPSProcedure; + ip : TPSInternalProcedure; + ipv : PIFPSProcVar; + ipp : TPSParameterDecl; +// t : String; + 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:string): Boolean; + var + cv : String; + h, i : Longint; + proc : TPSProcedure; + xr : TPSRegProc; +// t : String; + 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; + 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 : String; + 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: STring; 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 + MethodList.SetMethodName(aComponent,'',''); + end; +end; + +function TPSScriptExtension.GetProcName(Instance: TObject; PropName: String): string; +begin + Result := MethodList.ProcName[Instance, Propname]; +end; + +procedure TPSScriptExtension.SetProcName(Instance: TObject; PropName: String; const Value: string); +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: String); +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:String; aPropType: TTypeData); +var + newProc: string; + 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: String; OnTop: Boolean = false); +var + x : Integer; + sl : TStringList; + nBegins : Integer; + nProcs : Integer; + line, test : String; + + function IsItem(line,item:String; First :Boolean = false):Boolean; + var + nPos : Integer; + begin + 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','_'])))); + 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 (line = test) then + Exit; + Inc(nProcs); + end; + 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') then begin + If nProcs = 0 then Break; + Inc(nBegins); + end; + end else begin + If IsItem(line,'BEGIN') or IsItem(line,'TRY') 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: String): String; +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: string; 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: String): 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: String): 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: String; + const Value: String); +var + x, y : Integer; + mo : TMethodObj; + function TypeData(Instance: TObject; const PropName: string):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: String); +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/Source/uPSComponent_COM.pas b/Source/uPSComponent_COM.pas new file mode 100644 index 0000000..31c1dad --- /dev/null +++ b/Source/uPSComponent_COM.pas @@ -0,0 +1,38 @@ + +unit uPSComponent_COM; + +interface +uses + SysUtils, Classes, uPSComponent, uPSCompiler, uPSRuntime; +type + + TPSImport_ComObj = class(TPSPlugin) + private + protected + 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/Source/uPSComponent_Controls.pas b/Source/uPSComponent_Controls.pas new file mode 100644 index 0000000..37543f2 --- /dev/null +++ b/Source/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; + protected + 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/Source/uPSComponent_DB.pas b/Source/uPSComponent_DB.pas new file mode 100644 index 0000000..16c35f8 --- /dev/null +++ b/Source/uPSComponent_DB.pas @@ -0,0 +1,35 @@ + unit uPSComponent_DB; + +interface +uses + SysUtils, Classes, uPSComponent, uPSRuntime, uPSCompiler; +type + + TPSImport_DB = class(TPSPlugin) + protected + 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/Source/uPSComponent_Default.pas b/Source/uPSComponent_Default.pas new file mode 100644 index 0000000..ba520fe --- /dev/null +++ b/Source/uPSComponent_Default.pas @@ -0,0 +1,81 @@ + unit uPSComponent_Default; + +interface +uses + SysUtils, Classes, uPSComponent, uPSCompiler, uPSRuntime; + +type + + TPSImport_DateUtils = class(TPSPlugin) + protected + procedure CompOnUses(CompExec: TPSScript); override; + procedure ExecOnUses(CompExec: TPSScript); override; + end; + + TPSImport_Classes = class(TPSPlugin) + private + FEnableStreams: Boolean; + FEnableClasses: Boolean; + protected + 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/Source/uPSComponent_Forms.pas b/Source/uPSComponent_Forms.pas new file mode 100644 index 0000000..8d60d5e --- /dev/null +++ b/Source/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; + protected + 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/Source/uPSComponent_StdCtrls.pas b/Source/uPSComponent_StdCtrls.pas new file mode 100644 index 0000000..66ce95c --- /dev/null +++ b/Source/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; + protected + 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/Source/uPSDebugger.pas b/Source/uPSDebugger.pas new file mode 100644 index 0000000..b9bac09 --- /dev/null +++ b/Source/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: string; + + 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: string): Boolean; + + procedure LoadDebugData(const Data: string); + + 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: string; 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: string): 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: string; + 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: string); +var + CP, I: Longint; + c: char; + CurrProcNo, LastProcNo: Cardinal; + LastProc: PFunctionInfo; + NewLoc: PPositionData; + s: string; +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: string; +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: string): Boolean; +// Made by Martijn Laan (mlaan@wintax.nl) +var + i: LongInt; + fi: PFunctionInfo; + pt: TIfList; + r: PPositionData; + lastfn: string; + 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: string): 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/Source/uPSDisassembly.pas b/Source/uPSDisassembly.pas new file mode 100644 index 0000000..98c9d09 --- /dev/null +++ b/Source/uPSDisassembly.pas @@ -0,0 +1,495 @@ + + +unit uPSDisassembly; +{$I PascalScript.inc} + +interface +uses + uPSRuntime, uPSUtils, sysutils; + +function IFPS3DataToText(const Input: string; 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: string; 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 := 'Char'; + {$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: string; + 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 + + Writeln(' ['+inttostr(dp)+'] ASSIGN '+ReadWriteVariable+ ', ' + ReadWriteVariable); + 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/Source/uPSPreProcessor.pas b/Source/uPSPreProcessor.pas new file mode 100644 index 0000000..08c847b --- /dev/null +++ b/Source/uPSPreProcessor.pas @@ -0,0 +1,777 @@ + +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: string; var FileName, Output: string): Boolean; + TPSOnProcessDirective = procedure ( + Sender: TPSPreProcessor; + Parser: TPSPascalPreProcessorParser; + const Active: Boolean; + const DirectiveName, DirectiveParam: String; + 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: string; + FLineOffsets: TIfList; + public + + property FileName: string 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: string; + 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(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: string; + FMainFile: string; + FOnProcessDirective: TPSOnProcessDirective; + FOnProcessUnknowDirective: TPSOnProcessDirective; + procedure ParserNewLine(Sender: TPSPascalPreProcessorParser; Row, Col, Pos: Cardinal); + procedure IntPreProcess(Level: Integer; const OrgFileName: string; FileName: string; 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: string read FMainFile write FMainFile; + + property MainFileName: string read FMainFileName write FMainFileName; + + property ID: Pointer read FID write FID; + + procedure AdjustMessages(Comp: TPSPascalCompiler); + procedure AdjustMessage(Msg: TPSPascalCompilerMessage); //-jgv + + procedure PreProcess(const Filename: string; var Output: string); + + 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: string; + FText: Pchar; + FToken: string; + FTokenId: TPSPascalPreProcessorType; + FLastEnterPos, FLen, FRow, FCol, FPos: Cardinal; + FOnNewLine: TPSOnNewLine; + public + + procedure SetText(const dta: string); + + procedure Next; + + property Token: string 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; + 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; + 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(Pos: Cardinal; + var Res: TPSLineInfoResults): Boolean; +var + i,j: Longint; + linepos: Cardinal; + Item: TPSLineInfo; +begin + for i := FItems.Count -1 downto 0 do + begin + Item := FItems[i]; + if (Pos >= Item.StartPos) and (Pos < Item.EndPos) 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] = '$' 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: string); +begin + FData := dta; + FText := pchar(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.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: string; FileName: string; Dest: TStream); +var + Parser: TPSPascalPreProcessorParser; + dta: string; + item: TPSLineInfo; + s, name: string; + 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(' ', 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') 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]); + FDefineState.Add.DoWrite := FCurrentDefines.IndexOf(Uppercase(s)) <> -1; + end else if (Name = 'IFNDEF') then + begin + if pos(' ', s) <> 0 then raise EPSPreProcessor.CreateFmt(RPS_DefineTooManyParameters, [Parser.Row, Parser.Col]); + FDefineState.Add.DoWrite := FCurrentDefines.IndexOf(Uppercase(s)) = -1; + 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; + ds.DoWrite := not ds.DoWrite; + end + + //-- 20050710_jgv custom application error process + else 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: string; var Output: string); +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; + +end. diff --git a/Source/uPSR_DB.pas b/Source/uPSR_DB.pas new file mode 100644 index 0000000..187f45e --- /dev/null +++ b/Source/uPSR_DB.pas @@ -0,0 +1,2070 @@ +{runtime DB support} +Unit uPSR_DB; +{$I PascalScript.inc} +Interface +Uses uPSRuntime; + +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); +begin Self.VALUE := T; end; + +procedure TBLOBFIELDVALUE_R(Self: TBLOBFIELD; var T: STRING); +begin T := Self.VALUE; 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'); + RegisterMethod(@TLOOKUPLIST.ADD, 'ADD'); + RegisterMethod(@TLOOKUPLIST.CLEAR, 'CLEAR'); + RegisterMethod(@TLOOKUPLIST.VALUEOFKEY, 'VALUEOFKEY'); + 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/Source/uPSR_buttons.pas b/Source/uPSR_buttons.pas new file mode 100644 index 0000000..8117e4e --- /dev/null +++ b/Source/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/Source/uPSR_classes.pas b/Source/uPSR_classes.pas new file mode 100644 index 0000000..b29abc8 --- /dev/null +++ b/Source/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/Source/uPSR_comobj.pas b/Source/uPSR_comobj.pas new file mode 100644 index 0000000..67ec7df --- /dev/null +++ b/Source/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/Source/uPSR_controls.pas b/Source/uPSR_controls.pas new file mode 100644 index 0000000..4435bcf --- /dev/null +++ b/Source/uPSR_controls.pas @@ -0,0 +1,247 @@ + +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} + RegisterVirtualMethod(@TDragObject.GetName, 'GetName'); + RegisterVirtualMethod(@TDragObject.HideDragImage, 'HideDragImage'); + RegisterVirtualMethod(@TDragObject.Instance, 'Instance'); + 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/Source/uPSR_dateutils.pas b/Source/uPSR_dateutils.pas new file mode 100644 index 0000000..abb9954 --- /dev/null +++ b/Source/uPSR_dateutils.pas @@ -0,0 +1,63 @@ + +unit uPSR_dateutils; + +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/Source/uPSR_dll.pas b/Source/uPSR_dll.pas new file mode 100644 index 0000000..190170c --- /dev/null +++ b/Source/uPSR_dll.pas @@ -0,0 +1,297 @@ + +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 LINUX} + LibC{$IFNDEF FPC}, Windows{$ENDIF}; + {$ELSE} + Windows; + {$ENDIF} + +{ +p^.Ext1 contains the pointer to the Proc function +p^.ExportDecl: + 'dll:'+DllName+#0+FunctionName+#0+chr(Cc)+Chr(DelayLoad)+VarParams +} + +type + PLoadedDll = ^TLoadedDll; + TLoadedDll = record + dllnamehash: Longint; + dllname: string; + {$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: string; + h, i: Longint; + ph: PLoadedDll; + {$IFDEF LINUX} + dllhandle: Pointer; + {$ELSE} + dllhandle: THandle; + {$ENDIF} +begin + s := p.Decl; + Delete(s, 1, 4); + s2 := copy(s, 1, pos(#0, s)-1); + delete(s, 1, length(s2)+1); + h := makehash(s2); + 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 LINUX} + dllhandle := dlopen(PChar(s2), RTLD_LAZY); + {$ELSE} + dllhandle := LoadLibrary(Pchar(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(copy(s, 1, pos(#0, s)-1))); + {$ELSE} + p.Ext1 := GetProcAddress(dllhandle, pchar(copy(s, 1, pos(#0, s)-1))); + {$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: string; +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(#0, s)); + delete(S, 1, pos(#0, s)); + if length(S) < 2 then + begin + Result := False; + exit; + end; + cc := TPSCallingConvention(s[1]); + delete(s, 1, 2); // cc + delayload (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: string; +begin + if not ForceDelayLoad then begin + s := p.Decl; + Delete(s,1,pos(#0, s)); + Delete(s,1,pos(#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: string; +begin + sname := Stack.GetString(-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(#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/Source/uPSR_extctrls.pas b/Source/uPSR_extctrls.pas new file mode 100644 index 0000000..0f4a129 --- /dev/null +++ b/Source/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/Source/uPSR_forms.pas b/Source/uPSR_forms.pas new file mode 100644 index 0000000..957cbb4 --- /dev/null +++ b/Source/uPSR_forms.pas @@ -0,0 +1,260 @@ + +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} + RegisterMethod(@TAPPLICATION.HELPCOMMAND, 'HELPCOMMAND'); + RegisterMethod(@TAPPLICATION.HELPCONTEXT, 'HELPCONTEXT'); + RegisterMethod(@TAPPLICATION.HELPJUMP, 'HELPJUMP'); + {$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/Source/uPSR_graphics.pas b/Source/uPSR_graphics.pas new file mode 100644 index 0000000..7a7643a --- /dev/null +++ b/Source/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/Source/uPSR_menus.pas b/Source/uPSR_menus.pas new file mode 100644 index 0000000..a4b4206 --- /dev/null +++ b/Source/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/Source/uPSR_std.pas b/Source/uPSR_std.pas new file mode 100644 index 0000000..a67946e --- /dev/null +++ b/Source/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/Source/uPSR_stdctrls.pas b/Source/uPSR_stdctrls.pas new file mode 100644 index 0000000..87eeab9 --- /dev/null +++ b/Source/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/Source/uPSRuntime.pas b/Source/uPSRuntime.pas new file mode 100644 index 0000000..5a16d66 --- /dev/null +++ b/Source/uPSRuntime.pas @@ -0,0 +1,12265 @@ +unit uPSRuntime; +{$I PascalScript.inc} +{ + +Innerfuse Pascal Script III +Copyright (C) 2000-2004 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, eInterfaceNotSupported, 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: string; + FProcPtr: TPSProcPtr; + FDecl: string; + public + + property Name: string read FName write FName; + + property Decl: string 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: string; + FExportName: string; + public + + property Data: PByteArray read FData; + + property Length: Cardinal read FLength; + + property ExportNameHash: Longint read FExportNameHash; + + property ExportName: string read FExportName write FExportName; + + property ExportDecl: string 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: string; + FBaseType: TPSBaseType; + FAttributes: TPSRuntimeAttributes; + protected + FRealSize: Cardinal; + public + + property RealSize: Cardinal read FRealSize; + + property BaseType: TPSBaseType read FBaseType write FBaseType; + + property ExportName: string 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: string; + public + + property ParamInfo: string read FParamInfo write FParamInfo; + procedure CalcSize; override; + end; + PIFTypeRec = TPSTypeRec; + + TPSTypeRec_Class = class(TPSTypeRec) + private + FCN: string; + public + + property CN: string 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; + public + + property Size: Longint read FSize write FSize; + 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 = packed record + VI: TPSVariant; + Data: WideString; + 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: string; Attr: TPSRuntimeAttribute): Boolean; + + TPSAttributeType = class + private + FTypeName: string; + FUseProc: TPSAttributeUseProc; + FTypeNameHash: Longint; + public + + property UseProc: TPSAttributeUseProc read FUseProc write FUseProc; + + property TypeName: string read FTypeName write FTypeName; + + property TypeNameHash: Longint read FTypeNameHash write FTypeNameHash; + end; + + PClassItem = ^TClassItem; + + TClassItem = record + + FName: string; + + 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: string; + FOwner: TPSRuntimeAttributes; + FAttribTypeHash: Longint; + function GetValue(I: Longint): PIFVariant; + function GetValueCount: Longint; + public + + property Owner: TPSRuntimeAttributes read FOwner; + + property AttribType: string 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: string): TPSRuntimeAttribute; + + + constructor Create(AOwner: TPSExec); + + destructor Destroy; override; + end; + TPSOnGetNVariant = function (Sender: TPSExec; const Name: string): Variant; + TPSOnSetNVariant = procedure (Sender: TPSExec; const Name: string; V: Variant); + + TPSOnLineEvent = procedure(Sender: TPSExec); + + TPSOnSpecialProcImport = function (Sender: TPSExec; p: TPSExternalProcRec; Tag: Pointer): Boolean; + + TPSOnException = procedure (Sender: TPSExec; ExError: TPSError; const ExParam: string; 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: string; + + 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: string; NewObject: TObject); Virtual; + + function FindSpecialProcImport(P: TPSOnSpecialProcImport): pointer; + Public + + procedure CMD_Err(EC: TPSError); + + procedure CMD_Err2(EC: TPSError; const Param: string); + + procedure CMD_Err3(EC: TPSError; const Param: string; ExObject: TObject); + + property Id: Pointer read FID write FID; + + class function About: string; + + function RunProc(Params: TPSList; ProcNo: Cardinal): Boolean; + + function RunProcP(const Params: array of Variant; const Procno: Cardinal): Variant; + + function RunProcPN(const Params: array of Variant; const ProcName: string): 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: string): Cardinal; + + function GetProc(const Name: string): Cardinal; + + function GetVar(const Name: string): Cardinal; + + function GetVar2(const Name: string): 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: string): 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: string; P: TPSOnSpecialProcImport; Tag: Pointer); + + function RegisterFunctionName(const Name: string; ProcPtr: TPSProcPtr; + Ext1, Ext2: Pointer): PProcRec; + + procedure RegisterDelphiFunction(ProcPtr: Pointer; const Name: string; CC: TPSCallingConvention); + + procedure RegisterDelphiMethod(Slf, ProcPtr: Pointer; const Name: string; CC: TPSCallingConvention); + + function GetProcAsMethod(const ProcNo: Cardinal): TMethod; + + function GetProcAsMethodN(const ProcName: string): TMethod; + + procedure RegisterAttributeType(useproc: TPSAttributeUseProc; const TypeName: string); + + procedure ClearFunctionList; + + property ExceptionProcNo: Cardinal Read ExProc; + + property ExceptionPos: Cardinal Read ExPos; + + property ExceptionCode: TPSError Read ExEx; + + property ExceptionString: string 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; +{$IFNDEF PS_NOWIDESTRING} + function GetWideString(ItemNo: Longint): WideString; +{$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); +{$IFNDEF PS_NOWIDESTRING} + procedure SetWideString(ItemNo: Longint; const Data: WideString); +{$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: string): string; +function TIFErrorToString(x: TPSError; const Param: string): string; +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; +{$IFNDEF PS_NOWIDESTRING} +function PSGetWideString(Src: Pointer; aType: TPSTypeRec): WideString; +{$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); +{$IFNDEF PS_NOWIDESTRING} +procedure PSSetWideString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: WideString); +{$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; +{$IFNDEF PS_NOWIDESTRING} +function VNGetWideString(const Src: TPSVariantIFC): WideString; +{$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); +{$IFNDEF PS_NOWIDESTRING} +procedure VNSetWideString(const Src: TPSVariantIFC; const Val: WideString); +{$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; +{$IFNDEF PS_NOWIDESTRING} +function VGetWideString(const Src: PIFVariant): WideString; +{$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); +{$IFNDEF PS_NOWIDESTRING} +procedure VSetWideString(const Src: PIFVariant; const Val: WideString); +{$ENDIF} + +type + + EPSException = class(Exception) + private + FProcPos: Cardinal; + FProcNo: Cardinal; + FExec: TPSExec; + public + + constructor Create(const Error: string; 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: string; + FClassNameHash: Longint; + + FClassItems: TPSList; + FClass: TClass; + + FEndOfVmt: Longint; + public + + procedure RegisterConstructor(ProcPtr: Pointer; const Name: string); + + procedure RegisterVirtualConstructor(ProcPtr: Pointer; const Name: string); + + procedure RegisterMethod(ProcPtr: Pointer; const Name: string); + + procedure RegisterVirtualMethod(ProcPtr: Pointer; const Name: string); + + procedure RegisterVirtualAbstractMethod(ClassDef: TClass; ProcPtr: Pointer; const Name: string); + + procedure RegisterPropertyHelper(ReadFunc, WriteFunc: Pointer; const Name: string); + + procedure RegisterPropertyHelperName(ReadFunc, WriteFunc: Pointer; const Name: string); + + procedure RegisterEventPropertyHelper(ReadFunc, WriteFunc: Pointer; const Name: string); + + constructor Create(aClass: TClass; const AName: string); + + 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: string): TPSRuntimeClass; + + procedure Clear; + + function FindClass(const Name: string): 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: string): string; +function MakeString(const s: string): string; +{$IFNDEF PS_NOWIDESTRING} +function MakeWString(const s: widestring): string; +{$ENDIF} + +{$IFNDEF PS_NOIDISPATCH} +function IDispatchInvoke(Self: IDispatch; PropertySet: Boolean; const Name: String; 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_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: string; + FNameHash: Longint; + FVarNo: Cardinal; + end; + PRaiseFrame = ^TRaiseFrame; + TRaiseFrame = record + NextRaise: PRaiseFrame; + ExceptAddr: Pointer; + ExceptObject: TObject; + ExceptionRecord: Pointer; + end; + PPSExceptionHandler =^TPSExceptionHandler; + TPSExceptionHandler = packed record + CurrProc: TPSInternalProcRec; + BasePtr, StackSize: Cardinal; + FinallyOffset, ExceptOffset, Finally2Offset, EndOfBlock: Cardinal; + 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: string; + tag: pointer; + 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: string): string; +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): string; +begin + Result := Sysutils.FloatToStr(e); +end; + +//------------------------------------------------------------------- + +function Padl(s: string; i: longInt): string; +begin + result := StringOfChar(' ', i - length(s)) + s; +end; +//------------------------------------------------------------------- + +function Padz(s: string; i: longInt): string; +begin + result := StringOfChar('0', i - length(s)) + s; +end; +//------------------------------------------------------------------- + +function Padr(s: string; i: longInt): string; +begin + result := s + StringOfChar(' ', i - Length(s)); +end; +//------------------------------------------------------------------- + +{$IFNDEF PS_NOWIDESTRING} +function MakeWString(const s: widestring): string; +var + i: Longint; + e: string; + 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) 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: string): string; +var + i: Longint; + e: string; + 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: string): string; +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: string): string; +var + s: string; + i: Longint; + PP: PPropInfo; +begin + if PName = '' then + begin + Result := Instance.ClassName; + exit; + end; + while Length(PName) > 0 do + begin + i := pos('.', 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), s); + if pp = nil then begin Result := 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 := 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 := ''''+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 := ''''+GetWideStrProp(Instance, pp)+''; end; {$ENDIF} + {$ENDIF} + else begin Result := '[Unknown]'; exit; end; + end; + if Instance = nil then begin result := 'nil'; exit; end; + end; + Result := Instance.ClassName; +end; + +function ClassVariantInfo(const pvar: TPSVariantIFC; const PropertyName: string): string; +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 := RPS_InvalidType; +end; + +function PSVariantToString(const p: TPSVariantIFC; const ClassProperties: string): string; +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(variant(p.Dta^)) + else + Result := Variant(p.Dta^); + except + on e: Exception do + Result := 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, btPChar: Result := makestring(string(p.dta^)); + btchar: Result := MakeString(tbtchar(p.dta^)); + {$IFNDEF PS_NOWIDESTRING} + btwidechar: Result := MakeWString(tbtwidechar(p.dta^)); + btWideString: Result := MakeWString(tbtwidestring(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 := RPS_Invalid; + end; +end; + + + +function TIFErrorToString(x: TPSError; const Param: string): string; +begin + Result := PSErrorToString(x,param); +end; + +function PSErrorToString(x: TPSError; const Param: string): string; +begin + case x of + ErNoError: Result := RPS_NoError; + erCannotImport: Result := Format (RPS_CannotImport, [Safestr(Param)]); + erInvalidType: Result := RPS_InvalidType; + ErInternalError: Result := RPS_InternalError; + erInvalidHeader: Result := RPS_InvalidHeader; + erInvalidOpcode: Result := RPS_InvalidOpcode; + erInvalidOpcodeParameter: Result := RPS_InvalidOpcodeParameter; + erNoMainProc: Result := RPS_NoMainProc; + erOutOfGlobalVarsRange: Result := RPS_OutOfGlobalVarsRange; + erOutOfProcRange: Result := RPS_OutOfProcRange; + ErOutOfRange: Result := RPS_OutOfRange; + erOutOfStackRange: Result := RPS_OutOfStackRange; + ErTypeMismatch: Result := RPS_TypeMismatch; + erUnexpectedEof: Result := RPS_UnexpectedEof; + erVersionError: Result := RPS_VersionError; + ErDivideByZero: Result := RPS_DivideByZero; + erMathError: Result := RPS_MathError; + erCouldNotCallProc: begin Result := RPS_CouldNotCallProc; if (Param <> '') then Result := result +' ('+Param+')'; end; + erOutofRecordRange: Result := RPS_OutofRecordRange; + erNullPointerException: Result := RPS_NullPointerException; + erNullVariantError: Result := RPS_NullVariantError; + erOutOfMemory: Result := RPS_OutOfMemory; + erException: Result := Format (RPS_Exception, [Param]); + eInterfaceNotSupported: Result := RPS_InterfaceNotSupported; + erCustomError: Result := Param; + else + Result := 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, {$ENDIF}{$IFNDEF PS_NOINTERFACES}btInterface, {$ENDIF}btSingle, bts32, btU32, + btclass, btPChar, btString: FrealSize := 4; + btProcPtr: FRealSize := 2 * sizeof(Pointer) + sizeof(Cardinal); + btCurrency: FrealSize := Sizeof(Currency); + btPointer: FRealSize := 12; // 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 + + Cardinal(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}btWideString, {$ENDIF}btClass, + btInterface, btArray: tbtu32(P^) := 0; + btPointer: + begin + Pointer(p^) := nil; + Pointer(Pointer(IPointer(p)+4)^) := nil; + Pointer(Pointer(IPointer(p)+8)^) := nil; + end; + btProcPtr: + begin + Longint(p^) := 0; + Pointer(Pointer(IPointer(p)+4)^) := nil; + Pointer(Pointer(IPointer(p)+8)^) := 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},btWideString{$ENDIF}]; + +procedure FinalizeVariant(p: Pointer; aType: TPSTypeRec); +var + t: TPSTypeRec; + elsize: Cardinal; + i, l: Longint; + darr: Pointer; +begin + case aType.BaseType of + btString: string(p^) := ''; + {$IFNDEF PS_NOWIDESTRING}btWideString: widestring(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)+8)^) <> nil then + begin + DestroyHeapVariant2(Pointer(p^), Pointer(Pointer(IPointer(p)+4)^)); + Pointer(p^) := nil; + end; + btArray: + begin + if IPointer(P^) = 0 then exit; + darr := Pointer(IPointer(p^) - 8); + 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) + 4); + l := Longint(darr^); + darr := Pointer(IPointer(darr) + 4); + case t.BaseType of + btString, {$IFNDEF PS_NOWIDESTRING}btWideString, {$ENDIF}{$IFNDEF PS_NOINTERFACES}btInterface, {$ENDIF}btArray, btStaticArray, + btRecord, btPointer: + begin + for i := 0 to l -1 do + begin + FinalizeVariant(darr, t); + darr := Pointer(IPointer(darr) + elsize); + end; + end; + end; + FreeMem(Pointer(IPointer(p^) - 8), Cardinal(l) * elsize + 8); + 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}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}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)+4), aType); +end; + +procedure DestroyHeapVariant(v: PPSVariant); +begin + if v = nil then exit; + if v.FType.BaseType in NeedFinalization then + FinalizeVariant(Pointer(IPointer(v)+4), 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: string; +begin + Result := 'RemObjects Pascal Script. Copyright (c) 2004 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)+4), Pointer(P^)); + InitializeVariant(Pointer(IPointer(p)+4), Pointer(P^)); + end; +end; + +procedure TPSExec.Clear; +var + I: Longint; + temp: PPSResource; + Proc: TPSResourceFreeProc; + pp: PPSExceptionHandler; +begin + for i := Longint(FExceptionStack.Count) -1 downto 0 do + begin + pp := FExceptionStack.Data^[i]; + Dispose(pp); + 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: string; NewObject: TObject); +var + d, l: Longint; + pp: PPSExceptionHandler; +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 + Dispose(pp); + FExceptionStack.DeleteLast; + 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); + Exit; + end else if pp^.Finally2Offset <> InvalidVal then + begin + FCurrentPosition := pp^.Finally2Offset; + pp^.Finally2Offset := InvalidVal; + Exit; + end; + Dispose(pp); + 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: string; + I, fnh: Longint; + P: PSpecialProc; + +begin + if name = '' then + begin + fname := proc.Decl; + fname := copy(fname, 1, pos(':', 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: string; ProcPtr: TPSProcPtr; Ext1, Ext2: Pointer): PProcRec; +var + p: PProcRec; + s: string; +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: string): 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: string; + 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; + PPSVariantU32(varp)^.Data := Cardinal((@FData^[FCurrentPosition])^); + Inc(FCurrentPosition, 4); + end; + btProcPtr: + begin + if FCurrentPosition + 3 >= FDataLength then + begin + Cmd_Err(erOutOfRange); + DestroyHeapVariant(VarP); + Result := False; + exit;; + end; + PPSVariantU32(varp)^.Data := Cardinal((@FData^[FCurrentPosition])^); + 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; + {$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}, 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; + 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: string; + 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) <> 0then + 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)+4)^) := aType; + Pointer(Pointer(IPointer(Src.Dta)+8)^) := 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 VNGetString(const Src: TPSVariantIFC): String; +begin + Result := PSGetString(Src.Dta, Src.aType); +end; + +{$IFNDEF PS_NOWIDESTRING} +function VNGetWideString(const Src: TPSVariantIFC): WideString; +begin + Result := PSGetWideString(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 VNSetString(const Src: TPSVariantIFC; const Val: String); +var + Dummy: Boolean; +begin + PSSetString(Src.Dta, Src.aType, Dummy, Val); +end; + +{$IFNDEF PS_NOWIDESTRING} +procedure VNSetWideString(const Src: TPSVariantIFC; const Val: WideString); +var + Dummy: Boolean; +begin + PSSetWideString(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 VGetString(const Src: PIFVariant): String; +begin + Result := PSGetString(@PPSVariantData(src).Data, src.FType); +end; + +{$IFNDEF PS_NOWIDESTRING} +function VGetWideString(const Src: PIFVariant): WideString; +begin + Result := PSGetWideString(@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 VSetString(const Src: PIFVariant; const Val: String); +var + Dummy: Boolean; +begin + PSSetString(@PPSVariantData(src).Data, src.FType, Dummy, Val); +end; + +{$IFNDEF PS_NOWIDESTRING} +procedure VSetWideString(const Src: PIFVariant; const Val: WideString); +var + Dummy: Boolean; +begin + PSSetWideString(@PPSVariantData(src).Data, src.FType, Dummy, Val); +end; +{$ENDIF} + +{$IFNDEF PS_NOWIDESTRING} +function VarToWideStr(const Data: Variant): WideString; +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)+4)^); + 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)+4)^); + 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)+4)^); + 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)+4)^); + 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)+4)^); + 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)+4)^); + 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)+4)^); + 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 PSGetString(Src: Pointer; aType: TPSTypeRec): String; +begin + if aType.BaseType = btPointer then + begin + atype := PIFTypeRec(Pointer(IPointer(Src)+4)^); + 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^)); + btChar: Result := tbtchar(Src^); + btPchar: Result := pchar(src^); +{$IFNDEF PS_NOWIDESTRING} btWideChar: Result := tbtwidechar(Src^);{$ENDIF} + btString: Result := tbtstring(src^); +{$IFNDEF PS_NOWIDESTRING} btWideString: Result := tbtwidestring(src^);{$ENDIF} + btVariant: Result := Variant(src^); + else raise Exception.Create(RPS_TypeMismatch); + end; +end; +{$IFNDEF PS_NOWIDESTRING} +function PSGetWideString(Src: Pointer; aType: TPSTypeRec): WideString; +begin + if aType.BaseType = btPointer then + begin + atype := PIFTypeRec(Pointer(IPointer(Src)+4)^); + 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 := tbtchar(Src^); + btPchar: Result := pchar(src^); + btWideChar: Result := tbtwidechar(Src^); + btString: Result := tbtstring(src^); + btWideString: Result := tbtwidestring(src^); + btVariant: Result := Variant(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)+4)^); + 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)+4)^) := nil; + Pointer(Pointer(IPointer(Src)+8)^) := nil; + end; + btU32: tbtu32(src^) := Val; + btS32: tbts32(src^) := Val; +{$IFNDEF PS_NOINT64} btS64: tbts64(src^) := Val;{$ENDIF} + btChar: tbtchar(Src^) := Chr(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)+4)^); + 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^) := Chr(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)+4)^); + 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)+4)^); + 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)+4)^); + 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)+4)^) := nil; + Pointer(Pointer(IPointer(Src)+8)^) := nil; + end; + btU32: tbtu32(src^) := Val; + btS32: tbts32(src^) := Val; +{$IFNDEF PS_NOINT64} btS64: tbts64(src^) := Val;{$ENDIF} + btChar: tbtchar(Src^) := Chr(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 PSSetString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: String); +begin + if (Src = nil) or (aType = nil) then begin Ok := false; exit; end; + if aType.BaseType = btPointer then + begin + atype := PIFTypeRec(Pointer(IPointer(Src)+4)^); + 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} btWideString: tbtwidestring(src^) := 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: WideString); +begin + if (Src = nil) or (aType = nil) then begin Ok := false; exit; end; + if aType.BaseType = btPointer then + begin + atype := PIFTypeRec(Pointer(IPointer(Src)+4)^); + Src := Pointer(Src^); + if (src = nil) or (aType = nil) then begin Ok := false; exit; end; + end; + case aType.BaseType of + btString: tbtstring(src^) := val; + btWideString: tbtwidestring(src^) := val; + btVariant: + begin + try + Variant(src^) := Val; + except + Ok := false; + end; + end; + else ok := false; + end; +end; +{$ENDIF} + +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 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); + tbtU32(Dest^) := tbtU32(Src^); + Dest := Pointer(IPointer(Dest) + 4); + Src := Pointer(IPointer(Src) + 4); + tbtU32(Dest^) := tbtU32(Src^); + Dest := Pointer(IPointer(Dest) + 4); + Src := Pointer(IPointer(Src) + 4); + end; + btU32, btS32, btClass, btSingle, btpchar: + 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) + 4); + Src := Pointer(IPointer(Src) + 4); + end; + {$IFNDEF PS_NOWIDESTRING}btWideString: + for i := 0 to Len -1 do + begin + tbtWideString(Dest^) := tbtWideString(Src^); + Dest := Pointer(IPointer(Dest) + 4); + Src := Pointer(IPointer(Src) + 4); + 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^)-8)^)); // RefCount + end; + Dest := Pointer(IPointer(Dest) + 4); + Src := Pointer(IPointer(Src) + 4); + 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) + 4); + Src := Pointer(IPointer(Src) + 4); + end; + end; +{$ENDIF} + btPointer: + begin + if (Pointer(Pointer(IPointer(Dest)+8)^) = nil) and (Pointer(Pointer(IPointer(Src)+8)^) = nil) then + begin + for i := 0 to Len -1 do + begin + Pointer(Dest^) := Pointer(Src^); + Dest := Pointer(IPointer(Dest) + 4); + Src := Pointer(IPointer(Src) + 4); + Pointer(Dest^) := Pointer(Src^); + Dest := Pointer(IPointer(Dest) + 4); + Src := Pointer(IPointer(Src) + 4); + Pointer(Dest^) := nil; + Dest := Pointer(IPointer(Dest) + 4); + Src := Pointer(IPointer(Src) + 4); + end; + end else begin + for i := 0 to Len -1 do + begin + if Pointer(Pointer(IPointer(Dest)+8)^) <> nil then + DestroyHeapVariant2(Pointer(Dest^), Pointer(Pointer(IPointer(Dest)+4)^)); + if Pointer(Src^) <> nil then + begin + if Pointer(Pointer(IPointer(Src) + 8)^) = nil then + begin + Pointer(Dest^) := Pointer(Src^); + Pointer(Pointer(IPointer(Dest) + 4)^) := Pointer(Pointer(IPointer(Src) + 4)^); + Pointer(Pointer(IPointer(Dest) + 8)^) := Pointer(Pointer(IPointer(Src) + 8)^); + end else + begin + Pointer(Dest^) := CreateHeapVariant2(Pointer(Pointer(IPointer(Src) + 4)^)); + Pointer(Pointer(IPointer(Dest) + 4)^) := Pointer(Pointer(IPointer(Src) + 4)^); + Pointer(Pointer(IPointer(Dest) + 8)^) := Pointer(1); + if not CopyArrayContents(Pointer(Dest^), Pointer(Src^), 1, Pointer(Pointer(IPointer(Dest) + 4)^)) then + begin + Result := false; + exit; + end; + end; + end else + begin + Pointer(Dest^) := nil; + Pointer(Pointer(IPointer(Dest) + 4)^) := nil; + Pointer(Pointer(IPointer(Dest) + 8)^) := nil; + end; + Dest := Pointer(IPointer(Dest) + 12); + Src := Pointer(IPointer(Src) + 12); + 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)-4)^); +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)-8)^) = 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)-8); + if NewLength <= 0 then + begin + FreeMem(arr, NewLength * elsize + 8); + arr := nil; + exit; + end; + ReallocMem(arr, NewLength * elSize + 8); + arr := Pointer(IPointer(Arr)+4); + Longint(Arr^) := NewLength; + arr := Pointer(IPointer(Arr)+4); + 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)-8)^) = 1 then + FreeMem(Pointer(IPointer(Arr)-8), OldLen * elSize + 8) + else if Longint(Pointer(IPointer(Arr)-8)^) > 0 then + Dec(Longint(Pointer(IPointer(Arr)-8)^)); + arr := nil; + exit; + end; + GetMem(p, NewLength * elSize + 8); + Longint(p^) := 1; + p:= Pointer(IPointer(p)+4); + Longint(p^) := NewLength; + p := Pointer(IPointer(p)+4); + 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): 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; +{$ENDIF} + + +{$IFNDEF DELPHI3UP} +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 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)+4)^); + 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)+4)^) := Pointer(Pointer(IPointer(Src)+4)^); + Pointer(Pointer(IPointer(Dest)+8)^) := Pointer(Pointer(IPointer(Src)+8)^); + end; + else raise Exception.Create(RPS_TypeMismatch); + end; + end; + btU32: + begin + if srctype.BaseType = btPointer then + begin + srctype := PIFTypeRec(Pointer(IPointer(Src)+4)^); + 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)+4)^); + 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^); + 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)+4)^); + 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)+4)^); + 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)+4)^); + 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: pchar(dest^) := pchar(PSGetString(Src, srctype)); + btString: + tbtstring(dest^) := PSGetString(Src, srctype); + btChar: tbtchar(dest^) := chr(PSGetUInt(Src, srctype)); + {$IFNDEF PS_NOWIDESTRING} + btWideString: tbtwidestring(dest^) := PSGetWideString(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 (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 + 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(eInterfaceNotSupported); + 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, 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, 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; + +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); + 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 := char(tbtu8(var1^)) >= PSGetString(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)+4)^); + 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^); + {$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^) >= PSGetString(Var2, var2type); + btChar: b := tbtchar(var1^) >= PSGetString(Var2, var2type); + {$IFNDEF PS_NOWIDESTRING} + btWideChar: b := tbtwidechar(var1^) >= PSGetWideString(Var2, var2type); + btWideString: b := tbtwidestring(var1^) >= PSGetWideString(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 := char(tbtu8(var1^)) <= PSGetString(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)+4)^); + 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^); + {$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^) <= PSGetString(Var2, var2type); + btChar: b := tbtchar(var1^) <= PSGetString(Var2, var2type); + {$IFNDEF PS_NOWIDESTRING} + btWideChar: b := tbtwidechar(var1^) <= PSGetWideString(Var2, var2type); + btWideString: b := tbtwidestring(var1^) <= PSGetWideString(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 := char(tbtu8(var1^)) > PSGetString(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)+4)^); + 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^); + {$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^) > PSGetString(Var2, var2type); + btChar: b := tbtchar(var1^) > PSGetString(Var2, var2type); + {$IFNDEF PS_NOWIDESTRING} + btWideChar: b := tbtwidechar(var1^) > PSGetWideString(Var2, var2type); + btWideString: b := tbtwidestring(var1^) > PSGetWideString(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 := char(tbtu8(var1^)) < PSGetString(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)+4)^); + 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^); + {$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^) < PSGetString(Var2, var2type); + btChar: b := tbtchar(var1^) < PSGetString(Var2, var2type); + {$IFNDEF PS_NOWIDESTRING} + btWideChar: b := tbtwidechar(var1^) < PSGetWideString(Var2, var2type); + btWideString: b := tbtwidestring(var1^) < PSGetWideString(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 := char(tbtu8(var1^)) <> PSGetString(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)+8)^) <> Pointer(Pointer(IPointer(Var2)+8)^)) or + (Pointer(Pointer(IPointer(Var1)+8)^) <> Pointer(Pointer(IPointer(Var2)+8)^))) + 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)+4)^); + 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^); + {$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^) <> PSGetString(Var2, var2type); + {$IFNDEF PS_NOINT64} + btS64: b := tbts64(var1^) <> PSGetInt64(Var2, var2type); + {$ENDIF} + btChar: b := tbtchar(var1^) <> PSGetString(Var2, var2type); + {$IFNDEF PS_NOWIDESTRING} + btWideChar: b := tbtwidechar(var1^) <> PSGetWideString(Var2, var2type); + btWideString: b := tbtwidestring(var1^) <> PSGetWideString(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 := char(tbtu8(var1^)) = PSGetString(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)+8)^) = Pointer(Pointer(IPointer(Var2)+8)^)) and + (Pointer(Pointer(IPointer(Var1)+8)^) = Pointer(Pointer(IPointer(Var2)+8)^))) + else + b := True; + end else b := False; + end; + btS32: + begin + if var2type.BaseType = btPointer then + begin + var2type := PIFTypeRec(Pointer(IPointer(var2)+4)^); + 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^); + {$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^) = PSGetString(Var2, var2type); + {$IFNDEF PS_NOINT64} + btS64: b := tbts64(var1^) = PSGetInt64(Var2, var2type); + {$ENDIF} + btChar: b := tbtchar(var1^) = PSGetString(Var2, var2type); + {$IFNDEF PS_NOWIDESTRING} + btWideChar: b := tbtwidechar(var1^) = PSGetWideString(Var2, var2type); + btWideString: b := tbtwidestring(var1^) = PSGetWideString(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 = 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, 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, 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)+4)^); + 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)+4)^); + 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)+4)^); + 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)+4)^); + 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)+4)^); + 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)+4)^); + 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^) + PSGetString(Var2, var2type); + btChar: tbtchar(var1^) := char(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); + {$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_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)+4)^); + 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)+4)^); + 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)+4)^); + 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)+4)^); + 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)+4)^); + 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)+4)^); + 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^):= char(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)+4)^); + 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)+4)^); + 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)+4)^); + 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)+4)^); + 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)+4)^); + 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)+4)^); + 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)+4)^); + 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)+4)^); + 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)+4)^); + 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)+4)^); + 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)+4)^); + 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)+4)^); + 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)+4)^); + 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)+4)^); + 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, 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, 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); + Param := Cardinal((@FData^[FCurrentPosition])^); + 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; + tbtu16(dest.p^) := tbtu16((@FData^[FCurrentPosition])^); + Inc(FCurrentPosition, 2); + end; + bts32, btU32: + begin + if FCurrentPosition + 3>= FDataLength then + begin + CMD_Err(erOutOfRange); + FTempVars.Pop; + Result := False; + exit; + end; + tbtu32(dest.p^) := tbtu32((@FData^[FCurrentPosition])^); + Inc(FCurrentPosition, 4); + end; + btProcPtr: + begin + if FCurrentPosition + 3>= FDataLength then + begin + CMD_Err(erOutOfRange); + FTempVars.Pop; + Result := False; + exit; + end; + tbtu32(dest.p^) := tbtu32((@FData^[FCurrentPosition])^); + tbtu32(Pointer(IPointer(dest.p)+4)^) := 0; + tbtu32(Pointer(IPointer(dest.p)+8)^) := 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; + tbts64(dest.p^) := tbts64((@FData^[FCurrentPosition])^); + Inc(FCurrentPosition, 8); + end; + {$ENDIF} + btSingle: + begin + if FCurrentPosition + (Sizeof(Single)-1)>= FDataLength then + begin + CMD_Err(erOutOfRange); + FTempVars.Pop; + Result := False; + exit; + end; + tbtsingle(dest.p^) := tbtsingle((@FData^[FCurrentPosition])^); + Inc(FCurrentPosition, Sizeof(Single)); + end; + btDouble: + begin + if FCurrentPosition + (Sizeof(Double)-1)>= FDataLength then + begin + CMD_Err(erOutOfRange); + FTempVars.Pop; + Result := False; + exit; + end; + tbtdouble(dest.p^) := tbtdouble((@FData^[FCurrentPosition])^); + Inc(FCurrentPosition, Sizeof(double)); + end; + + btExtended: + begin + if FCurrentPosition + (sizeof(Extended)-1)>= FDataLength then + begin + CMD_Err(erOutOfRange); + FTempVars.Pop; + Result := False; + exit; + end; + tbtextended(dest.p^) := tbtextended((@FData^[FCurrentPosition])^); + Inc(FCurrentPosition, sizeof(Extended)); + end; + btPchar, btString: + begin + if FCurrentPosition + 3 >= FDataLength then + begin + Cmd_Err(erOutOfRange); + FTempVars.Pop; + Result := False; + exit; + end; + Param := Cardinal((@FData^[FCurrentPosition])^); + 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; + Param := Cardinal((@FData^[FCurrentPosition])^); + 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; + {$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; + Param := Cardinal((@FData^[FCurrentPosition])^); + 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)+4)^); + 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; + Param := Cardinal((@FData^[FCurrentPosition])^); + 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)+4)^); + 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 + b := Cardinal((@FData^[FCurrentPosition])^); + 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: string; + 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.RunProcPN(const Params: array of Variant; const ProcName: string): 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, 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, 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: string): Cardinal; +var + MM, + I: Longint; + n: PIFProcRec; + s: string; +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: string): Cardinal; +var + MM, + I: Longint; + n: PIFTypeRec; + s: string; +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: string; 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: string; + 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: string): Cardinal; +var + l: Longint; + h: longint; + s: string; + 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: string): 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: PPSExceptionHandler; + 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]; + Dispose(pp); + 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; + 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)+4); + 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)+4)^); + 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; + 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)+4), 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; + p := Cardinal((@FData^[FCurrentPosition])^); + 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 + Result := False; + ExceptionProc(EPSException(tmp).ProcNo, EPSException(tmp).ProcPos, erCustomError, 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, Exception(Tmp).Message, Tmp) else + CMD_Err3(erException, '', Tmp); + Break; + end; + end + else begin + Vtemp := Fstack.PushType(FReturnAddressType); + vd.P := Pointer(IPointer(VTemp)+4); + 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; + p := Cardinal((@FData^[FCurrentPosition])^); + 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; + p := Cardinal((@FData^[FCurrentPosition])^); + Inc(FCurrentPosition, 4); + FCurrentPosition := FCurrentPosition + p; + end; + Cm_G: + begin + if FCurrentPosition + 3 >= FDataLength then + begin + Cmd_Err(erOutOfRange); + Break; + end; + p := Cardinal((@FData^[FCurrentPosition])^); + Inc(FCurrentPosition, 4); + FCurrentPosition := FCurrentPosition + p; + end; + Cm_CG: + begin + if FCurrentPosition + 3 >= FDataLength then + begin + Cmd_Err(erOutOfRange); + Break; + end; + p := Cardinal((@FData^[FCurrentPosition])^); + 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; + p := Cardinal((@FData^[FCurrentPosition])^); + 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^.ExceptOffset = InvalidVal -1) then // we are in an try/except + begin + ExceptionProc(InvalidVal, InvalidVal, erNoError, '', nil); + end else + 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 + Dispose(pp); + 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; + p := Cardinal((@FData^[FCurrentPosition])^); + 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; + p := Cardinal((@FData^[FCurrentPosition])^); + Inc(FCurrentPosition, 4); + if FJumpFlag then + FCurrentPosition := FCurrentPosition + p; + end; + cm_puexh: + begin + New(pp); + pp^.CurrProc := FCurrProc; + pp^.BasePtr :=FCurrStackBase; + pp^.StackSize := FStack.Count; + if not ReadLong(pp^.FinallyOffset) then begin + CMD_Err(erOutOfRange); + Dispose(pp); + Break; + end; + if not ReadLong(pp^.ExceptOffset) then begin + CMD_Err(erOutOfRange); + Dispose(pp); + Break; + end; + if not ReadLong(pp^.Finally2Offset) then begin + CMD_Err(erOutOfRange); + Dispose(pp); + Break; + end; + if not ReadLong(pp^.EndOfBlock) then begin + CMD_Err(erOutOfRange); + Dispose(pp); + 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); + Dispose(pp); + 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 + ExceptionProc(InvalidVal, InvalidVal, erNoError, '', nil); + 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; + Dispose(pp); + 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; + Dispose(pp); + 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); + end else if (pp^.Finally2Offset <> InvalidVal) then + begin + FCurrentPosition := pp^.Finally2Offset; + pp^.Finally2Offset := InvalidVal; + end else begin + p := pp^.EndOfBlock; + Dispose(pp); + 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; + 3: + begin + pp := FExceptionStack.Data^[FExceptionStack.Count -1]; + if pp = nil then begin + cmd_err(ErOutOfRange); + Break; + end; + p := pp^.EndOfBlock; + Dispose(pp); + 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)+8)^) <> nil then + DestroyHeapVariant2(Pointer(vD.P^), Pointer(Pointer(IPointer(vd.P)+4)^)); + if vs.aType.BaseType = btPointer then + begin + if Pointer(vs.P^) <> nil then + begin + Pointer(vd.P^) := CreateHeapVariant2(Pointer(Pointer(IPointer(vs.P) + 4)^)); + Pointer(Pointer(IPointer(vd.P) + 4)^) := Pointer(Pointer(IPointer(vs.P) + 4)^); + Pointer(Pointer(IPointer(vd.P) + 8)^) := Pointer(1); + if not CopyArrayContents(Pointer(vd.P^), Pointer(vs.P^), 1, Pointer(Pointer(IPointer(vd.P) + 4)^)) 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) + 4)^) := nil; + Pointer(Pointer(IPointer(vd.P) + 8)^) := nil; + end; + end else begin + Pointer(vd.P^) := CreateHeapVariant2(vs.aType); + Pointer(Pointer(IPointer(vd.P) + 4)^) := vs.aType; + Pointer(Pointer(IPointer(vd.P) + 8)^) := Pointer(1); + 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)+4)^) := Pointer(Pointer(IPointer(vs.P)+4)^); + end + else + begin + Pointer(vd.P^) := vs.P; + Pointer(Pointer(IPointer(vd.P)+4)^) := 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)+8)^) <> nil) then + begin + if not InvokeExternalMethod(TPSTypeRec_ProcPtr(vd.aType), Pointer(Pointer(IPointer(vd.p)+4)^), Pointer(Pointer(IPointer(vd.p)+8)^)) 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 + if not TPSExternalProcRec(u).ProcPtr(Self, TPSExternalProcRec(u), FGlobalVars, FStack) then + CMD_Err(erCouldNotCallProc); + 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.GetString(-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.GetString(-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; + Tmp: TObject; +begin + case Longint(p.Ext1) of + 0: Stack.SetString(-1, IntToStr(Stack.GetInt(-2))); // inttostr + 1: Stack.SetInt(-1, SysUtils.StrToInt(Stack.GetString(-2))); // strtoint + 2: Stack.SetInt(-1, StrToIntDef(Stack.GetString(-2), Stack.GetInt(-3))); // strtointdef + 3: Stack.SetInt(-1, Pos(Stack.GetString(-2), Stack.GetString(-3)));// pos + 4: Stack.SetString(-1, Copy(Stack.GetString(-2), Stack.GetInt(-3), Stack.GetInt(-4))); // copy + 5: //delete + begin + temp := NewTPSVariantIFC(Stack[Stack.Count -1], True); + 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; + 6: // insert + begin + temp := NewTPSVariantIFC(Stack[Stack.Count -2], True); + if (temp.Dta = nil) or (temp.aType.BaseType <> btString) then + begin + Result := False; + exit; + end; + Insert(Stack.GetString(-1), tbtstring(temp.Dta^), Stack.GetInt(-3)); + 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, 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, RPS_OutOfStringRange); + Result := True; + exit; + end; + tbtstring(temp.Dta^)[i] := chr(Stack.GetInt(-1)); + end; + 10: Stack.SetString(-1, FastUppercase(Stack.GetString(-2))); // Uppercase + 11: Stack.SetString(-1, FastLowercase(Stack.GetString(-2)));// LowerCase + 12: Stack.SetString(-1, Trim(Stack.GetString(-2)));// Trim + 13: Stack.SetInt(-1, Length(Stack.GetString(-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.GetString(-2))); // StrToFloat + 24: Stack.SetString(-1, FloatToStr(Stack.GetReal(-2)));// FloatToStr + 25: Stack.SetString(-1, PadL(Stack.GetString(-2), Stack.GetInt(-3))); // PadL + 26: Stack.SetString(-1, PadR(Stack.GetString(-2), Stack.GetInt(-3))); // PadR + 27: Stack.SetString(-1, PadZ(Stack.GetString(-2), Stack.GetInt(-3)));// PadZ + 28: Stack.SetString(-1, StringOfChar(Char(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^)<> ''; +{$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} + Tmp := Caller.ExObject; + Caller.ExObject := nil; + Caller.ExceptionProc(Caller.ExProc, Caller.ExPos, Caller.ExEx, Caller.ExParam, tmp); + end; + 31: Caller.CMD_Err2(TPSError(Stack.GetInt(-1)), Stack.GetString(-2)); {RaiseExeption} + 32: Stack.SetInt(-1, Ord(Caller.ExEx)); {ExceptionType} + 33: Stack.SetString(-1, Caller.ExParam); {ExceptionParam} + 34: Stack.SetInt(-1, Caller.ExProc); {ExceptionProc} + 35: Stack.SetInt(-1, Caller.ExPos); {ExceptionPos} + 36: Stack.SetString(-1, PSErrorToString(TPSError(Stack.GetInt(-2)), Stack.GetString(-3))); {ExceptionToString} + 37: Stack.SetString(-1, AnsiUpperCase(Stack.GetString(-2))); // AnsiUppercase + 38: Stack.SetString(-1, AnsiLowercase(Stack.GetString(-2)));// AnsiLowerCase +{$IFNDEF PS_NOINT64} + 39: Stack.SetInt64(-1, StrToInt64(Stack.GetString(-2))); // StrToInt64 + 40: Stack.SetString(-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; + 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} + +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', DefProc, Pointer(13), nil); + RegisterFunctionName('SETLENGTH', DefProc, Pointer(14), 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); + + RegisterInterfaceLibraryRuntime(Self); +end; + +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; + + + + +function ToString(p: PChar): string; +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)+4)^); + 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^); + 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(PChar(Src^)); + {$IFNDEF PS_NOINT64} + {$IFDEF DELPHI6UP} btS64: Dest := tbts64(Src^); {$ELSE} bts64: begin Result := False; exit; end; {$ENDIF} + {$ENDIF} + btChar: Dest := string(tbtchar(src^)); + {$IFNDEF PS_NOWIDESTRING} + btWideString: Dest := tbtWideString(src^); + btWideChar: Dest := widestring(tbtwidechar(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)+4)^); + cp := Pointer(Datap^); + if cp = nil then + begin + tvarrec(p^).VType := vtPointer; + tvarrec(p^).VPointer := nil; + end else begin + case ctype.BaseType of + btchar: begin + tvarrec(p^).VType := vtChar; + tvarrec(p^).VChar := 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; + btwideString: begin + tvarrec(p^).VType := vtWideString; + widestring(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; + string(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)+12); + p := PChar(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)+4)^); + 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^) := 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; + btWideString: + begin + if v^.VarParam then + tbtwidestring(cp^) := widestring(TVarRec(p^).VWideString); + finalize(widestring(TVarRec(p^).VWideString)); + end; + {$ENDIF} + btString: begin + if v^.VarParam then + tbtstring(cp^) := tbtstring(TVarRec(p^).VString); + finalize(string(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(string(TVarRec(p^).VAnsiString)); + end; +{$ENDIF} +{$ENDIF} + end; + datap := Pointer(IPointer(datap)+12); + p := Pointer(IPointer(p) + Cardinal(v^.ElementSize)); + end; + FreeMem(v.Data, v.ElementSize * v.ItemCount); + end; + Dispose(V); +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; + + 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: string; + 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 := #0#0#0#0 + 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 := #0#0#0#0 + 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} btWideString, btWideChar, {$ENDIF} btU8, btS8, btU16, + btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, 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 := #0#0#0#0 + Stack; + Pointer((@Stack[1])^) := VarPtr; + end; + end; + end else begin + UseReg := True; + case fVar^.aType.BaseType of + btSet: + begin + tempstr := #0#0#0#0; + 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 := #0#0#0#0 + 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 := #0#0#0#0 + Stack; + Longint((@Stack[1])^) := POpenArray(p)^.ItemCount -1; + end; + end; + Result := True; + exit; + end else begin + {$IFDEF PS_DYNARRAY} + TempStr := #0#0#0#0; + Pointer((@TempStr[1])^) := Pointer(fvar.Dta^); + {$ELSE} + Exit; + {$ENDIF} + end; + end; + btVariant + , btStaticArray, btRecord: + begin + TempStr := #0#0#0#0; + Pointer((@TempStr[1])^) := Pointer(fvar.Dta); + end; + btDouble: {8 bytes} begin + TempStr := #0#0#0#0#0#0#0#0; + UseReg := False; + double((@TempStr[1])^) := double(fvar.dta^); + end; + btCurrency: {8 bytes} begin + TempStr := #0#0#0#0#0#0#0#0; + UseReg := False; + currency((@TempStr[1])^) := currency(fvar.dta^); + end; + btSingle: {4 bytes} begin + TempStr := #0#0#0#0; + UseReg := False; + Single((@TempStr[1])^) := single(fvar.dta^); + end; + + btExtended: {10 bytes} begin + UseReg := False; + TempStr:= #0#0#0#0#0#0#0#0#0#0#0#0; + Extended((@TempStr[1])^) := extended(fvar.dta^); + end; + btChar, + btU8, + btS8: begin + TempStr := char(fVar^.dta^) + #0#0#0; + end; + {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF} + btu16, btS16: begin + TempStr := #0#0#0#0; + Word((@TempStr[1])^) := word(fVar^.dta^); + end; + btu32, bts32: begin + TempStr := #0#0#0#0; + Longint((@TempStr[1])^) := Longint(fVar^.dta^); + end; + btPchar: + begin + TempStr := #0#0#0#0; + if pointer(fvar^.dta^) = nil then + Pointer((@TempStr[1])^) := @EmptyPchar + else + Pointer((@TempStr[1])^) := pointer(fvar^.dta^); + end; + btclass, btinterface, btString: + begin + TempStr := #0#0#0#0; + Pointer((@TempStr[1])^) := pointer(fvar^.dta^); + end; + {$IFNDEF PS_NOWIDESTRING} + btWideString: begin + TempStr := #0#0#0#0; + Pointer((@TempStr[1])^) := pointer(fvar^.dta^); + end; + {$ENDIF} + + btProcPtr: + begin + tempstr := #0#0#0#0#0#0#0#0; + TMethod((@TempStr[1])^) := MKMethod(Self, Longint(FVar.Dta^)); + UseReg := false; + end; + + {$IFNDEF PS_NOINT64}bts64: + begin + TempStr:= #0#0#0#0#0#0#0#0; + 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 Stack := TempStr + Stack; + end; + end else begin + Stack := TempStr + Stack; + end; + end; + Result := True; + end; +begin + 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; + 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, {$ENDIF} + btInterface, btArray, btrecord, btstring, btVariant: 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 : + {$IFNDEF FPC} + tbtu32(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil); + {$ELSE} + //EAX switched with EDX + tbtu32(res.dta^) := RealCall_Register(Address, EDX, EAX, 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: pchar(res.dta^) := Pchar(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(EDX) shl 32 or 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, {$ENDIF} + btArray, btrecord, btstring: RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); + 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, {$ENDIF}btInterface, btArray, btrecord, btstring, btVariant: GetPtr(res); + end; + end; + if assigned(_Self) then begin + Stack := #0#0#0#0 +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^) := Pchar(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 := #0#0#0#0 +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 := #0#0#0#0; + 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^) := Pchar(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}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 := #0#0#0#0 + 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^) := Pchar(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}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; + +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 (Longint(p^[I]) > Longint(p)) and ((Longint(p^[I]) - Longint(p)) + div + 4 < Ret.FEndOfVMT) then + begin + Ret.FEndOfVMT := (Longint(p^[I]) - Longint(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)+4)^); + 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: string; + Tmp: TObject; +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 + 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); + 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 + Caller.Cmd_Err(erCouldNotCallProc) + else if Tmp is Exception then + Caller.CMD_Err3(erCustomError, (tmp as Exception).Message, tmp) + else + Caller.Cmd_Err3(erCustomError, RPS_CouldNotCallProc, tmp); + Result := false; + end; + DisposePPSVariantIFC(v); + DisposePPSVariantIFCList(mylist); +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: string; + FType: PIFTypeRec; + x: TPSRuntimeClass; + Tmp: TObject; + 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; + 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]; +// 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, cc, MyList, v); + 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 + Caller.Cmd_Err(erCouldNotCallProc) + else if Tmp is Exception then + Caller.CMD_Err3(erCustomError, (tmp as Exception).Message, tmp) + else + Caller.Cmd_Err3(erCustomError, RPS_CouldNotCallProc, tmp); + Result := false; + end; + DisposePPSVariantIFC(v); + DisposePPSVariantIFCList(mylist); + DestroyHeapVariant(intval); +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: string; + FType: PIFTypeRec; + x: TPSRuntimeClass; + Tmp: TObject; + 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; + 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); + 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 + Caller.Cmd_Err(erCouldNotCallProc) + else if Tmp is Exception then + Caller.CMD_Err3(erCustomError, (tmp as Exception).Message, tmp) + else + Caller.Cmd_Err3(erCustomError, RPS_CouldNotCallProc, tmp); + Result := false; + end; + DisposePPSVariantIFC(v); + DisposePPSVariantIFCList(mylist); + DestroyHeapVariant(intval); +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, 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, 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; + 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; + 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: string; + Tmp: TObject; +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 + 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(Cardinal(FSelf^) + (Cardinal(p.Ext1) * Sizeof(Pointer)))^), cc, MyList, n2); + result := true; + 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 + Caller.Cmd_Err(erCouldNotCallProc) + else if Tmp is Exception then + Caller.CMD_Err3(erCustomError, (tmp as Exception).Message, tmp) + else + Caller.Cmd_Err3(erCustomError, RPS_CouldNotCallProc, tmp); + Result := false; + end; + DisposePPSVariantIFC(n2); + DisposePPSVariantIFCList(MyList); +end; + + +function InterfaceProc(Sender: TPSExec; p: TPSExternalProcRec; Tag: Pointer): Boolean; +var + s: string; +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): Cardinal; +begin + if (p.Code <> @MyAllMethodsHandler) or (p.Data = nil) 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; + tmp: TObject; + 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; + 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(n.Dta^)); + btPChar: SetStrProp(TObject(FSelf), p.Ext1, pchar(n.Dta^)); + btClass: SetOrdProp(TObject(FSelf), P.Ext1, Longint(n.Dta^)); + {$IFDEF DELPHI6UP} +{$IFNDEF PS_NOWIDESTRING}btWideString: SetWideStrProp(TObject(FSelf), P.Ext1, Widestring(n.dta^)); {$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; + 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); + if Cardinal(n.dta^) = 0 then + begin + Pointer(Pointer((IPointer(n.dta)+4))^) := m.Data; + Pointer(Pointer((IPointer(n.dta)+8))^) := 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: string(n.Dta^) := GetStrProp(TObject(FSelf), p.Ext1); + btClass: Longint(n.dta^) := GetOrdProp(TObject(FSelf), p.Ext1); + {$IFDEF DELPHI6UP} +{$IFNDEF PS_NOWIDESTRING}btWideString: Widestring(n.dta^) := GetWideStrProp(TObject(FSelf), P.Ext1); {$ENDIF} +{$ENDIF} + else + begin + Result := False; + exit; + end; + end; + Result := True; + 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 + Caller.Cmd_Err(erCouldNotCallProc) + else if Tmp is Exception then + Caller.CMD_Err3(erCustomError, (tmp as Exception).Message, tmp) + else + Caller.Cmd_Err3(erCustomError, RPS_CouldNotCallProc, tmp); + Result := False; + end; +end; + +function ClassCallProcPropertyHelper(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +var + I, ParamCount: Longint; + Params: TPSList; + n: TPSVariantIFC; + FSelf: Pointer; + Tmp: TObject; +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; + 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); + 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 + Caller.Cmd_Err(erCouldNotCallProc) + else if Tmp is Exception then + Caller.CMD_Err3(erCustomError, (tmp as Exception).Message, tmp) + else + Caller.Cmd_Err3(erCustomError, RPS_CouldNotCallProc, tmp); + Result := false; + end; + DisposePPSVariantIFCList(Params); + end else begin + n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 1], False); + if (n.Dta = nil) or (n.aType.BaseType <> btClass) then + begin + result := false; + 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); + 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 + Caller.Cmd_Err(erCouldNotCallProc) + else if Tmp is Exception then + Caller.CMD_Err3(erCustomError, (tmp as Exception).Message, tmp) + else + Caller.Cmd_Err3(erCustomError, RPS_CouldNotCallProc, tmp); + Result := false; + end; + DisposePPSVariantIFCList(Params); + end; +end; + +function ClassCallProcPropertyHelperName(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +var + I, ParamCount: Longint; + Params: TPSList; + tt: PIFVariant; + n: TPSVariantIFC; + FSelf: Pointer; + Tmp: TObject; +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; + 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); + 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 + Caller.Cmd_Err(erCouldNotCallProc) + else if Tmp is Exception then + Caller.CMD_Err3(erCustomError, (tmp as Exception).Message, tmp) + else + Caller.Cmd_Err3(erCustomError, RPS_CouldNotCallProc, tmp); + Result := false; + end; + DestroyHeapVariant(tt); + DisposePPSVariantIFCList(Params); + end else begin + n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 1], false); + if (n.Dta = nil) or (n.aType.BaseType <> btClass) then + begin + result := false; + 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); + 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 + Caller.Cmd_Err(erCouldNotCallProc) + else if Tmp is Exception then + Caller.CMD_Err3(erCustomError, (tmp as Exception).Message, tmp) + else + Caller.Cmd_Err3(erCustomError, RPS_CouldNotCallProc, tmp); + Result := false; + end; + DestroyHeapVariant(tt); + DisposePPSVariantIFCList(Params); + end; +end; + + + +function ClassCallProcEventPropertyHelper(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +{Event property helper} +var + I, ParamCount: Longint; + Params: TPSList; + n: TPSVariantIFC; + n2: PIFVariant; + FSelf: Pointer; + Tmp: TObject; +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; + 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; + exit; + end; + n2 := CreateHeapVariant(Caller.FindType2(btDouble)); + if n2 = nil then + begin + Result := False; + exit; + end; + TMethod(PPSVariantDouble(n2).Data).Code := nil; + TMethod(PPSVariantDouble(n2).Data).Data := nil; + Params := TPSList.Create; + Params.Add(NewPPSVariantIFC(n2, True)); + 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); + 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 + Caller.Cmd_Err(erCouldNotCallProc) + else if Tmp is Exception then + Caller.CMD_Err3(erCustomError, (tmp as Exception).Message, tmp) + else + Caller.Cmd_Err3(erCustomError, RPS_CouldNotCallProc, tmp); + Result := false; + end; + Cardinal(n.Dta^) := getMethodNo(TMethod(PPSVariantDouble(n2).Data)); + if Cardinal(n.Dta^) = 0 then + begin + Pointer(Pointer((IPointer(n.dta)+4))^) := TMethod(PPSVariantDouble(n2).Data).Data; + Pointer(Pointer((IPointer(n.dta)+8))^) := TMethod(PPSVariantDouble(n2).Data).Code; + end; + DestroyHeapVariant(n2); + DisposePPSVariantIFCList(Params); + end else begin + n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 1], false); + if (n.Dta = nil) or (n.aType.BaseType <> btClass) then + begin + result := false; + 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; + exit; + end; + n2 := CreateHeapVariant(Caller.FindType2(btDouble)); + if n2 = nil then + begin + Result := False; + exit; + end; + TMethod(PPSVariantDouble(n2).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); + 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 + Caller.Cmd_Err(erCouldNotCallProc) + else if Tmp is Exception then + Caller.CMD_Err3(erCustomError, (tmp as Exception).Message, tmp) + else + Caller.Cmd_Err3(erCustomError, RPS_CouldNotCallProc, tmp); + Result := false; + end; + DestroyHeapVariant(n2); + DisposePPSVariantIFCList(Params); + 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: string; + 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('|', 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('|', 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, 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: string); +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: string): 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: string); +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: string; + CurrStack, i: Longint; + n: PPSVariant; + MyList: TPSList; +begin + s := TPSTypeRec_ProcPtr(at).ParamInfo; + Delete(s, 1, 1); + CurrStack := Cardinal(FStack.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 := 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; + +{ TPSRuntimeClass } + +constructor TPSRuntimeClass.Create(aClass: TClass; const AName: string); +begin + inherited Create; + FClass := AClass; + if AName = '' then + begin + FClassName := FastUpperCase(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: string); +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: string); +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: string); +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: string); +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: string); +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: string); +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: string); +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: string); +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(FastUppercase(aClass.ClassName)); + if Result <> nil then exit; + Result := TPSRuntimeClass.Create(aClass, ''); + FClasses.Add(Result); +end; + +function TPSRuntimeClassImporter.Add2(aClass: TClass; + const Name: string): 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: string): string; +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; + + + +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, +{$IFNDEF PS_NOINT64} + bts64, +{$ENDIF} + btPChar, +{$IFNDEF PS_NOWIDESTRING} + btWideChar, +{$ENDIF} + btChar, + btclass, + btEnum: Result := true; + btSet: Result := b.RealSize <= 4; + btStaticArray: Result := b.RealSize <= 4; + else + Result := false; + end; +end; + +function SupportsRegister(b: TPSTypeRec): Boolean; +begin + case b.BaseType of + btU8, + bts8, + bts16, + btu16, + bts32, + btu32, +{$IFNDEF PS_NOINT64} + bts64, +{$ENDIF} + btstring, + btclass, +{$IFNDEF PS_NOINTERFACES} + btinterface, +{$ENDIF} + btPChar, +{$IFNDEF PS_NOWIDESTRING} + btwidestring, + btWideChar, +{$ENDIF} + btChar, + btArray, + btEnum: Result := true; + btSet: Result := b.RealSize <= 4; + btStaticArray: Result := b.RealSize <= 4; + else + Result := false; + end; +end; + +function AlwaysAsVariable(aType: TPSTypeRec): Boolean; +begin + case atype.BaseType of + btVariant: Result := true; + btSet: Result := atype.RealSize > 4; + btRecord: Result := atype.RealSize > 4; + btStaticArray: Result := atype.RealSize > 4; + else + Result := false; + end; +end; + + +procedure PutOnFPUStackExtended(ft: extended); +asm + fstp tbyte ptr [ft] +end; + + +function MyAllMethodsHandler2(Self: PScriptMethodInfo; const Stack: PPointer; _EDX, _ECX: Pointer): Integer; +var + Decl: string; + I, C, regno: Integer; + Params: TPSList; + Res, Tmp: PIFVariant; + cpt: PIFTypeRec; + fmod: char; + s,e: string; + FStack: pointer; + ex: PPSExceptionHandler; + + +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; + 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) + 4); + Inc(Result, 4); + 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; + 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^); +(*{$IFNDEF PS_NOINT64} + FStack := Pointer(IPointer(FStack) + 4); +{$ENDIF}*) + Inc(Result, 4); + end; + end; + end else + begin + Res := CreateHeapVariant(cpt); + Params.Add(Res); + end; + end else Res := nil; + New(ex); + 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); + Dispose(ex); + 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)-8), @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; + +function TPSRuntimeClassImporter.FindClass(const Name: string): TPSRuntimeClass; +var + h, i: Longint; + p: TPSRuntimeClass; +begin + h := MakeHash(Name); + for i := FClasses.Count -1 downto 0 do + begin + p := FClasses[i]; + if (p.FClassNameHash = h) and (p.FClassName = Name) 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: string; +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; + +procedure TPSExec.RegisterDelphiFunction(ProcPtr: Pointer; + const Name: string; CC: TPSCallingConvention); +begin + RegisterDelphiMethod(nil, ProcPtr, FastUppercase(Name), CC); +end; + +procedure TPSExec.RegisterDelphiMethod(Slf, ProcPtr: Pointer; + const Name: string; 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); + cdCdecl: RegisterFunctionName(FastUppercase(Name), DelphiFunctionProc_CDECL, ProcPtr, Slf); + end; +end; + +{ EPSException } + +constructor EPSException.Create(const Error: string; Exec: TPSExec; + Procno, ProcPos: Cardinal); +begin + inherited Create(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: string): TPSRuntimeAttribute; +var + n: string; + 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 := 4; +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)+4), 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)+4), 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.GetString(ItemNo: Longint): string; +var + val: PPSVariant; +begin + if ItemNo < 0 then + val := items[Longint(ItemNo) + Longint(Count)] + else + val := items[ItemNo]; + Result := PSGetString(@PPSVariantData(val).Data, val.FType); +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; + +{$IFNDEF PS_NOWIDESTRING} +function TPSStack.GetWideString(ItemNo: Longint): WideString; +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)+4), 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) and not 3; + 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 + o := FLength; + FLength := (FLength + Longint(aType.RealSize) + Longint(RTTISize + 3)) and not 3; + if FLength > FCapacity then AdjustLength; + p := Pointer(IPointer(FDataPtr) + IPointer(o)); + Add(p); + Result := P; + Result.FType := aType; + InitializeVariant(Pointer(IPointer(Result)+4), 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 + Data[i] := Pointer(IPointer(Data[i]) + OOFS); + + 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.SetString(ItemNo: Longint; const Data: string); +var + val: PPSVariant; + ok: Boolean; +begin + if ItemNo < 0 then + val := items[Longint(ItemNo) + Longint(Count)] + else + val := items[ItemNo]; + ok := true; + PSSetString(@PPSVariantData(val).Data, val.FType, ok, Data); + if not ok then raise Exception.Create(RPS_TypeMismatch); +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.SetWideString(ItemNo: Longint; + const Data: WideString); +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: String; 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(Par[High(Par)-i]); + WSFreeList.Add(DispParam.rgvarg[i].bstrVal); + 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(OleVariant)); + + 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 := 12; +end; + +end. + diff --git a/Source/uPSUtils.pas b/Source/uPSUtils.pas new file mode 100644 index 0000000..596474b --- /dev/null +++ b/Source/uPSUtils.pas @@ -0,0 +1,1540 @@ +unit uPSUtils; +{$I PascalScript.inc} + +interface +uses + Classes, SysUtils; +const + + PSMainProcName = '!MAIN'; + + PSMainProcNameOrg = 'Main Proc'; + + PSLowBuildSupport = 12; + + PSCurrentBuildNo = 22; + + PSCurrentversion = '1.30'; + + PSValidHeader = 1397769801; + + PSAddrStackStart = 1610612736; + + PSAddrNegativeStackStart = 1073741824; +type + + 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; + + btType = 130; + + btEnum = 129; + + btExtClass = 131; + + + +function MakeHash(const s: string): Longint; + +const +{ Script internal command: Assign command
+ Command: TPSCommand;
+ VarDest, // no data
+ VarSrc: TPSVariable;
+} + CM_A = 0; +{ Script internal command: Calculate Command
+ Command: TPSCommand;
+ CalcType: Byte;
+
+ 0 = +
+ 1 = -
+ 2 = *
+ 3 = /
+ 4 = MOD
+ 5 = SHL
+ 6 = SHR
+ 7 = AND
+ 8 = OR
+ 9 = XOR
+
+ VarDest, // no data
+ VarSrc: TPSVariable;
+
+} + CM_CA = 1; +{ Script internal command: Push
+ Command: TPSCommand;
+ Var: TPSVariable;
+} + CM_P = 2; +{ Script internal command: Push Var
+ Command: TPSCommand;
+ Var: TPSVariable;
+} + CM_PV = 3; +{ Script internal command: Pop
+ Command: TPSCommand;
+} + CM_PO = 4; +{ Script internal command: Call
+ Command: TPSCommand;
+ ProcNo: Longword;
+} + Cm_C = 5; +{ Script internal command: Goto
+ Command: TPSCommand;
+ NewPosition: Longint; //relative to end of this instruction
+} + Cm_G = 6; +{ Script internal command: Conditional Goto
+ Command: TPSCommand;
+ NewPosition: LongWord; //relative to end of this instruction
+ Var: TPSVariable; // no data
+} + Cm_CG = 7; +{ Script internal command: Conditional NOT Goto
+ Command: TPSCommand;
+ NewPosition: LongWord; // relative to end of this instruction
+ Var: TPSVariable; // no data
+} + Cm_CNG = 8; +{ Script internal command: Ret
+ Command: TPSCommand;
+} + Cm_R = 9; +{ Script internal command: Set Stack Type
+ Command: TPSCommand;
+ NewType: LongWord;
+ OffsetFromBase: LongWord;
+} + Cm_ST = 10; +{ Script internal command: Push Type
+ Command: TPSCommand;
+ FType: LongWord;
+} + Cm_Pt = 11; +{ Script internal command: Compare
+ Command: TPSCommand;
+ CompareType: Byte;
+
+ 0 = >=
+ 1 = <=
+ 2 = >
+ 3 = <
+ 4 = <>
+ 5 = =
+
+ IntoVar: TPSAssignment;
+ Compare1, Compare2: TPSAssigment;
+} + CM_CO = 12; +{ Script internal command: Call Var
+ Command: TPSCommand;
+ Var: TPSVariable;
+} + Cm_cv = 13; +{ Script internal command: Set Pointer
+ Command: TPSCommand;
+ VarDest: TPSVariable;
+ VarSrc: TPSVariable;
+} + cm_sp = 14; +{ Script internal command: Boolean NOT
+ Command: TPSCommand;
+ Var: TPSVariable;
+} + cm_bn = 15; +{ Script internal command: Var Minus
+ Command: TPSCommand;
+ Var: TPSVariable; +} + cm_vm = 16; +{ Script internal command: Set Flag
+ Command: TPSCommand;
+ Var: TPSVariable;
+ DoNot: Boolean;
+} + cm_sf = 17; +{ Script internal command: Flag Goto
+ Command: TPSCommand;
+ Where: Cardinal;
+} + cm_fg = 18; +{ Script internal command: Push Exception Handler
+ Command: TPSCommand;
+ FinallyOffset,
+ ExceptionOffset, // FinallyOffset or ExceptionOffset need to be set.
+ Finally2Offset,
+ EndOfBlock: Cardinal;
+} + cm_puexh = 19; +{ Script internal command: Pop Exception Handler
+ Command:TPSCommand;
+ Position: Byte;
+ 0 = end of try/finally/exception block;
+ 1 = end of first finally
+ 2 = end of except
+ 3 = end of second finally
+
+} + cm_poexh = 20; +{ Script internal command: Integer NOT
+ Command: TPSCommand;
+ Where: Cardinal;
+} + cm_in = 21; + {Script internal command: Set Stack Pointer To Copy
+ Command: TPSCommand;
+ Where: Cardinal;
+} + cm_spc = 22; + {Script internal command: Inc
+ Command: TPSCommand;
+ Var: TPSVariable;
+ } + cm_inc = 23; + {Script internal command: Dec
+ Command: TPSCommand;
+ Var: TPSVariable;
+ } + cm_dec = 24; + {Script internal command: nop
+ Command: TPSCommand;
} + cm_nop = 255; +{ Script internal command: Pop and Goto
+ Command: TPSCommand;
+ NewPosition: Longint; //relative to end of this instruction
+} + Cm_PG = 25; +{ Script internal command: Pop*2 and Goto
+ Command: TPSCommand;
+ NewPosition: Longint; //relative to end of this instruction
+} + Cm_P2G = 26; + + +type + + TbtU8 = Byte; + + TbtS8 = ShortInt; + + TbtU16 = Word; + + TbtS16 = SmallInt; + + TbtU32 = Cardinal; + + TbtS32 = Longint; + + TbtSingle = Single; + + TbtDouble = double; + + TbtExtended = Extended; + + tbtCurrency = Currency; + + TbtString = string; +{$IFNDEF PS_NOINT64} + + tbts64 = int64; +{$ENDIF} + + tbtchar = char; +{$IFNDEF PS_NOWIDESTRING} + + tbtwidestring = widestring; + + tbtwidechar = widechar; +{$ENDIF} + IPointer = Cardinal; + TPSCallingConvention = (cdRegister, cdPascal, cdCdecl, cdStdCall, cdSafecall); + +const + + 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): string; + procedure SetItem(Nr: LongInt; const s: string); + public + + function Count: LongInt; + + property Items[Nr: Longint]: string read GetItem write SetItem; default; + + + procedure Add(const P: string); + + 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_out, + CSTII_nil + ); + + TPSParserErrorKind = (iNoError + , iCommentError + , iStringError + , iCharError + , iSyntaxError + ); + TPSParserErrorEvent = procedure (Parser: TObject; Kind: TPSParserErrorKind) of object; + + + TPSPascalParser = class(TObject) + protected + FData: string; + FText: PChar; + FLastEnterPos, FRow, FRealPosition, FTokenLength: Cardinal; + FTokenId: TPSPasToken; + FToken: string; + FOriginalToken: string; + 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: string read FToken; + + property OriginalToken: string 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: string); virtual; + + property OnParserError: TPSParserErrorEvent read FParserError write FParserError; + end; + +function FloatToStr(E: Extended): string; + +function FastLowerCase(const s: String): string; + +function Fw(const S: string): string; + +function IntToStr(I: LongInt): string; + +function StrToIntDef(const S: string; Def: LongInt): LongInt; + +function StrToInt(const S: string): LongInt; +function StrToFloat(const s: string): Extended; + +function FastUpperCase(const s: String): string; + +function GRFW(var s: string): string; +function GRLW(var s: string): string; + +const + + FCapacityInc = 32; +{$IFNDEF PS_NOSMARTLIST} + + FMaxCheckCount = (FCapacityInc div 4) * 64; +{$ENDIF} + + +implementation + + +{$IFDEF DELPHI3UP } +resourceString +{$ELSE } +const +{$ENDIF } + RPS_InvalidFloat = 'Invalid float'; + +function MakeHash(const s: string): 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: string): string; +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: string): string; +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: string): Extended; +var + i: longint; +begin + Val(s, Result, i); + if i <> 0 then raise Exception.Create(RPS_InvalidFloat); +end; +//------------------------------------------------------------------- + +function IntToStr(I: LongInt): string; +var + s: string; +begin + Str(i, s); + IntToStr := s; +end; +//------------------------------------------------------------------- + +function FloatToStr(E: Extended): string; +var + s: string; +begin + Str(e:0:12, s); + result := s; +end; + +function StrToInt(const S: string): LongInt; +var + e: Integer; + Res: LongInt; +begin + Val(S, Res, e); + if e <> 0 then + StrToInt := -1 + else + StrToInt := Res; +end; +//------------------------------------------------------------------- + +function StrToIntDef(const S: string; Def: LongInt): LongInt; +var + e: Integer; + Res: LongInt; +begin + Val(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, 64); +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 * 4); + for I := 0 to Longint(FCount) -1 do + begin + NewData^[i] := FData^[I]; + end; + FreeMem(FData, FCapacity * 4); + 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 shl 2); + 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 shl 2); + 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) * 4); + 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 * 4); + 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 = ^string; + +//------------------------------------------------------------------- + +function TPSStringList.GetItem(Nr: LongInt): string; +var + S: PStr; +begin + s := List.GetItem(Nr); + if s = nil then + Result := '' + else + + Result := s^; +end; +//------------------------------------------------------------------- + + +procedure TPSStringList.SetItem(Nr: LongInt; const s: string); +var + p: PStr; +begin + p := List.GetItem(Nr); + if p = nil + then + Exit; + p^ := s; +end; +//------------------------------------------------------------------- + +procedure TPSStringList.Add(const P: string); +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: string): string; // First word +var + x: integer; +begin + x := pos(' ', s); + if x > 0 + then Fw := Copy(S, 1, x - 1) + else Fw := S; +end; +//------------------------------------------------------------------- +function FastUpperCase(const s: String): string; +{Fast uppercase} +var + I: Integer; + C: Char; +begin + Result := S; + I := Length(Result); + while I > 0 do + begin + C := Result[I]; + if c in [#97..#122] then + Dec(Byte(Result[I]), 32); + Dec(I); + end; +end; +function FastLowerCase(const s: String): string; +{Fast lowercase} +var + I: Integer; + C: Char; +begin + Result := S; + I := Length(Result); + while I > 0 do + begin + C := Result[I]; + if C in [#65..#90] then + Inc(Byte(Result[I]), 32); + Dec(I); + end; +end; +//------------------------------------------------------------------- + +type + TRTab = record + name: string; + c: TPSPasToken; + end; + + +const + KEYWORD_COUNT = 63; + 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: '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: '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: string; + function CheckReserved(Const S: ShortString; var CurrTokenId: TPSPasToken): Boolean; + var + L, H, I: LongInt; + J: Char; + 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): string; + var + s: string; + begin + SetLength(s, CurrTokenLen); + Move(FText[CurrTokenPos], S[1], CurrtokenLen); + GetToken := s; + end; + + function ParseToken(var CurrTokenPos, CurrTokenLen: Cardinal; var CurrTokenId: TPSPasToken): TPSParserErrorKind; + {Parse the token} + var + ct, ci: Cardinal; + hs: Boolean; + p: PChar; + 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 := pchar(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 + FTokenLength; + Err := ParseToken(FRealPosition, 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: string); +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/Source/uROPSImports.pas b/Source/uROPSImports.pas new file mode 100644 index 0000000..da70685 --- /dev/null +++ b/Source/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/Source/uROPSServerLink.pas b/Source/uROPSServerLink.pas new file mode 100644 index 0000000..a246a6f --- /dev/null +++ b/Source/uROPSServerLink.pas @@ -0,0 +1,1139 @@ +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; + protected + procedure CompileImport1(CompExec: TPSScript); override; + procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override; + 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; + + +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])); + Char(aMode) := s[length(s2)+2]; + Char(aType) := 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])); + Char(aMode) := s[length(s2)+2]; + Char(aType) := 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: string; 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: string; 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('!', 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: string; 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: string; + 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'); + SIRegisterTROTRANSPORTCHANNEL(CompExec.Comp); + SIRegisterTROMESSAGE(CompExec.Comp); + 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); + 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.AddType(Arr.Info.Name, btArray); + 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); + 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/dunit/CompileTestExtended.pas b/dunit/CompileTestExtended.pas new file mode 100644 index 0000000..7c857ec --- /dev/null +++ b/dunit/CompileTestExtended.pas @@ -0,0 +1,147 @@ +unit CompileTestExtended; + +interface + +uses Classes, + TestFramework, + { Project Units } + SysUtils, + ifps3, + ifps3utl, + ifpscomp, + IFPS3CompExec, + CompilerTestBase; + +type + TCompilerTestExtended = class(TCompilerTestBase) + private + protected + LastResult: string; + LastResultB: Boolean; + LastResultI: Longint; + LastResultD: Double; + procedure OnCompImport(Sender: TObject; x: TIFPSPascalCompiler); override; + procedure ResultD(const d: Double); + procedure ResultS(const s: string); + procedure ResultB(const val: Boolean); + procedure ResultI(const val: Longint); + published + procedure VariantTest1; + procedure VariantTest2; + procedure ArrayTest1; + procedure CompileDouble; + procedure ArrayRefCounting; + procedure ArrayTest; + procedure FormatTest; + procedure ExtCharTest; + procedure StrList; + end; + +implementation + + +{ TCompilerTestExtended } + +procedure TCompilerTestExtended.ArrayRefCounting; +begin + CompileRun('var e, d: array of string; begin SetArrayLength(d, 1); d[0] := ''123''; e := d;'+ + 'setarraylength(d, 0); e[0] := ''321''; d := e;setarraylength(e, 0); d[0] := ''321'';end.'); +end; + +procedure TCompilerTestExtended.ArrayTest; +begin + CompileRun('var d,e: array of string; begin SetArrayLength(d, 1); d[0] := ''123''; e := d; setarraylength(e, 0); ResultS(d[0]); end.'); + CheckEquals(LastResult, '123'); +end; + +procedure TCompilerTestExtended.ArrayTest1; +begin + CompileRun('type Tstrarr = array of string; var r: TStrArr; i: Longint; Begin'+ + ' setarraylength(r, 3); r[0] := ''asdf''; r[1] := ''safasf''; ResultS(r[0]+''!''+r[1]); end.'); + CheckEquals('asdf!safasf', LastResult); +end; + +procedure TCompilerTestExtended.CompileDouble; +var + d: double; +begin + CompileRun('var x: Double; begin x := 1234.54656456; ResultS(Format(''%15.0f'',[2*x]));end.'); + d := 1234.54656456; + CheckEquals(LastResult, Format('%15.0f',[2*d])); +end; + +procedure TCompilerTestExtended.ExtCharTest; +var + d: double; +begin + CompileRun('var s:string; i:integer; Res: Double; function Test(i1, i2: Integer): Double; begin Result := Double(i1) / i2; end; '+ + 'begin i := ord(''a'');s:=chr(i); i := ord(''a''); s:= chr(i + 1); s := s + chr(i); res := Test(10, 2); ResultS(''Test 1: ''+s+''|Test 2:''+FloatToStr(res));end.'); + d := 10; + d := d / 2; + CheckEquals('Test 1: ba|Test 2:'+ifps3utl.FloatToStr(d), LastResult); +end; + +procedure TCompilerTestExtended.FormatTest; +begin + CompileRun('var s: string; begin s := ''TeSTDaTa''; ResultS(''Test: ''+format(''test %s %f'', [s, 2 * PI])); end.'); + CheckEquals('Test: test TeSTDaTa '+SysUtils.Format('%f', [2*pi]), LastResult); + +end; + +procedure TCompilerTestExtended.OnCompImport(Sender: TObject; + x: TIFPSPascalCompiler); +begin + inherited; + CompExec.AddMethod(Self, @TCompilerTestExtended.ResultS, 'procedure ResultS(const s: string);'); + CompExec.AddMethod(Self, @TCompilerTestExtended.ResultB, 'procedure ResultB(const b: Boolean);'); + CompExec.AddMethod(Self, @TCompilerTestExtended.ResultI, 'procedure ResultI(const I: Longint);'); + CompExec.AddMethod(Self, @TCompilerTestExtended.ResultD, 'procedure ResultD(const D: Double);'); +end; + +procedure TCompilerTestExtended.ResultB(const val: Boolean); +begin + LastResultB := Val; +end; + +procedure TCompilerTestExtended.ResultD(const d: Double); +begin + LastResultD := d; +end; + +procedure TCompilerTestExtended.ResultI(const val: Integer); +begin + LastResultI := Val; +end; + +procedure TCompilerTestExtended.ResultS(const s: string); +begin + LastResult := s; +end; + +procedure TCompilerTestExtended.StrList; +begin + CompileRun('var r: TStringList; begin r := TStringList.Create; try r.Values[''test''] := ''data'';'+ + 'ResultS(''Test1: ''+r.Values[''test1'']+#13#10+''Test2: ''+r.Values[''test'']); finally r.Free; end;end.'); + + CheckEquals('Test1: '#13#10'Test2: data', Lastresult); +end; + +procedure TCompilerTestExtended.VariantTest1; +begin + CompileRun('var v: variant; Begin v := ''Hey:''; v := v + FloatToStr(Pi); ResultS(v);end.'); + CheckEquals('Hey:'+ifps3utl.FloatToStr(Pi), LastResult); +end; + +procedure TCompilerTestExtended.VariantTest2; +begin + CompileRun('var v: variant; s: string;Begin v := 123; s := v; v := s + ''_test_'';'+ +' s := v; v := 123.456; s := s + v; v := ''test'' + s; ResultS(v);end.'); + CheckEquals('test123_test_'+Sysutils.FloatToStr(123.456), LastResult); +end; + +initialization + RegisterTests('Extended Compiler Tests', + [ TCompilerTestExtended.Suite + ]); + +end. diff --git a/dunit/CompilerTestBase.pas b/dunit/CompilerTestBase.pas new file mode 100644 index 0000000..2842db3 --- /dev/null +++ b/dunit/CompilerTestBase.pas @@ -0,0 +1,137 @@ + +unit CompilerTestBase; + +interface + +uses Classes, + TestFramework, + { Project Units } + ifps3, + ifpscomp, + IFPS3CompExec; + +type + TCompilerTestBase = class(TTestCase) + protected + procedure SetUp; override; + procedure TearDown; override; + protected + last_script : string; + CompExec: TIFPS3CompExec; + //Compiler: TIFPSPascalCompiler; + //Exec: TIFPSExec; + procedure Compile(script: string); + procedure CompileRun(Script: string); + + procedure OnCompile(Sender: TIFPS3CompExec); virtual; + procedure OnExecute(Sender: TIFPS3CompExec); virtual; + procedure OnCompImport(Sender: TObject; x: TIFPSPascalCompiler); virtual; + procedure OnExecImport(Sender: TObject; se: TIFPSExec; x: TIFPSRuntimeClassImporter); virtual; + end; + +implementation + +uses StrUtils, SysUtils, Math, + Dialogs, + { Project Units } + ifpiir_std, + ifpii_std, + ifpiir_stdctrls, + ifpii_stdctrls, + ifpiir_forms, + ifpii_forms, + ifpii_graphics, + ifpii_controls, + ifpii_classes, + ifpiir_graphics, + ifpiir_controls, + ifpiir_classes; + +function MyFormat(const Format: string; + const Args: array of const): string; +begin + Result := SysUtils.Format(Format, Args); +end; + + +{ TCompilerTestBase } + +procedure TCompilerTestBase.SetUp; +begin + inherited; + CompExec := TIFPS3CompExec.Create(nil); + CompExec.OnCompile := OnCompile; + CompExec.OnExecute := OnExecute; + CompExec.OnCompImport := OnCompImport; + CompExec.OnExecImport := OnExecImport; +end; + +procedure TCompilerTestBase.TearDown; +begin + CompExec.Free; + //Compiler.Free; + //Exec.Free; + inherited; +end; + +procedure TCompilerTestBase.CompileRun(Script: string); +var + ok: boolean; +begin + last_script := Script; + + Compile(script); + + ok := CompExec.Execute; + + Check(ok, 'Exec Error:' + Script + #13#10 + + CompExec.ExecErrorToString + ' at ' + + Inttostr(CompExec.ExecErrorProcNo) + '.' + + Inttostr(CompExec.ExecErrorByteCodePosition)); +end; + +procedure TCompilerTestBase.OnCompile(Sender: TIFPS3CompExec); +begin + Sender.AddFunction(@MyFormat, 'function Format(const Format: string; const Args: array of const): string;'); +end; + +procedure TCompilerTestBase.OnCompImport(Sender: TObject; x: TIFPSPascalCompiler); +begin + SIRegister_Std(x); + SIRegister_Classes(x, true); +end; + +procedure TCompilerTestBase.OnExecImport(Sender: TObject; se: TIFPSExec; x: TIFPSRuntimeClassImporter); +begin + RIRegister_Std(x); + RIRegister_Classes(x, True); +end; + +procedure TCompilerTestBase.OnExecute(Sender: TIFPS3CompExec); +begin + //Sender.SetVarToInstance('SELF', Self); +end; + +procedure TCompilerTestBase.Compile(script: string); +var + OutputMessages: string; + ok: Boolean; + i: Longint; +begin + + CompExec.Script.Clear; + CompExec.Script.Add(Script); + + OutputMessages := ''; + ok := CompExec.Compile; + if (NOT ok) then + begin + //Get Compiler Messages now. + for i := 0 to CompExec.CompilerMessageCount - 1 do + OutputMessages := OutputMessages + CompExec.CompilerErrorToStr(i); + end; + Check(ok, 'Compiling failed:' + Script + #13#10 + OutputMessages); + +end; + +end. \ No newline at end of file diff --git a/dunit/CompilerTestFunctions.pas b/dunit/CompilerTestFunctions.pas new file mode 100644 index 0000000..a041ab3 --- /dev/null +++ b/dunit/CompilerTestFunctions.pas @@ -0,0 +1,203 @@ + +unit CompilerTestFunctions; + +interface + +uses Classes, + TestFramework, + { Project Units } + ifps3, + ifpscomp, + ifps3utl, + IFPS3CompExec, + CompilerTestBase; + +type + + TCompilerTestFunctions = class(TCompilerTestBase) + private + function MethodTest(const s: string): string; + procedure AssertS(s1, s2: string); + procedure AssertI(s1, s2: Longint); + procedure AssertE(s1, s2: extended); + protected + procedure OnCompile(Sender: TIFPS3CompExec); override; + procedure OnExecute(Sender: TIFPS3CompExec); override; + published + procedure CallProcedure; + procedure CallMethod; + procedure CallScriptFunctionAsMethod; + procedure WideStringFunctions; + procedure CheckConsts; + end; + + { + TVariablesTest = class(TCompilerTest) + private + published + end; } + +implementation + +uses StrUtils, SysUtils, Math, Dialogs, + { Project Units } + ifpiir_std, + ifpii_std, + ifpiir_stdctrls, + ifpii_stdctrls, + ifpiir_forms, + ifpii_forms, + ifpii_graphics, + ifpii_controls, + ifpii_classes, + ifpiir_graphics, + ifpiir_controls, + ifpiir_classes; + + +{ TFunctionsTest } + +var + vResultS: string; + vResultSw: WideString; + aWideString: WideString; + +procedure ResultS(const s: string); +begin + vResultS := s; +end; + +procedure ResultSw(const s: WideString); +begin + vResultSw := s; +end; + +function getWideString(): WideString; +begin + Result := aWideString; +end; + + +function MyWide2String(s: WideString): String; +begin + Result := s + '+Wide2String'; +end; + +function MyString2Wide(s: String): WideString; +begin + Result := s + '+String2Wide'; +end; + +function MyWide2Wide(s: WideString): WideString; +begin + Result := s + '+Wide2Wide'; +end; + +procedure TCompilerTestFunctions.OnCompile(Sender: TIFPS3CompExec); +begin + inherited; + Sender.AddMethod(Self, @TCompilerTestFunctions.AssertS, 'procedure AssertS(s1, s2: string);'); + Sender.AddMethod(Self, @TCompilerTestFunctions.AssertI, 'procedure AssertI(s1, s2: Longint);'); + Sender.AddMethod(Self, @TCompilerTestFunctions.AssertE, 'procedure AssertE(s1, s2: Extended);'); + + + Sender.AddFunction(@ResultS, 'procedure ResultS(s: string);'); + Sender.AddFunction(@ResultSw, 'procedure ResultSw(s: WideString);'); + Sender.AddFunction(@MyString2Wide, 'function MyString2Wide(s: String): Widestring;'); + Sender.AddFunction(@MyWide2String, 'function MyWide2String(s: Widestring): string;'); + Sender.AddFunction(@MyWide2Wide, 'function MyWide2Wide(s: Widestring): Widestring;'); + Sender.AddFunction(@getWideString, 'function getWideString(): Widestring;'); + Sender.AddMethod(Self, @TCompilerTestFunctions.MethodTest, 'function MethodTest(s: string): string'); + //Sender.AddRegisteredVariable('aWideString', 'WideString'); +end; + +procedure TCompilerTestFunctions.OnExecute(Sender: TIFPS3CompExec); +begin + inherited; + //Sender.SetVarToInstance('aWideString', aWideString); +end; + +procedure TCompilerTestFunctions.CallProcedure; +begin + CompileRun('begin ResultS(''hello''); end.'); + CheckEquals('hello', vResultS, last_script); +end; + + +procedure TCompilerTestFunctions.WideStringFunctions; +begin + CompileRun('begin ResultS(MyString2Wide(''hello'')); end.'); + CheckEquals('hello+String2Wide', vResultS, last_script); + + CompileRun('begin ResultS(MyWide2String(''hello'')); end.'); + CheckEquals('hello+Wide2String', vResultS, last_script); + + CompileRun('begin ResultS(MyWide2Wide(''hello'')); end.'); + CheckEquals('hello+Wide2Wide', vResultS, last_script); + + aWideString := 'Unicode=[' + WideChar($1F04) + WideChar($4004) + ']'; + CompileRun('begin ResultSw(getWideString()); end.'); + CheckEquals(aWideString, vResultSw, last_script); +end; + +function TCompilerTestFunctions.MethodTest(const s: string): string; +begin + Result := 'Test+'+s; +end; + +procedure TCompilerTestFunctions.CallMethod; +begin + CompileRun('begin ResultS(MethodTest(''hello'')); end.'); + CheckEquals('Test+hello', vResultS, last_script); +end; + +type + TTestMethod = function (s: string): string of object; + +procedure TCompilerTestFunctions.CallScriptFunctionAsMethod; +var + Meth: TTestMethod; +begin + Compile('function Test(s:string): string; begin Result := ''Test Results: ''+s;end; begin end.'); + Meth := TTestMethod(CompExec.GetProcMethod('Test')); + Check(@Meth <> nil, 'Unable to find function'); + CheckEquals('Test Results: INDATA', Meth('INDATA')); +end; + + +procedure TCompilerTestFunctions.CheckConsts; +begin + CompileRun('const s1 = ''test''; s2 = ''data: ''+s1; s3 = s2 + ''324''; i1 = 123; i2 = i1+123; '#13#10+ + 'i3 = 123 + i2; r1 = 123.0; r2 = 4123; r3 = r1 + r2; r4 = 2344.4 + r1; r5 = 23 + r1; r6 = r1 + 2344.4; '#13#10+ + 'r7 = r6 + 23; begin AssertS(s1, ''test''); AssertS(s2, ''data: test''); AssertS(s3, ''data: test324'');'#13#10+ + 'AssertI(i1, 123);AssertI(i2, 246);AssertI(i3, 369);AssertE(r1, 123);AssertE(r1, 123.0);AssertE(r2, 4123);'#13#10+ + 'AssertE(r2, 4123.0);AssertE(r3, 4123 + 123);AssertE(r3, 4246);AssertE(r4, 2344.4 + 123);AssertE(r4, 2467.4);'#13#10+ + 'AssertE(r5, 123 + 23);AssertE(r5, 123.0 + 23.0);AssertE(r5, 146.0);AssertE(r6, 2344.4 + 123);AssertE(r6, 2467.4);'#13#10+ + 'AssertE(r7, 2467.4 + 23);AssertE(r7, 2490.4);end.'); + +end; + +procedure TCompilerTestFunctions.AssertE(s1, s2: extended); +begin + if abs(s1 - s2) > 0.0001 then + raise Exception.Create('AssertE: '+floattostr(s1)+' '+floattostr(s2)); +end; + +procedure TCompilerTestFunctions.AssertI(s1, s2: Integer); +begin + if s1 <> s2 then + raise Exception.Create('AssertI: '+inttostr(s1)+' '+inttostr(s2)); +end; + +procedure TCompilerTestFunctions.AssertS(s1, s2: string); +begin + if s1 <> s2 then + raise Exception.Create('AssertS: '+s1+' '+s2); +end; + +initialization + RegisterTests('Functions Tests', + [ TCompilerTestFunctions.Suite + ]); + +end. \ No newline at end of file diff --git a/dunit/CompilerTestSimple.pas b/dunit/CompilerTestSimple.pas new file mode 100644 index 0000000..fbae057 --- /dev/null +++ b/dunit/CompilerTestSimple.pas @@ -0,0 +1,283 @@ +unit CompilerTestSimple; + +interface + +uses Classes, + TestFramework, + { Project Units } + ifps3, + ifpscomp, + IFPS3CompExec, + CompilerTestBase; + +type + TCompilerTestSimple = class(TCompilerTestBase) + private + protected + LastResult: string; + LastResultB: Boolean; + LastResultI: Longint; + LastResultD: Double; + procedure OnCompImport(Sender: TObject; x: TIFPSPascalCompiler); override; + procedure ResultD(const d: Double); + procedure ResultS(const s: string); + procedure ResultB(const val: Boolean); + procedure ResultI(const val: Longint); + published + procedure EmptyScript; + procedure VarDecl; + procedure ForLoop; + procedure WhileLoop; + procedure CaseStatement; + procedure RepeatLoop; + procedure IfTest; + procedure IfTest2; + procedure FunctionTest; + procedure CreateObject; + procedure CharTest; + procedure CharTest2; + procedure StrConcat; + procedure StringCharTest; + procedure CastDoubleTest; + procedure ConstTest; + procedure CheckArrayProperties; + end; + +implementation + +uses StrUtils, SysUtils, Math, Dialogs, + { Project Units } + ifpiir_std, + ifpii_std, + ifpiir_stdctrls, + ifpii_stdctrls, + ifpiir_forms, + ifpii_forms, + ifpii_graphics, + ifpii_controls, + ifpii_classes, + ifpiir_graphics, + ifpiir_controls, + ifpiir_classes; + +{ TCompilerTestSimple } + + +procedure TCompilerTestSimple.OnCompImport(Sender: TObject; + x: TIFPSPascalCompiler); +begin + inherited; + CompExec.AddMethod(Self, @TCompilerTestSimple.ResultS, 'procedure ResultS(const s: string);'); + CompExec.AddMethod(Self, @TCompilerTestSimple.ResultB, 'procedure ResultB(const b: Boolean);'); + CompExec.AddMethod(Self, @TCompilerTestSimple.ResultI, 'procedure ResultI(const I: Longint);'); + CompExec.AddMethod(Self, @TCompilerTestSimple.ResultD, 'procedure ResultD(const D: Double);'); +end; + + +procedure TCompilerTestSimple.ResultS(const s: string); +begin + LastResult := s; +end; + + +const + CaseScript = + 'Program Test; begin case %d of 0: ResultS(''0'');1: ResultS(''1'');2: ResultS(''2'');'+ + '3: ResultS(''3'');else Results(''e''); end;end.'; + +procedure TCompilerTestSimple.CaseStatement; +begin + CompileRun(Format(CaseScript, [-10])); + CheckEquals('e', LastResult, last_script); + CompileRun(Format(CaseScript, [0])); + CheckEquals('0', LastResult, last_script); + CompileRun(Format(CaseScript, [2])); + CheckEquals('2', LastResult, last_script); + CompileRun(Format(CaseScript, [3])); + CheckEquals('3', LastResult, last_script); + CompileRun(Format(CaseScript, [4])); + CheckEquals('e', LastResult, last_script); +end; + +procedure TCompilerTestSimple.EmptyScript; +begin + CompileRun('Program Test; begin end.'); + CompileRun('begin end.'); +end; + +procedure TCompilerTestSimple.ForLoop; +begin + CompileRun('var i, j: Integer; begin for i := 0 to 100 do j := j + i; ResultI(j); end.'); + CheckEquals(5050, LastResultI, last_script); + CompileRun('var i, j: Integer; begin j := 1; for i := 1 to 10 do j := j * i; ResultI(j); end.'); + CheckEquals(3628800, LastResultI, last_script); +end; + +procedure TCompilerTestSimple.FunctionTest; +begin + CompileRun('function test: string; begin Result := ''Func_Res''; end; begin ResultS(test+''+test''); end.'); + CheckEquals('Func_Res+test', LastResult, last_script); +end; + +procedure TCompilerTestSimple.IfTest; +begin + CompileRun('begin if true then ResultB(True) else ResultB(False); end.'); + CheckEquals(true, LastResultB, last_script); + CompileRun('begin if false then ResultB(True) else ResultB(False); end.'); + CheckEquals(False, LastResultB, last_script); + + CompileRun('begin if not true then ResultB(True) else ResultB(False); end.'); + CheckEquals(False, LastResultB, last_script); + CompileRun('begin if not false then ResultB(True) else ResultB(False); end.'); + CheckEquals(true, LastResultB, last_script); + + CompileRun('begin if not (true) then ResultB(True) else ResultB(False); end.'); + CheckEquals(False, LastResultB, last_script); + CompileRun('begin if not (false) then ResultB(True) else ResultB(False); end.'); + CheckEquals(true, LastResultB, last_script); + + CompileRun('begin if (not true) then ResultB(True) else ResultB(False); end.'); + CheckEquals(False, LastResultB, last_script); + CompileRun('begin if (not false) then ResultB(True) else ResultB(False); end.'); + CheckEquals(true, LastResultB, last_script); + + CompileRun('begin if true and true then ResultB(True) else ResultB(False); end.'); + CheckEquals(true, LastResultB, last_script); + CompileRun('begin if true and false then ResultB(True) else ResultB(False); end.'); + CheckEquals(False, LastResultB, last_script); + CompileRun('begin if false and true then ResultB(True) else ResultB(False); end.'); + CheckEquals(False, LastResultB, last_script); + CompileRun('begin if false and false then ResultB(True) else ResultB(False); end.'); + CheckEquals(False, LastResultB, last_script); + + CompileRun('begin if true or true then ResultB(True) else ResultB(False); end.'); + CheckEquals(true, LastResultB, last_script); + CompileRun('begin if true or false then ResultB(True) else ResultB(False); end.'); + CheckEquals(true, LastResultB, last_script); + CompileRun('begin if false or true then ResultB(True) else ResultB(False); end.'); + CheckEquals(true, LastResultB, last_script); + CompileRun('begin if false or false then ResultB(True) else ResultB(False); end.'); + CheckEquals(False, LastResultB, last_script); + + CompileRun('begin if true xor true then ResultB(True) else ResultB(False); end.'); + CheckEquals(False, LastResultB, last_script); + CompileRun('begin if true xor false then ResultB(True) else ResultB(False); end.'); + CheckEquals(true, LastResultB, last_script); + CompileRun('begin if false xor true then ResultB(True) else ResultB(False); end.'); + CheckEquals(true, LastResultB, last_script); + CompileRun('begin if false xor false then ResultB(True) else ResultB(False); end.'); + CheckEquals(False, LastResultB, last_script); +end; + + + +procedure TCompilerTestSimple.RepeatLoop; +begin + CompileRun('var i: Integer; begin Repeat i := i + 8; until i mod 7 = 6; ResultI(I); end.'); + CheckEquals(48, LastResultI, last_script); +end; + + +procedure TCompilerTestSimple.WhileLoop; +begin + CompileRun('var i, j: Integer; begin while i < 10 do begin j := j + 1; i := j; end; ResultI(i+j); end.'); + CheckEquals(20, LastResultI, last_script); +end; + +procedure TCompilerTestSimple.CharTest; +begin + CompileRun('var s: string; begin s := ''''+chr(32) + chr(45) + chr(45); ResultS(s); end.'); + CheckEquals(#32#45#45, LastResult, last_script); + CompileRun('var s: string; begin s := chr(32) + chr(45) + chr(45); ResultS(s); end.'); + CheckEquals(#32#45#45, LastResult, last_script); +end; + +procedure TCompilerTestSimple.StringCharTest; +begin + CompileRun('var s: string; begin s:=''123456789''; s[1]:=s[2]; ResultS(s); end.'); + CheckEquals('223456789', LastResult, last_script); +end; + +procedure TCompilerTestSimple.CastDoubleTest; +begin + CompileRun('function Test(i1, i2: Integer): Double; begin Result := Double(i1) / i2; end; var Res: Double; begin res := Test(10, 2); ResultD(Res); end.'); + CheckEquals(10/2, LastResultD, 0.000001, last_script); +end; + +procedure TCompilerTestSimple.ResultB(const val: Boolean); +begin + LastResultB := Val; +end; + +procedure TCompilerTestSimple.ResultI(const val: Integer); +begin + LastResultI := Val; +end; + +procedure TCompilerTestSimple.ResultD(const d: Double); +begin + LastResultD := D; +end; + +procedure TCompilerTestSimple.ConstTest; +begin + CompileRun('const a = 10; b = a * 3; begin ResultI(b);end.'); + CheckEquals(30, LastResultI, last_script); + CompileRun('const a = (1+4)*6+1; begin ResultI(a);end.'); + CheckEquals(31, LastResultI, last_script); + CompileRun('const a = 2 * -(3 + 4) + (5 + 6) mod 5; begin ResultI(a);end.'); + CheckEquals(-13, LastResultI, last_script); + CompileRun('const b = ''a''+''b''+''c'';a = b = ''a''+''b''+''c'';begin ResultB(a);end.'); + CheckEquals(true, LastResultB, last_script); +end; + +const + IfTest2Script = 'var backclicked: Boolean; curpage: integer; wpselectdir: integer;'+ +'procedure Beep(i: Longint); begin if i = 2 then RaiseException(erCustomError, ''currpage <> '+ +'wpSelectDir''); if i = 3 then RaiseException(erCustomError, ''not False and False'');end;'+ +'Begin backclicked := false; curpage := 0; wpSelectDir := 5; if not BackClicked then Beep(1);'+ +'if CurPage = wpSelectDir then Beep(2); if not BackClicked and (CurPage = wpSelectDir) then Beep(3);End.'; + + +procedure TCompilerTestSimple.IfTest2; +begin + CompileRun(IfTest2Script); + CompileRun('Program IFSTest; type TShiftStates = (ssCtrl, ssShift); TShiftState = set of TShiftStates; var shift: TShiftState; Begin if shift = [ssCtrl, ssShift] then End.'); +end; + +procedure TCompilerTestSimple.checkArrayProperties; +begin + CompileRun('var r: TStringList; begin r := TStringList.Create; r.Values[''test''] := ''data''; ResultS(r.text); r.Free;end.'); + CheckEquals('test=data'#13#10, LastResult); +end; + +procedure TCompilerTestSimple.VarDecl; +begin + CompileRun('Program test; var i: Longint; begin end.'); + +end; + +procedure TCompilerTestSimple.StrConcat; +begin + CompileRun('var s: string; begin s := ''test''; s := s + ''TESTED''; ResultS(s); End.'); + CheckEquals('testTESTED', LastResult); +end; + +procedure TCompilerTestSimple.CreateObject; +begin + CompileRun('var r: TObject; begin r := TObject.Create; r.Free; end.'); +end; + +procedure TCompilerTestSimple.CharTest2; +begin +CompileRun('var s:string; i:integer; begin i := ord(''a''); s:=chr(i); '+ + 'i := ord(''a'');s:=chr(i + 1); end.'); + +end; + +initialization + RegisterTests('Basic Compiler Tests', + [ TCompilerTestSimple.Suite + ]); + +end. \ No newline at end of file diff --git a/dunit/ifps3_DUnit.dpr b/dunit/ifps3_DUnit.dpr new file mode 100644 index 0000000..40fbc23 --- /dev/null +++ b/dunit/ifps3_DUnit.dpr @@ -0,0 +1,21 @@ +program ifps3_DUnit; + +uses + Forms, + TestFramework, + GUITestRunner, + CompilerTestBase in 'CompilerTestBase.pas', + CompilerTestSimple in 'CompilerTestSimple.pas', + CompilerTestFunctions in 'CompilerTestFunctions.pas', + CompileTestExtended in 'CompileTestExtended.pas'; + +{$R *.res} + +var + AGUITestRunner: TGUITestRunner; +begin + Application.Initialize; + Application.CreateForm(TGUITestRunner, AGUITestRunner); + AGUITestRunner.Suite := RegisteredTests; + Application.Run; +end. diff --git a/dunit/ifps3_DUnit.res b/dunit/ifps3_DUnit.res new file mode 100644 index 0000000000000000000000000000000000000000..a80858393190b78573e3a8e964b75e01337cf1b1 GIT binary patch literal 876 zcmZuw!D`e{6g`;)3`FV_g?85=l-8YwECpL>QC!&mgOp|~gXHZrr3(XD^jD^2Biv0~ z`5QtvE@xN4;`Q8@WSoMRIeGWIbMAeQ_vQh>j8N^t^j`d&jCx2<;I--WaWtBqGMN#F zM1WzMHUEza;15;R5BxGEDs){(!8T!o_5;8Dz7$EeX)&ehBaxhut$18FHnHL`mT!)B zpss6?>wnxEGDOG6!(1cnHKNyLIZTjecvBST<)L@fO`A>j%CacVJWr@koGad!A6MKt zH&2UmUl7-ld0q|;MDlIQqmGg9^?q=HZRb*#roJ9A7r1is{dNB3mh!G&54OOZ4Sz>H zw}xB$E`7EbIFDp2b#7M%9yjfDlBP%o19|49(ZGhr6B!J(*nuV@^1=If=roW6tsUr%_nXEYDeJ+zJ}zBDJ*ENaSn7`(QK!U-XoBWO_1g$cV)PRiHYe3snuv z@KTo>(B(sXUdA~1WdL>zcWd~=oH#J>?`7E0i_0sm^t*OQC!&mgOp|~gXHZrr3(XD^jD^2Biv0~ z`5QtvE@xN4;`Q8@WSoMRIeGWIbMAeQ_vQh>j8N^t^j`d&jCx2<;I--WaWtBqGMN#F zM1WzMHUEza;15;R5BxGEDs){(!8T!o_5;8Dz7$EeX)&ehBaxhut$18FHnHL`mT!)B zpss6?>wnxEGDOG6!(1cnHKNyLIZTjecvBST<)L@fO`A>j%CacVJWr@koGad!A6MKt zH&2UmUl7-ld0q|;MDlIQqmGg9^?q=HZRb*#roJ9A7r1is{dNB3mh!G&54OOZ4Sz>H zw}xB$E`7EbIFDp2b#7M%9yjfDlBP%o19|49(ZGhr6B!J(*nuV@^1=If=roW6tsUr%_nXEYDeJ+zJ}zBDJ*ENaSn7`(QK!U-XoBWO_1g$cV)PRiHYe3snuv z@KTo>(B(sXUdA~1WdL>zcWd~=oH#J>?`7E0i_0sm^t*O 0 then + Setlength(LastTokens, TokenHistoryLength); + + FOutUnitList := TStringList.Create; + FSingleUnit := True; +end; {Create} + +destructor TUnitParser.Destroy; +begin + FOutUnitList.Free; + fParser.free; + ini.free; + inherited; +end; {Destroy} + +procedure TUnitParser.SetWriteln(aWriteln: TWriteln); +begin + if assigned(aWriteln) then + fWriteln := aWriteln +//else +// fWriteln := DefWriteln; +end; {SetWriteln} + +procedure TUnitParser.SetReadln(aReadln: TReadln); +begin + if assigned(aReadln) then + fReadln := aReadln +//else +// fReadln := DefReadln; +end; {SetWriteln} + +procedure TUnitParser.AddToTokenHistory(const aToken: TPasToken); +begin + if TokenHistoryLength <= 0 then exit; + LastTokens[FTail] := aToken; + FTail := (FTail + 1) mod TokenHistoryLength; + if FTail = FHead then + FHead := (FHead + 1) mod TokenHistoryLength + else + inc(TokenHistoryCount); +end; {AddToTokenHistory} + +function TUnitParser.RemoveFromTokenHistory(var aToken: TPasToken): boolean; +begin + Result := (TokenHistoryLength > 0) and (TokenHistoryCount <> 0); + if result then + begin + aToken := LastTokens[FHead]; + FHead := (FHead + 1) mod TokenHistoryLength; + dec(TokenHistoryCount); + end; +end; {RemoveFromTokenHistory} +(*----------------------------------------------------------------------------*) +procedure TUnitParser.SetToken(aTokenID: TPSPasToken; aToken: string; aTokenRow, aTokenCol: integer); +begin + fToken.ID := aTokenID; + fToken.data := Uppercase(aToken); + fToken.Org := aToken; + fToken.row := aTokenRow; + fToken.col := aTokenCol; + AddToTokenHistory(fToken); +end; {InsertToken} + +procedure TUnitParser.NextToken; +begin + fPrevToken := fToken; +// fprevOrgToken := fparser.OriginalToken; + fParser.next; + fToken.ID := fParser.CurrTokenID; + fToken.data := fParser.GetToken; + fToken.Org := fParser.OriginalToken; + fToken.row := fParser.Row; + fToken.col := fParser.Col; + AddToTokenHistory(fToken); +end; {NextToken} + +// ----------------------------------------------------------------------------- + +procedure TUnitParser.skipToSemicolon; //Birb +begin + while not ifmatch(CSTI_SemiColon) do //assuming EOF checks aren't needed since everywhere in this code it's done similarly (maybe parser throws exception at EOF so that loops similar to this one don't go on forever) + NextToken; +end; + +function TUnitParser.Ifmatch(atoken: TPSPasToken): boolean; +begin + Result := TokenID = atoken; + if result then + NextToken; +end; {Ifmatch} + +procedure TUnitParser.Match(atoken: TPSPasToken; err: string = ''); +var + Errormsg: string; + TokenList: string; + OldToken: TPasToken; +begin + if not Ifmatch(atoken) then + begin + if err = '' then + err := GetTokenName(atoken); + Errormsg := 'Expecting Token ''' + err + ''' but '; + case TokenID of + CSTI_Identifier: Errormsg := Errormsg + 'Identifier ''' + Token; + CSTI_Integer: Errormsg := Errormsg + 'Integer number ''' + Token; + CSTI_Real: Errormsg := Errormsg + 'Floatpoint number ''' + Token; + CSTI_String: Errormsg := Errormsg + 'String ''' + Token; + CSTI_Char: Errormsg := Errormsg + 'Character ''' + Token; + CSTI_HexInt: Errormsg := Errormsg + 'Hexadecimal number ''' + Token; + else Errormsg := Errormsg + 'token ''' + GetTokenName(TokenID); + end; + // build the list of tokens + TokenList := ''; + while RemoveFromTokenHistory(OldToken) do + begin + if OldToken.ID in [CSTI_Identifier, CSTI_Integer, CSTI_Real, + CSTI_String, CSTI_Char, CSTI_HexInt] then + TokenList := TokenList + OldToken.Data + ' ' + else + TokenList := TokenList + GetTokenName(OldToken.ID) + ' '; + end; + RaiseError(Errormsg + ''' found' + NewLine + 'Previous tokens : ''' + TokenList + '''', TokenRow, TokenCol); + end; +end; {Match} + +// ----------------------------------------------------------------------------- + +procedure TUnitParser.ParseUnit(const Input: string); +begin + UnitName := ''; + FOutUnitList.Clear; + fparser.OnParserError := ParserError; + fParser.SetText(Input); + try + StartParse; + ParseUnitHeader; + ParseGlobalDeclarations; + finally + case FSingleUnit of + False : FinishParse; + True : FinishParseSingleUnit; + end; + end; +end; {ParseUnit} +(*----------------------------------------------------------------------------*) +procedure TUnitParser.AddRequiredUnit(const UnitName: string; TimeMode: TTimeMode; InterfaceSection: boolean); +var + Unitlist : TStringList; { ref } + Index : integer; +begin +// choice the correct list to Add it to + Unitlist := nil; + case TimeMode of + CompileTime : if InterfaceSection then + Unitlist := fCompileTimeUnitList + else Unitlist := fCompileTimeUnitListImp; + RunTime : if InterfaceSection then + Unitlist := fRunTimeUnitList + else Unitlist := fRunTimeUnitListImp; + else RaiseError('Unable to deterimine which used unit list' + ' to Add the unit ''' + UnitName + ''' to', TokenRow, TokenCol); + end; + Index := Unitlist.Indexof(UnitName); + if Index = -1 then + Unitlist.Add(UnitName) +end; {AddRequiredUnit} +(*----------------------------------------------------------------------------*) +function TUnitParser.RegisterProc(const ProcName: string; TimeMode: TTimeMode; Attr: TProcAttr): TProcList; +var + proclist: TStringList; + Index: integer; +begin + if ProcName = '' then + RaiseError('Invalid procedure name', TokenRow, TokenCol); + + if TimeMode = CompileTime then + proclist := fCompileTimeproclist + else proclist := fRunTimeProclist; + + assert(proclist <> nil); + Index := proclist.IndexOf(ProcName); + if Index = -1 then + begin + Result := TProcList.create; + try + Result.Add(ProcName); + if not (IsHelper in Attr) then + Result.Add('begin'); + Result.ProcAttr := Attr; + proclist.AddObject(ProcName, Result); + except + Result.free; + raise + end; + end + else + Result := proclist.Objects[Index] as TProcList; +end; {RegisterProc} +(*----------------------------------------------------------------------------*) +procedure TUnitParser.FinishProcs; +var + Index: integer; + obj: TObject; +begin + if FRunTimeProcList <> nil then + for Index := FRunTimeProcList.count - 1 downto 0 do + begin + obj := FRunTimeProcList.Objects[Index]; + if (obj is TProcList) and + not (IsHelper in TProcList(obj).ProcAttr) then + TProcList(obj).Add('end;'); + end; + if FCompileTimeProcList <> nil then + for Index := FCompileTimeProcList.count - 1 downto 0 do + begin + obj := FCompileTimeProcList.Objects[Index]; + if (obj is TProcList) and + not (IsHelper in TProcList(obj).ProcAttr) then + TProcList(obj).Add('end;'); + end; +end; {FinishProcs} + +(* +Procedure TUnitParser.AddVarToProc(const ProcName : string; + CompileTime : TCompileTime; + const VarString : string); +var + proc : TStringList; +begin +proc := RegisterProc(ProcName,CompileTime,false); +If Proc = nil then + RaiseError('Procedure :"'+ProcName+'" can not be found'); +If fastUppercase(Proc[1]) = 'VAR' then + Proc.Insert(2,VarString) +else + Proc.Insert(1,'var'+newline+VarString) +end; {AddVarToProc} +*) +(*----------------------------------------------------------------------------*) +procedure TUnitParser.StartParse; +begin + SetToken(fParser.CurrTokenID, fParser.OriginalToken, fParser.Row, FParser.Col); + OutputDT := ''; + OutputRT := ''; + + FRunTimeProcList := TStringList.create; + FCompileTimeProcList := TStringList.create; + + fRunTimeUnitList := TStringList.create; + fRunTimeUnitListImp := TStringList.create; + fCompileTimeUnitList := TStringList.create; + fCompileTimeUnitListImp := TStringList.create; +end; {StartParse} +(*----------------------------------------------------------------------------*) +function TUnitParser.UnitNameRT: string; +begin + Result := Format('%sR_%s.pas', [FUnitPrefix, UnitName]); +end; +(*----------------------------------------------------------------------------*) +function TUnitParser.UnitNameCT: string; +begin + Result := Format('%sC_%s.pas', [FUnitPrefix, UnitName]); +end; + +function TUnitParser.UnitNameCmp: string; +begin + Result := Format('%sI_%s.pas', [FUnitPrefix, UnitName]); +end; + + +(*----------------------------------------------------------------------------*) +procedure TUnitParser.SaveToPath(const Path: string); +var + List : TStringList; +begin + if SingleUnit then + begin + FOutUnitList.SaveToFile(Path + UnitNameCmp); + end else begin + List := TStringList.Create; + try + List.Text := OutputRT; + List.SaveToFile(Path + UnitnameRT); + + List.Text := OutputDT; + List.SaveToFile(Path + UnitnameCT); + finally + List.Free; + end; + end; +end; +(*----------------------------------------------------------------------------*) +procedure TUnitParser.FinishParse; +var + OutPut : TStringList; + obj : TObject; + Index : integer; + S : string; +begin + try + FinishProcs; + + {===================================================================================} + // write out the design time unit + if FCompileTimeProcList <> nil then + begin + OutPut := TStringList.create; + try + // insert the front of the text body //FUnitPrefix + //OutPutList.Add('unit ifpii_' + UnitName + ';'); + OutPut.Add('unit ' + ChangeFileExt(UnitNameCT, '') + ';'); + OutPut.Add(GetLicence); +// OutPut.Add('{$I PascalScript.inc}'); + OutPut.Add('interface'); + OutPut.Add(GetUsedUnitList(fCompileTimeUnitList) + Newline); + + for Index := FCompileTimeProcList.count - 1 downto 0 do + begin + obj := FCompileTimeProcList.objects[Index]; + if (obj is TProcList) and + (PublicProc in TProcList(obj).ProcAttr) then + OutPut.Add(FCompileTimeProcList[Index]); + end; + + OutPut.Add('implementation'); + // insert the Designtime unit importer into the used unit list + S := GetUsedUnitList(fCompileTimeUnitListImp); + if S <> '' then + begin + Delete(S, length(S), 1); + OutPut.Add(S); +(* if WriteDefines then + begin + OutPut.Add('{$IFDEF USEIMPORTER}'); + OutPut.Add(' ,CIImporterU'); + OutPut.Add('{$ENDIF};'); + end;*) + OutPut.Add(';'); + end else begin +(* if WriteDefines then + begin + OutPut.Add('{$IFDEF USEIMPORTER}'); + OutPut.Add(' uses CIImporterU;'); + OutPut.Add('{$ENDIF}'); + end;*) + end; + + //OutPut.Add(''); + //Output.Add('const IID__DUMMY: TGUID = ''{00000000-0000-0000-0000-000000000000}'';'); //Birb (!!!could set some attribute to avoid spitting that out when not needed) + //Output.Add(''); + + // reinsert the main text body + for Index := FCompileTimeProcList.count - 1 downto 0 do + begin + obj := FCompileTimeProcList.objects[Index]; + if (obj is TProcList) and + (IsHelper in TProcList(obj).ProcAttr) then + OutPut.Add(TStringList(obj).text); + end; + + for Index := FCompileTimeProcList.count - 1 downto 0 do + begin + obj := FCompileTimeProcList.objects[Index]; + if (obj is TProcList) and + (PublicProc in TProcList(obj).ProcAttr) then + OutPut.Add(TStringList(obj).text); + end; + + // insert the Runtime unit importer code into the end of the unit +(* if WriteDefines then + begin + OutPut.Add('{$IFDEF USEIMPORTER}'); + OutPut.Add('initialization'); + OutPut.Add('CIImporter.AddCallBack(@SIRegister_' + UnitName + ',PT_ClassImport);'); + OutPut.Add('{$ENDIF}'); + end;*) + OutPut.Add('end.'); + + finally + if OutPut <> nil then + OutputDT := OutPut.text; + OutPut.free; + end; + end; + + + + {===================================================================================} + // write out the run time import unit + if FRunTimeProcList <> nil then + begin + OutPut := TStringList.create; + try + OutPut.Add('unit ' + ChangeFileExt(UnitNameRT, '') + ';'); + OutPut.Add(GetLicence); +// OutPut.Add('{$I PascalScript.inc}'); + OutPut.Add('interface'); + OutPut.Add(GetUsedUnitList(fRunTimeUnitList) + Newline); + for Index := FRunTimeProcList.count - 1 downto 0 do + begin + obj := FRunTimeProcList.objects[Index]; + if (obj is TProcList) and + (PublicProc in TProcList(obj).ProcAttr) then + OutPut.Add(FRunTimeProcList[Index]); + end; + + OutPut.Add(''); + OutPut.Add('implementation'); + + // insert the Runtime unit importer into the used unit list + S := GetUsedUnitList(fRunTimeUnitListImp); + if RunTimeProcType <> [] then + begin + if S <> '' then + begin + Delete(S, length(S), 1); + OutPut.Add(S); +(* if WriteDefines then + begin + OutPut.Add('{$IFDEF USEIMPORTER}'); + OutPut.Add(' ,RIImporterU'); + OutPut.Add('{$ENDIF};'); + end;*) + OutPut.Add(';'); + end + else + begin +(* if WriteDefines then + begin + OutPut.Add('{$IFDEF USEIMPORTER}'); + OutPut.Add(' uses RIImporterU;'); + OutPut.Add('{$ENDIF}'); + end;*) + end; + end + else OutPut.Add(S); + + // reinsert the main text body --IsHelper + for Index := FRunTimeProcList.count - 1 downto 0 do + begin + obj := FRunTimeProcList.objects[Index]; + if (obj is TProcList) and + (IsHelper in TProcList(obj).ProcAttr) then + OutPut.Add(TProcList(obj).text); + end; + + // reinsert the main text body --PublicProc + for Index := FRunTimeProcList.count - 1 downto 0 do + begin + obj := FRunTimeProcList.objects[Index]; + if (obj is TProcList) and + (PublicProc in TProcList(obj).ProcAttr) then + OutPut.Add(TProcList(obj).text); + end; + + // Add the ending of the unit + // insert the Runtime unit importer code into the end of the unit + if RunTimeProcType <> [] then + begin +(* if WriteDefines then + begin + OutPut.Add('{$IFDEF USEIMPORTER}'); + OutPut.Add('initialization'); + if RoutineImporter in RunTimeProcType then + OutPut.Add('RIImporter.AddCallBack(RIRegister_' + UnitName + '_Routines);'); + if ClassImporter in RunTimeProcType then + OutPut.Add('RIImporter.Invoke(RIRegister_' + UnitName + ');'); + OutPut.Add('{$ENDIF}'); + end;*) + end; + OutPut.Add('end.'); + finally + if OutPut <> nil then + OutputRT := OutPut.text; + OutPut.free; + end; + end; + finally + + for Index := FRunTimeProcList.Count - 1 downto 0 do + begin + FRunTimeProcList.Objects[Index].Free; + end; + FreeAndNil(FRunTimeProcList); + for Index := FCompileTimeProcList.Count - 1 downto 0 do + begin + FCompileTimeProcList.Objects[Index].Free; + end; + + FreeAndNil(FCompileTimeProcList); + FreeAndNil(fRunTimeUnitList); + FreeAndNil(fRunTimeUnitListImp); + FreeAndNil(fCompileTimeUnitList); + FreeAndNil(fCompileTimeUnitListImp); + end; +end; {FinishParse} + +(*----------------------------------------------------------------------------*) +procedure TUnitParser.FinishParseSingleUnit; + {-------------------------------------------} + procedure ProcessUsesList(List: TStrings); + var + i : Integer; + begin + if List.Count > 0 then + begin + List[0] := ' ' + List[0]; + + for i := 1 to List.Count - 1 do + List[i] := ' ,' + List[i]; + + List.Insert(0, 'uses'); + List.Add(' ;') + end; + end; + {-------------------------------------------} + procedure AddToUsesList(UsesList, CheckList: TStrings; const AUnitName: string); + var + i : Integer; + S : string; + begin + S := UpperCase(AUnitName); + + if Assigned(CheckList) then + begin + for i := 0 to CheckList.Count - 1 do + if UpperCase(CheckList[i]) = S then + Exit; //==> + end; + + for i := 0 to UsesList.Count - 1 do + if UpperCase(UsesList[i]) = S then + Exit; //==> + + UsesList.Add(AUnitName); + end; +var + OutPutList : TStringList; + InterfaceUsesList : TStringList; { helper } + ImplementationUsesList : TStringList; { helper } + List : TStringList; + obj : TObject; + Index : integer; + //S : string; + i : Integer; + sClassName : string; +begin + OutPutList := TStringList.Create; + ImplementationUsesList := TStringList.Create; + InterfaceUsesList := TStringList.Create; + List := TStringList.Create; + +// ImplementationUsesList .CaseSensitive := False; +// InterfaceUsesList .CaseSensitive := False; + try + FinishProcs; + + { unit name, etc. } + OutPutList.Add('unit ' + ChangeFileExt(UnitNameCmp, '') + ';'); + OutPutList.Add(GetLicence); +// OutPutList.Add('{$I PascalScript.inc}'); + OutPutList.Add('interface'); + OutPutList.Add(' '); + + { interface uses clause list } + AddToUsesList(InterfaceUsesList, nil, 'SysUtils'); + AddToUsesList(InterfaceUsesList, nil, 'Classes'); + AddToUsesList(InterfaceUsesList, nil, 'uPSComponent'); + AddToUsesList(InterfaceUsesList, nil, 'uPSRuntime'); + AddToUsesList(InterfaceUsesList, nil, 'uPSCompiler'); + + if Assigned(FCompileTimeProcList) then + for i := 0 to FCompileTimeUnitList.Count - 1 do + AddToUsesList(InterfaceUsesList, nil, FCompileTimeUnitList[i]); + + if Assigned(FRunTimeProcList) then + for i := 0 to FRunTimeUnitList.Count - 1 do + AddToUsesList(InterfaceUsesList, nil, FRunTimeUnitList[i]); + + List.Assign(InterfaceUsesList); + ProcessUsesList(List); + OutPutList.AddStrings(List); + OutPutList.Add(' '); + + sClassName := FCompPrefix + '_' + UnitName ; + OutPutList.Add('type '); + OutPutList.Add('(*----------------------------------------------------------------------------*)'); + OutPutList.Add(Format(' %s = class(TPSPlugin)', [sClassName])); + OutPutList.Add(' protected'); +// OutPutList.Add(' procedure CompOnUses(CompExec: TPSScript); override;'); +// OutPutList.Add(' procedure ExecOnUses(CompExec: TPSScript); override;'); + OutPutList.Add(' procedure CompileImport1(CompExec: TPSScript); override;'); +// OutPutList.Add(' procedure CompileImport2(CompExec: TPSScript); override;'); + OutPutList.Add(' procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;'); +// OutPutList.Add(' procedure ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;'); + OutPutList.Add(' end;'); + OutPutList.Add(' '); + OutPutList.Add(' '); + + + { compile-time function declarations } + if Assigned(FCompileTimeProcList) then + begin + OutPutList.Add('{ compile-time registration functions }'); + for Index := FCompileTimeProcList.count - 1 downto 0 do + begin + obj := FCompileTimeProcList.objects[Index]; + if (obj is TProcList) and + (PublicProc in TProcList(obj).ProcAttr) then + OutPutList.Add(FCompileTimeProcList[Index]); + end; + end; + + OutPutList.Add(''); + + { run-time function declarations } + if Assigned(FRunTimeProcList) then + begin + OutPutList.Add('{ run-time registration functions }'); + for Index := FRunTimeProcList.count - 1 downto 0 do + begin + obj := FRunTimeProcList.objects[Index]; + if (obj is TProcList) and + (PublicProc in TProcList(obj).ProcAttr) then + OutPutList.Add(FRunTimeProcList[Index]); + end; + end; + + OutPutList.Add(''); + + OutPutList.Add('procedure Register;'); + + OutPutList.Add(''); + OutPutList.Add('implementation'); + OutPutList.Add(''); + OutPutList.Add(''); + + + { implementation uses clause } + if Assigned(FCompileTimeProcList) then + for i := 0 to FCompileTimeUnitListImp.Count - 1 do + AddToUsesList(ImplementationUsesList, InterfaceUsesList, FCompileTimeUnitListImp[i]); + + + if Assigned(FRunTimeProcList) then + for i := 0 to FRunTimeUnitListImp.Count - 1 do + AddToUsesList(ImplementationUsesList, InterfaceUsesList, FRunTimeUnitListImp[i]); + +(* if WriteDefines then + begin + ImplementationUsesList.Add('CIImporterU'); + if RunTimeProcType <> [] then + ImplementationUsesList.Add('RIImporterU'); + end;*) + + List.Assign(ImplementationUsesList); + ProcessUsesList(List); + (* + i := List.IndexOf('CIImporterU'); + if i <> -1 then + begin + if i = 1 then + List[i] := '{$IFDEF USEIMPORTER} CIImporterU {$ENDIF}' + else List[i] := '{$IFDEF USEIMPORTER} ,CIImporterU {$ENDIF}'; + end; + i := List.IndexOf('RIImporterU'); + if i <> -1 then + begin + if i = 1 then + List[i] := '{$IFDEF USEIMPORTER} RIImporterU {$ENDIF}' + else List[i] := '{$IFDEF USEIMPORTER} ,RIImporterU {$ENDIF}'; + end; + +*) + + + OutPutList.AddStrings(List); + OutPutList.Add(' '); + OutPutList.Add(' '); + OutPutList.Add('procedure Register;'); + OutPutList.Add('begin'); + OutPutList.Add(' RegisterComponents('''+FCompPage+''', ['+FCompPrefix + '_' + UnitName+']);'); + OutPutList.Add('end;'); + OutPutList.Add(''); + + { compile-time function definitions } + if Assigned(FCompileTimeProcList) then + begin + OutPutList.Add('(* === compile-time registration functions === *)'); + + // reinsert the main text body + for Index := FCompileTimeProcList.count - 1 downto 0 do + begin + obj := FCompileTimeProcList.objects[Index]; + if (obj is TProcList) and (IsHelper in TProcList(obj).ProcAttr) then + begin + OutPutList.Add('(*----------------------------------------------------------------------------*)'); + OutPutList.Add(TStringList(obj).text); + end; + end; + + for Index := FCompileTimeProcList.count - 1 downto 0 do + begin + obj := FCompileTimeProcList.objects[Index]; + if (obj is TProcList) and (PublicProc in TProcList(obj).ProcAttr) then + begin + OutPutList.Add('(*----------------------------------------------------------------------------*)'); + OutPutList.Add(TStringList(obj).text); + end; + end; + end; + + { run-time function definitions } + if Assigned(FRunTimeProcList) then + begin + OutPutList.Add('(* === run-time registration functions === *)'); + + // reinsert the main text body --IsHelper + for Index := FRunTimeProcList.count - 1 downto 0 do + begin + obj := FRunTimeProcList.objects[Index]; + if (obj is TProcList) and (IsHelper in TProcList(obj).ProcAttr) then + begin + OutPutList.Add('(*----------------------------------------------------------------------------*)'); + OutPutList.Add(TProcList(obj).text); + end; + end; + + // reinsert the main text body --PublicProc + for Index := FRunTimeProcList.count - 1 downto 0 do + begin + obj := FRunTimeProcList.objects[Index]; + if (obj is TProcList) and (PublicProc in TProcList(obj).ProcAttr) then + begin + OutPutList.Add('(*----------------------------------------------------------------------------*)'); + OutPutList.Add(TProcList(obj).text); + end; + end; + end; + + OutPutList.Add(' '); + OutPutList.Add(' '); + OutPutList.Add(Format('{ %s }', [sClassName])); + OutPutList.Add('(*----------------------------------------------------------------------------*)'); + OutPutList.Add(Format('procedure %s.CompileImport1(CompExec: TPSScript);', [sClassName])); + OutPutList.Add('begin'); + OutPutList.Add(Format(' SIRegister_%s(CompExec.Comp);', [UnitName])); + OutPutList.Add('end;'); + OutPutList.Add('(*----------------------------------------------------------------------------*)'); + OutPutList.Add(Format('procedure %s.ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter);', [sClassName])); + OutPutList.Add('begin'); + if not (InterfaceImporter in RunTimeProcType) then //Birb + OutPutList.Add(Format(' RIRegister_%s(ri);', [UnitName])); //Birb: (!!!) should fix it so that this line is never added if there's no RIRegister... routine (e.g. if unit has just constants) + if RoutineImporter in RunTimeProcType then + OutPutList.Add(Format(' RIRegister_%s_Routines(CompExec.Exec); // comment it if no routines', [UnitName])); + OutPutList.Add('end;'); + OutPutList.Add('(*----------------------------------------------------------------------------*)'); + + + OutPutList.Add(' '); + OutPutList.Add(' '); + + OutPutList.Add('end.'); + finally + for Index := FRunTimeProcList.Count - 1 downto 0 do + begin + FRunTimeProcList.Objects[Index].Free; + end; + FreeAndNil(FRunTimeProcList); + for Index := FCompileTimeProcList.Count - 1 downto 0 do + begin + FCompileTimeProcList.Objects[Index].Free; + end; + + FreeAndNil(FCompileTimeProcList); + FreeAndNil(fRunTimeUnitList); + FreeAndNil(fRunTimeUnitListImp); + FreeAndNil(fCompileTimeUnitList); + FreeAndNil(fCompileTimeUnitListImp); + + List.Free; + ImplementationUsesList.Free; + InterfaceUsesList.Free; + FOutUnitList.Assign(OutPutList); + OutPutList.Free; + end; + +end; +(*----------------------------------------------------------------------------*) +procedure TUnitParser.ParseUnitHeader; +begin +// parser 'Unit ;' + Match(CSTII_Unit); + Match(CSTI_Identifier); + Unitname := prevOrgToken; + Match(CSTI_SemiColon); + Match(CSTII_Interface); +// parser the units clause 'uses [, ];' + if IfMatch(CSTII_uses) then + begin + repeat + Match(CSTI_Identifier); + AddRequiredUnit(PrevOrgToken, RunTime, false); +// AddRequiredUnit(PrevToken,CompileTime,false); + if TokenID = CSTI_SemiColon then + begin + Match(CSTI_SemiColon); + break; + end + else + Match(CSTI_Comma, ','' or '';'); + until false; + end; + + AddRequiredUnit(UnitName, RunTime, false); + fCurrentDTProc := RegisterProc('procedure SIRegister_' + UnitName + + '(CL: TPSPascalCompiler);', CompileTime, [PublicProc]); + AddRequiredUnit('uPSCompiler', CompileTime, True); + AddRequiredUnit('uPSRuntime', RunTime, true); + + RunTimeProcType := []; + fCurrentRTProc := nil; +end; +(*----------------------------------------------------------------------------*) +procedure TUnitParser.ParseGlobalDeclarations; +begin + while not IfMatch(CSTII_Implementation) do + case TokenID of + CSTII_var : ParseVariables; + CSTII_const : ParseConstants; + CSTII_type : ParseTypes; + CSTII_procedure , + CSTII_function : ParseRoutines; + CSTI_Identifier : RaiseError('Declaration expected but identifier ''' + OrgToken + ''' found', TokenRow, TokenCol); + else RaiseError('Unknown keyword ''' + GetTokenName(TokenID) + '''', TokenRow, TokenCol); + end; +end; +(*----------------------------------------------------------------------------*) +function TUnitParser.GetConstantType: string; +var + value: int64; +begin + Result := ''; +// determine the constant type + case TokenID of + CSTI_Integer: + begin + value := StrToInt64(Token); + if (value < low(Longint)) then + Result := 'Int64' + else if value > High(Longint) then + begin + if value > High(longword) then + Result := 'Int64' + else + Result := 'LongWord' + end + else + Result := 'LongInt'; + end; + CSTI_HexInt: Result := 'LongWord'; + CSTI_Real: Result := 'Extended'; + CSTI_String: Result := 'String'; + CSTI_Char: Result := 'Char'; + CSTI_Identifier: + begin // unknown identifier + if (Token = 'FALSE') or + (Token = 'TRUE') then + Result := 'Boolean'; + end; + else RaiseError('Expected valid type, but found ''' + GetTokenName(TokenID) + '''', TokenRow, TokenCol); + end; {case} +end; {GetConstantType} + +function TUnitParser.ParseConstantExpression(var ExpType: string): string; +var + BracketCount: integer; + BlkBracketCount: integer; +begin + result := ''; + BracketCount := 0; + BlkBracketCount := 0; + repeat + // generate the actual string + case TokenID of + CSTI_OpenBlock: + BEGIN + ExpType := 'ConstSet'; + Inc(BlkBracketCount); + end; + CSTI_Comma: If BlkBracketCount>0 then + Result := Result + ' or '; + CSTI_CloseBlock: + begin // prevent adding brakets when there should not be + if blkBracketCount <> 0 then + begin + dec(BlkBracketCount) + end + else break; + end; + CSTI_Integer, CSTI_HexInt, CSTI_Real, + CSTI_String, CSTI_Char, CSTI_Identifier: + begin + if (TokenId = CSTI_Identifier) and (BlkBracketCount>0) then begin + result := result + 'ord('+orgtoken+')'; + end else begin + ExpType := GetConstantType; + // convert sveral consecutive characters into a string + if (PrevTokenID = CSTI_Char) and + (TokenID = CSTI_Char) then + begin + Result := Result + orgtoken; + ExpType := 'String'; + end + else + Result := Result + ' ' + orgToken; + end; + end; + CSTI_Equal: Result := Result + ' ='; + CSTI_NotEqual: Result := Result + ' <>'; + CSTI_Greater: Result := Result + ' >'; + CSTI_GreaterEqual: Result := Result + ' >='; + CSTI_Less: Result := Result + ' <'; + CSTI_LessEqual: Result := Result + ' <='; + CSTI_Plus: Result := Result + ' +'; + CSTI_Minus: Result := Result + ' -'; + CSTI_Divide: begin Result := Result + ' /'; ExpType := 'Extended'; end; + CSTII_div: Result := Result + ' div'; + CSTI_Multiply: Result := Result + ' *'; + CSTI_AddressOf: Result := Result + ' @'; + CSTI_Dereference: Result := Result + ' ^'; + CSTII_and: Result := Result + ' and'; + CSTII_mod: Result := Result + ' mod'; + CSTII_not: Result := Result + ' not'; + CSTII_or: Result := Result + ' or'; + CSTII_shl: Result := Result + ' shl'; + CSTII_shr: Result := Result + ' shr'; + CSTII_xor: Result := Result + ' xor'; + CSTII_Chr: begin + // jgv + Result := Result + ' char('; + NextToken; + Match (CSTI_OpenRound); + Result := Result + ParseConstantExpression(ExpType) + ')'; + Match (CSTI_CloseRound); + break; + //Result := Result + ' char(' + ParseConstantExpression(ExpType) + ')'; + end; + CSTII_Ord: begin + // jgv + Result := Result + ' ord('; + NextToken; + Match (CSTI_OpenRound); + Result := Result + ParseConstantExpression(ExpType); + Match (CSTI_CloseRound); + break; + //Result := Result + ' ord(' + ParseConstantExpression(ExpType) + ')'; + end; + CSTI_OpenRound: begin Result := Result + ' ('; inc(BracketCount); end; + CSTI_CloseRound: + begin // prevent adding brakets when there should not be + if BracketCount <> 0 then + begin + Result := Result + ' )'; + dec(BracketCount) + end + else break; + end; + end; + NextToken; + until (not (TokenID in [CSTI_Integer, CSTI_HexInt, CSTI_Real, CSTI_String, CSTI_Char, + CSTI_Equal, CSTI_NotEqual, CSTI_Greater, CSTI_GreaterEqual, + CSTI_Less, CSTI_LessEqual, CSTI_Plus, CSTI_Minus, CSTI_Divide, + CSTII_div, CSTI_Multiply, CSTI_AddressOf, CSTI_Dereference, + CSTII_and, CSTII_mod, CSTII_not, CSTII_or, CSTII_shl, CSTII_shr, + CSTII_xor, CSTII_Chr, CSTII_Ord, CSTI_OpenRound, CSTI_CloseRound])) and ((BlkBracketCount=0) or + not (TokenID in [CSTI_COmma,CSTI_Identifier, CSTI_CloseBlock ])) ; +end; {ParseConstantExpression} + +function TUnitParser.GetAsString(const ConstType, ConstValue: string): string; +begin + if ConstType = 'BOOLEAN' then + begin + with RegisterProc('Function BoolToStr(value : boolean) : string;', CompileTime, [IsHelper]) do + begin + if IsDone in ProcAttr then exit; + include(ProcAttr, IsDone); + Add('Begin If value then Result := ''TRUE'' else Result := ''FALSE'' End;'); + end; + Result := 'BoolToStr(' + ConstValue + ')'; + end + else If ConstType = 'CONSTSET' then + result := '.Value.ts32 := '+ConstValue +// Result := ConstValue +//else If ConstType = 'CHAR' then +// Result := '' + else + begin + AddRequiredUnit('Sysutils', CompileTime, false); + if (ConstType = 'BOOLEAN') then + Result := '.SetInt(Ord(' + Constvalue + '))' + else if (ConstType = 'LONGINT') or (ConstType = 'INTEGER') then + Result := '.SetInt(' + ConstValue + ')' + else if (ConstType = 'INT64') then + Result := '.SetInt64(' + ConstValue + ')' + else if (ConstType = 'LONGWORD') or (ConstType = 'BYTE') or (ConstType = 'WORD') then + Result := '.SetUInt(' + ConstValue + ')' + else if (ConstType = 'EXTENDED') or (ConstType = 'DOUBLE') or (ConstType = 'SINGLE') then + Result := '.setExtended(' + ConstValue + ')' + else + Result := '.SetString(' + ConstValue + ')'; + end; +end; {GetAsString} + +procedure TUnitParser.ParseConstants; +var + ConstName, ConstType, ConstValue, Expression: string; + l: Longint; +begin + Match(CSTII_const); + repeat + try + Match(CSTI_Identifier); + ConstName := PrevOrgToken; + if IfMatch(CSTI_Colon) then + begin + ConstType := OrgToken; + NextToken; + Match(CSTI_Equal); + Expression := ParseConstantExpression(Expression); + end else begin + Match(CSTI_Equal, ':'' or ''='); + Expression := ParseConstantExpression(ConstType); + end; + Match(CSTI_SemiColon); + if UseUnitAtDT then + ConstValue := ConstName + else + ConstValue := Expression; + if ConstType = '' then + ReadLn(ConstType, 'Expression (' + Expression + ') :', 'Unable to determine expression type'); + // now output the value // String( //teo + If ConstType = 'ConstSet' then + fCurrentDTProc.Add(' CL.AddConstantN(''' + ConstName + ''',' + '''LongInt'')' + GetAsString(FastUppercase(ConstType), ConstValue) + ';') + else + fCurrentDTProc.Add(' CL.AddConstantN(''' + ConstName + ''',' + '''' + ConstType + ''')' + GetAsString(FastUppercase(ConstType), ConstValue) + ';'); + except + // Hack: We cannot succesfully parse this, but that doesn't mean we should stop. + on e: Exception do + begin + Writeln('Warning, could not parse const: ' + e.Message); + l := 0; + while TokenId <> CSTI_Eof do + begin + NextToken; + if TokenId = CSTI_OpenBlock then + inc(l) + else if TokenId = CSTI_CloseBlock then + Dec(l) + else if TokenId = CSTI_OpenRound then + inc(l) + else if TokenId = CSTI_CloseRound then + Dec(l) + else if (TokenId = CSTI_SemiColon) and (l <= 0) then + break; + end; + Match(CSTI_Semicolon); + end; + end; + until (TokenID <> CSTI_Identifier); +end; {ParseConstants} + +procedure TUnitParser.ParseVariables; +begin +{todo 3-cWishList : generate wrapper code to allow a script to access a variable} + Match(CSTII_var); + repeat + Match(CSTI_Identifier); + Match(CSTI_Colon); + NextToken; + if IfMatch(CSTI_Equal) then + NextToken; + Match(CSTI_SemiColon); + until (TokenID <> CSTI_Identifier); +end; {ParseVariables} + +function TUnitParser.ParseProcDecl(var ProcName, decl, CallingConvention: string; + Options: TProcDeclOptions; OwnerClass:String=''): TProcDeclInfo; +var + VarListFirst: boolean; + FinishedProcDecl: boolean; + ParamNames: TStringList; + Olddecl, OldProcName, ParamStr, + s, Decl2: string; + Index: integer; + CheckSemiColon: boolean; + Proc: TProcList; +begin + Result := []; + if IfMatch(CSTII_function) then + begin + Include(Result, IsFunction); + decl := 'Function '; + end + else if IfMatch(CSTII_Procedure) then + decl := 'Procedure ' + else if IfMatch(CSTII_Constructor) then + begin + if not (IsMethod in Options) then + RaiseError('Constructor directive only applies to methods: '+OwnerClass, TokenRow, TokenCol); + Include(Result, IsConstructor); + decl := 'Constructor ' + end + else if IfMatch(CSTII_Destructor) then + begin + if not (IsMethod in Options) then + RaiseError('Destructor directive only applies to methods: '+OwnerClass, TokenRow, TokenCol); + Include(Result, IsDestructor); + decl := 'Destructor ' + end + else + Match(CSTII_Procedure, 'Function'' Or ''Procedure'); + + if not (Ispointer in Options) then + begin + Match(CSTI_Identifier); + ProcName := PrevOrgToken; + decl := decl + PrevOrgToken; + end + else + ProcName := ''; + ParamNames := TStringList.create; + try + if IfMatch(CSTI_OpenRound) then + begin + decl := decl + '( '; + while not IfMatch(CSTI_CloseRound) do + begin + if IfMatch(CSTII_var) then + decl := decl + 'var ' + else if Ifmatch(CSTII_out) then //Birb + decl := decl + 'out ' //Birb + else if Ifmatch(CSTII_const) then + decl := decl + 'const '; + // get the list of variable names + VarListFirst := true; + repeat + Match(CSTI_Identifier); + if VarListFirst then + begin + VarListFirst := false; + decl := decl + PrevOrgToken; + end + else + decl := decl + ', ' + PrevOrgToken; + ParamNames.Add(PrevOrgToken); + if TokenID = CSTI_Colon then + Break; + + //-- jgv untyped parameters + if TokenID in [CSTI_CloseRound, CSTI_SemiColon] then begin + Writeln('Untyped Pointers parameters are not supported, this declaration will fail. At position :' + inttostr(TokenRow) + ':' + inttostr(TokenCol)); + if TokenID = CSTI_SemiColon then begin + NextToken; + Continue; + end + else + Break; // jgv untyped parameter + end; + + IfMatch(CSTI_Comma); + until false; + + // jgv untyped parameter + if not (TokenID in [CSTI_CloseRound, CSTI_SemiColon]) then begin + Match(CSTI_Colon); + // get the type + decl := decl + ' : '; + CheckSemiColon := true; + ParseType(TokenID, ProcName, decl, CheckSemiColon); + end; //-- end jgv + + if TokenID = CSTI_Equal then + begin // stip the default part of the varaible declaration + NextToken; + ParseConstantExpression(ParamStr); + end; + if CheckSemiColon and Ifmatch(CSTI_SemiColon) and + (TokenID <> CSTI_CloseRound) then + decl := decl + '; ' + end; + decl := decl + ')'; + end; +// parse the ' : ' part of a function + if IsFunction in Result then + begin + Match(CSTI_Colon); + Match(CSTI_Identifier); + decl := decl + ' : ' + PrevOrgToken; + end; +// parse Calling Conventions & other misc bits that are taken to +// the end of a routine declaration + CallingConvention := 'cdRegister'; + FinishedProcDecl := false; +// check if we are a method pointer + if IsPointer in Options then + begin + if Ifmatch(CSTII_of) then + begin + if (TokenID <> CSTI_Identifier) or + (Token <> 'OBJECT') then + RaiseError('Expecting Token ''Object'' but found ''' + GetTokenName(TokenID) + '''', TokenRow, TokenCol) + else NextToken; + end + else + {todo 1 -cWishList : normal function pointers are not supported by the script, only method pointers} + Decl := ''; + end; + Match(CSTI_Semicolon); + repeat + case TokenID of + CSTII_External: + begin + if (IsPointer in Options) or + (IsMethod in Options) then + RaiseError('External directive only applies to routines ('+OwnerClass + ProcName + ')', TokenRow, TokenCol); + NextToken; + Match(CSTI_Semicolon); + end; + CSTII_Export: + begin + if (IsPointer in Options) or + (IsMethod in Options) then + RaiseError('Export directive only applies to routines (' + OwnerClass +ProcName + ')', TokenRow, TokenCol); + NextToken; + Match(CSTI_Semicolon); + end; + CSTII_Forward: + begin + if (IsPointer in Options) or + (IsMethod in Options) then + RaiseError('Forward directive only applies to routines (' + OwnerClass +ProcName + ')', TokenRow, TokenCol); + NextToken; + Match(CSTI_Semicolon); + end; + CSTII_Override: + begin + if not (IsMethod in Options) then + RaiseError('Override directive only applies to methods (' + OwnerClass +ProcName + ')', TokenRow, TokenCol); + decl := ''; + NextToken; + Match(CSTI_Semicolon); + end; + CSTII_Virtual: + begin + if not (IsMethod in Options) then + RaiseError('Virtual directive only applies to methods (' + OwnerClass +ProcName + ')', TokenRow, TokenCol); + NextToken; + Match(CSTI_Semicolon); + include(Result, IsVirtual); + if Token = 'ABSTRACT' then + begin + NextToken; + Match(CSTI_Semicolon); + include(Result, IsAbstract); + end; + end; + CSTI_Identifier: + begin + // check for calling conversion + if Token = 'MESSAGE' then + begin + if not (IsMethod in Options) then + RaiseError('Override directive only applies to methods (' + OwnerClass +ProcName + ')', TokenRow, TokenCol); + NextToken; + Match(CSTI_Identifier); + Match(CSTI_Semicolon); + end else + if Token = 'DYNAMIC' then + begin + if not (IsMethod in Options) then + RaiseError('Method directive only applies to methods (' + OwnerClass + ProcName + ')', TokenRow, TokenCol); + NextToken; + Match(CSTI_Semicolon); + include(Result, IsVirtual); + if Token = 'ABSTRACT' then + begin + NextToken; + Match(CSTI_Semicolon); + include(Result, IsAbstract); + end; + end else if Token = 'PASCAL' then + begin + CallingConvention := 'cdPascal'; + NextToken; ; + Match(CSTI_Semicolon); + end else if Token = 'REGISTER' then + begin + CallingConvention := 'cdRegister'; + NextToken; + Match(CSTI_Semicolon); + end else if Token = 'CDECL' then + begin + CallingConvention := 'CdCdecl'; + NextToken; + Match(CSTI_Semicolon); + end else if (Token = 'STDCALL') or + (Token = 'SAFECALL') then + begin + // map a safecall to stdcall + // (safecall cause special wrapper code to be implemented client side) + CallingConvention := 'CdStdCall'; + NextToken; + Match(CSTI_Semicolon); + + end else if not (Ispointer in Options) then + begin + if (token = 'OVERLOAD') then + begin +// if (IsPointer in Options) then +// RaiseError('overload directive does not applies to function/method pointers', TokenRow, TokenCol); + Writeln('Overloading isnt supported. Remapping of name required '+OwnerClass +Decl); + OldProcName := ProcName; + Olddecl := decl; + s := ''; + repeat + Readln(ProcName, s+'Current declaration :' + '''' + OwnerClass +decl + '''', 'Enter new name.'); + if ProcName = '' then + ProcName := OldProcName; + // create a tmp procedure to handle the overload (self: + + decl2 := decl; // jgv someone forget it !!! + + If (IsMethod in Options) then + if (Pos('(',decl)=0)then + decl2 := StringReplace(decl, OldProcName, OldProcName+'(Self: '+Ownerclass+')', [rfIgnoreCase]) + else + decl2 := StringReplace(decl, OldProcName+'(', OldProcName+'(Self: '+Ownerclass+'; ', [rfIgnoreCase]); + + decl2 := StringReplace(decl2, OldProcName, OwnerClass+ProcName+'_P', [rfIgnoreCase]); + decl := StringReplace(decl, OldProcName, ProcName, [rfIgnoreCase])+';'; + If (IsConstructor in Result) then begin + decl2 := StringReplace(decl2, 'Constructor', 'Function', [rfIgnoreCase]); + decl2 := StringReplace(decl2, ')', '):TObject', [rfIgnoreCase]); + decl2 := StringReplace(decl2, 'Self: '+Ownerclass, 'Self: TClass; CreateNewInstance: Boolean', [rfIgnoreCase]); + end; + If (IsDestructor in Result) then + decl2 := StringReplace(decl2, 'Destructor', 'Procedure', [rfIgnoreCase]); + decl2 := decl2 +';'; + Proc := RegisterProc(decl2, RunTime, [IsHelper]); + if {not} (IsDone in Proc.ProcAttr) then + begin + If S = '' then + S := 'Procedure name has been used, entre a new one'^m; + ProcName := OldProcName; + decl := Olddecl; + end + else break; + until false; + Include(result,IsCallHelper); + Include(Proc.ProcAttr, IsDone); + Writeln('New Name :''' + ProcName + ''''); + with Proc do + begin + ParamStr := ''; + if ParamNames.count <> 0 then + begin + for Index := 0 to ParamNames.count - 1 do + ParamStr := ParamStr + ', ' + ParamNames[Index]; + end; + system.Delete(ParamStr,1,2); + s := ''; + If (IsFunction in Result) then s := 'Result := '; + If ParamStr <> '' then ParamStr := '('+ParamStr +')'; + If (IsConstructor in Result) then + Add('Begin Result := '+OwnerClass+'.' + OldProcName+ParamStr+'; END;') + else + If (IsMethod in Options) then + Add('Begin '+S+'Self.' + OldProcName+ParamStr+'; END;') + else + Add('Begin '+s+UnitName + '.' + OldProcName +ParamStr+ '; END;'); + end; + end; + NextToken; + Match(CSTI_Semicolon); + end + else + exit; + // get the next token + end; + else FinishedProcDecl := true; + end; + until FinishedProcDecl; + finally + ParamNames.free; + end; +end; {ParseProcDecl} + +procedure TUnitParser.ParseRoutines; +var + decl, ProcName, CallingConvention: string; +begin + AddRequiredUnit('uPSRuntime', RunTime, true); + include(RunTimeProcType, RoutineImporter); + fCurrentRTProc := RegisterProc('procedure RIRegister_' + UnitName + '_Routines(S: TPSExec);', RunTime, [PublicProc]); +// build the function declaration + ParseProcDecl(ProcName, Decl, CallingConvention, []); + if decl <> '' then + begin + fCurrentDTProc.Add(' CL.AddDelphiFunction(''' + decl + ''');'); // teo -undeclared identifier RegisterDelphiFunctionC + fCurrentRTProc.Add(' S.RegisterDelphiFunction(@' + ProcName + ', ''' + ProcName + ''', ' + CallingConvention + ');'); + end; +end; {ParseRoutines} + +procedure TUnitParser.ParseClassOrInterfaceDef(const aClassName: string; const isInterface: boolean); //Birb +var + CurrPos: (cp_private, cp_Protected, cp_public, cp_published); + aClassParent: string; + + procedure ProcessProc; + var + decl, ProcName, callingConvention, PProcname: string; + ProcDeclInfo: TProcDeclInfo; + begin + ProcDeclInfo := ParseProcDecl(ProcName, decl, callingConvention, [IsMethod], aClassName); + if (decl = '') or + (CurrPos in [cp_private, cp_Protected]) or + (IsDestructor in ProcDeclInfo) then + Exit; + + if isInterface then //Birb + fCurrentDTProc.Add(' RegisterMethod(''' + decl + ''', '+callingConvention+');') + else + fCurrentDTProc.Add(' RegisterMethod(''' + decl + ''');'); + + if IsCallHelper in ProcDeclInfo then + PProcName := aClassname + ProcName+'_P' + else + PProcName := aClassname + '.' + ProcName; + + if not isInterface then //Birb + if IsVirtual in ProcDeclInfo then + begin + if IsConstructor in ProcDeclInfo then + fCurrentRTProc.Add(' RegisterVirtualConstructor(@' + + PProcName + ', ''' + ProcName + ''');') + else + begin + if IsAbstract in ProcDeclInfo then + fCurrentRTProc.Add(' RegisterVirtualAbstractMethod(@' + aClassname + + ', @!.' + ProcName + ', ''' + ProcName + ''');') + else + fCurrentRTProc.Add(' RegisterVirtualMethod(@' + PProcName + + ', ''' + ProcName + ''');') + end; + end + else + begin + if IsConstructor in ProcDeclInfo then + fCurrentRTProc.Add(' RegisterConstructor(@' + PProcName + + ', ''' + ProcName + ''');') + else + fCurrentRTProc.Add(' RegisterMethod(@' + PProcName + + ', ''' + ProcName + ''');') + end; + end; {ProcessProc} + + procedure ProcessVar; + var + VarType: string; + + procedure CreateFieldReadFunc(const VarName: string); + begin + with RegisterProc('procedure ' + aClassname + VarName + '_R(Self: ' + aClassname + + '; var T: ' + VarType + ');', RunTime, [Ishelper]) do + begin + if IsDone in ProcAttr then RaiseError('Duplicate reader for field :' + aClassname + VarName, TokenRow, TokenCol); + include(ProcAttr, IsDone); + Add('Begin T := Self.' + VarName + '; end;'); + end; + end; {CreateFieldReadFunc} + + procedure CreateFieldWriteFunc(const VarName: string); + begin + with RegisterProc('procedure ' + aClassname + VarName + '_W(Self: ' + aClassname + + '; const T: ' + VarType + ');', RunTime, [Ishelper]) do + begin + if IsDone in ProcAttr then RaiseError('Duplicate writer for field :' + aClassname + VarName, TokenRow, TokenCol); + include(ProcAttr, IsDone); + Add('Begin Self.' + VarName + ' := T; end;'); + end; + end; {CreateFieldWriteFunc} + var + VarNames: TStringList; + Index: integer; + CheckSemiColon: boolean; + begin {ProcessVar} + VarNames := TStringList.Create; + try + VarNames.Add(OrgToken); + NextToken; + while TokenId = CSTI_Comma do + begin + NextToken; + Match(CSTI_Identifier); + VarNames.Add(PrevorgToken); + end; + Match(CSTI_Colon); + CheckSemiColon := true; + ParseType(TokenID, '', VarType, CheckSemiColon); + if CheckSemiColon then + Match(CSTI_SemiColon); + if CurrPos in [cp_public, cp_published] then + begin + for Index := 0 to Varnames.Count - 1 do + begin + CreateFieldReadFunc(Varnames[Index]); + CreateFieldWriteFunc(Varnames[Index]); + fCurrentDTProc.Add(' RegisterProperty(''' + varnames[Index] + ''', ''' + + vartype + ''', iptrw);'); + if not isInterface then //Birb + fCurrentRTProc.Add(' RegisterPropertyHelper(' + + '@' + aClassname + varnames[Index] + '_R,' + + '@' + aClassname + varnames[Index] + '_W,' + + '''' + varnames[Index] + ''');'); + end; + end; + finally + VarNames.Free; + end; + end; {ProcessVar} + + procedure ProcessProp; + var + ParamTypes: TStringList; + PropertyName: string; + read, write: Boolean; + IsDefaultProp : Boolean; // teo + + function FindProperty: Boolean; + var + e, ReadString: string; + SearchCount: integer; + begin + ReadString := aClassParent; + Result := False; + SearchCount := MaxSearchCount; + while True do + begin + if SearchCount = 0 then RaiseError('While searching for property in property list, the maxium number of searchs allowed was reached', TokenRow, TokenCol); + dec(SearchCount); + e := Ini.ReadString(ReadString, PropertyName, '~'); + if e = '~' then + begin + ReadString := Ini.ReadString(ReadString, 'PARENT-CLASS', ''); + // check in the parent for the property + if ReadString = '' then exit; + end + else + begin + if e = '' then + begin + PropertyName := ''; + Result := True; + exit; + end; + if pos(' ', e) = 0 then exit; + ReadString := copy(e, 1, pos(' ', e) - 1); + Delete(e, 1, length(ReadString) + 1); + ParamTypes.Text := Stringreplace(e, ' ', #13#10, [rfReplaceAll]); + if ReadString = 'READ' then + Read := True + else if ReadString = 'WRITE' then + Write := True + else if ReadString = 'READWRITE' then + begin + Read := True; + Write := True; + end + else exit; + Result := True; + exit; + end; + end; + end; {FindProperty} + + procedure CreateReadFunc(Fake: Boolean); + var + decl: string; + Index: Longint; + begin + decl := 'procedure ' + aClassname + PropertyName + '_R(Self: ' + aClassname + + '; var T: ' + ParamTypes[0]; + for Index := 1 to ParamTypes.Count - 1 do + decl := decl + '; const t' + inttostr(Index) + ': ' + ParamTypes[Index]; + decl := decl + ');'; + with RegisterProc(decl, RunTime, [Ishelper]) do + begin + if IsDone in ProcAttr then RaiseError('Duplicate property :' + aClassname + PropertyName + '_R', TokenRow, TokenCol); + include(ProcAttr, IsDone); + if Fake then Insert(1, '{'); + decl := 'begin T := Self.' + PropertyName; + if ParamTypes.Count > 1 then + begin + decl := decl + '[t1'; + for Index := 2 to ParamTypes.Count - 1 do + decl := decl + ', t' + inttostr(Index); + decl := decl + ']'; + end; + Add(decl + '; end;'); + if Fake then Add('}'); + end; + end; {CreateReadFunc} + + procedure CreateWriteFunc(Fake: Boolean); + var + decl: string; + Index: Longint; + begin + decl := 'procedure ' + aClassname + PropertyName + '_W(Self: ' + aClassname + + '; const T: ' + ParamTypes[0]; + for Index := 1 to ParamTypes.Count - 1 do + decl := decl + '; const t' + inttostr(Index) + ': ' + ParamTypes[Index]; + decl := decl + ');'; + with RegisterProc(decl, RunTime, [Ishelper]) do + begin + if IsDone in ProcAttr then RaiseError('Duplicate property :' + aClassname + PropertyName + '_W', TokenRow, TokenCol); + include(ProcAttr, IsDone); + if Fake then Insert(1, '{'); + decl := 'begin Self.' + PropertyName; + if ParamTypes.Count > 1 then + begin + decl := decl + '[t1'; + for Index := 2 to ParamTypes.Count - 1 do + decl := decl + ', t' + inttostr(Index); + decl := decl + ']'; + end; + Add(decl + ' := T; end;'); + if Fake then Add('}'); + end; + end; {CreateWriteFunc} + + var + Readstr, Writestr, decl: string; + ParamCount: Longint; + + begin {ProcessProp} + IsDefaultProp := False; + ParamTypes := TStringList.Create; + try + NextToken; + Match(CSTI_Identifier); + PropertyName := PrevOrgToken; + case TokenId of + CSTI_Semicolon: + begin // A property is being introduced that is present in the parent object + NextToken; + if FindProperty then + begin + if (PropertyName = '') or + not (CurrPos in [cp_public, cp_published]) then Exit; + decl := trim(StringReplace(ParamTypes.Text, NewLine, ' ', [rfreplaceAll])); + // build the design time declaration + decl := ' RegisterProperty(''' + PropertyName + ''', ''' + decl + ''', ipt'; + if Read then decl := decl + 'r'; + if Write then decl := decl + 'w'; + fCurrentDTProc.Add(decl + ');'); + if CurrPos <> cp_published then + begin + // write out the runtime version + if Read then + begin // create the helper function to read from the property + CreateReadFunc(False); + Readstr := '@' + aClassName + PropertyName + '_R'; + end + else Readstr := 'nil'; + if Write then + begin // create the helper function to write to the property + CreateWriteFunc(False); + Writestr := '@' + aClassName + PropertyName + '_W'; + end + else Writestr := 'nil'; + // select which Property helper to use (relys on events following the syntax (ON...)) + if copy(PropertyName, 1, 2) <> 'ON' then + decl := ' RegisterPropertyHelper(' + else + decl := ' RegisterEventPropertyHelper('; + if not isInterface then //Birb + fCurrentRTProc.Add(decl + Readstr + ',' + Writestr + ',''' + PropertyName + ''');') + end; + end + else if PropertyName <> '' then + Exit; + end; + CSTI_OpenBlock: + begin // a pseudo array (indexed) property + NextToken; + while TokenID <> CSTI_CloseBlock do + begin + ParamCount := 0; + repeat + if (TokenID = CSTII_Const) + or (TokenID = CSTII_Var) + or (TokenID = CSTII_Out) //Birb + then + NextToken; + Match(CSTI_Identifier); + inc(ParamCount); + if TokenID = CSTI_Comma then + NextToken + else Break; + until False; + Match(CSTI_Colon); + Match(CSTI_Identifier); + while ParamCount > 0 do + begin + ParamTypes.Add(PrevOrgToken); + Dec(ParamCount); + end; + if TokenId = CSTI_Semicolon then + begin + NextToken; + Continue; + end; + end; + NextToken; + end; + end; + + //-- jgv reintroduce a property specifier + if token = 'STORED' then begin + If (CurrPos <> cp_published) then Exit; + NextToken; + Match(CSTI_Identifier); + If TokenID = CSTI_SemiColon then begin + Match (CSTI_SemiColon); + Exit; + end; + end; + + if Token = 'DEFAULT' then + begin + NextToken; + while TokenID <> CSTI_Semicolon do + NextToken; + NextToken; + if FindProperty then + begin + if (PropertyName = '') or + not (CurrPos in [cp_public, cp_published]) then Exit; + decl := trim(StringReplace(ParamTypes.Text, NewLine, ' ', [rfreplaceAll])); + // build the design time declaration + decl := ' RegisterProperty(''' + PropertyName + ''', ''' + decl + ''', ipt'; + if Read then decl := decl + 'r'; + if Write then decl := decl + 'w'; + fCurrentDTProc.Add(decl + ');'); + if CurrPos <> cp_published then + begin + // write out the runtime version + if Read then + begin // create the helper function to read from the property + CreateReadFunc(False); + Readstr := '@' + aClassName + PropertyName + '_R'; + end + else Readstr := 'nil'; + if Write then + begin // create the helper function to write to the property + CreateWriteFunc(False); + Writestr := '@' + aClassName + PropertyName + '_W'; + end + else Writestr := 'nil'; + // select which Property helper to use (relys on events following the syntax (ON...)) + if copy(PropertyName, 1, 2) <> 'ON' then + decl := ' RegisterPropertyHelper(' + else + decl := ' RegisterEventPropertyHelper('; + if not isInterface then //Birb + fCurrentRTProc.Add(decl + Readstr + ',' + Writestr + ',''' + PropertyName + ''');') + end; + end + else if PropertyName <> '' then + Exit; + end; + Match(CSTI_Colon); + Match(CSTI_Identifier); + ParamTypes.Insert(0, PrevOrgToken); + // handle various property declarations + read := false; write := false; + + //-- 20050707_jgv + if Token = 'INDEX' then begin + NextToken; + Match (CSTI_Integer); + end; + //-- end jgv + + if Token = 'READ' then + begin + repeat + NextToken; Match(CSTI_Identifier); + until TokenID <> CSTI_Period; + read := true; + end; + if Token = 'WRITE' then + begin + repeat + NextToken; Match(CSTI_Identifier); + until TokenID <> CSTI_Period; + Write := true; + end; + if TokenID = CSTI_SemiColon then + NextToken + else + begin + if (Token = 'STORED') then + begin + NextToken; + NextToken; // skip this + if TokenId = CSTI_Semicolon then + Match(CSTI_Semicolon); + end; + if (Token = 'DEFAULT') then + begin + NextToken; + while TokenID <> CSTI_Semicolon do + NextToken; + Match(CSTI_SemiColon); + end; + end; + if Token = 'DEFAULT' then + begin + IsDefaultProp := True; + NextToken; + Match(CSTI_Semicolon); + end; + if UseUnitAtDT and (CurrPos <> cp_public) or + not (CurrPos in [cp_public, cp_published]) then + exit; + decl := trim(StringReplace(ParamTypes.Text, NewLine, ' ', [rfreplaceAll])); + // build the design time declaration + decl := ' RegisterProperty(''' + PropertyName + ''', ''' + decl + ''', ipt'; + if Read then decl := decl + 'r'; + if Write then decl := decl + 'w'; + fCurrentDTProc.Add(decl + ');'); + // write out the runtime version + if Read then + begin // create the helper function to read from the property + CreateReadFunc(False); + Readstr := '@' + aClassName + PropertyName + '_R'; + end + else Readstr := 'nil'; + if Write then + begin // create the helper function to write to the property + CreateWriteFunc(False); + Writestr := '@' + aClassName + PropertyName + '_W'; + end + else Writestr := 'nil'; + // select which Property helper to use (relys on events following the syntax (ON...)) + if copy(PropertyName, 1, 2) <> 'ON' then + decl := ' RegisterPropertyHelper(' + else + decl := ' RegisterEventPropertyHelper('; + if not isInterface then //Birb + fCurrentRTProc.Add(decl + Readstr + ',' + Writestr + ',''' + PropertyName + ''');'); + + if IsDefaultProp then //teo + fCurrentDTProc.Add(' SetDefaultPropery(''' + PropertyName + ''');'); + + finally + ParamTypes.Free; + end; + end; {ProcessProp} + +var + OldDTProc, OldRTProc: TProcList; +begin {ParseClassDef} + if isInterface //Birb + then Match(CSTII_interface) //Birb + else Match(CSTII_class); +//CreateRegClasProc; +// check for forward declaration + if TokenID = CSTI_Semicolon then + begin +// NextToken; the semicolon is removed by the caller + if UseUnitAtDT then + if isInterface //Birb + then fCurrentDTProc.Add(' CL.AddInterface(CL.FindInterface('''+STR_IINTERFACE+'''),' + aClassname + ', '''+aClassname+''');') //this is a forward declaration that will be overriden later on + else fCurrentDTProc.Add(' CL.AddClass(CL.FindClass(''TOBJECT''),' + aClassname + ');') + else + if isInterface //Birb + then fCurrentDTProc.Add(' CL.AddInterface(CL.FindInterface('''+STR_IINTERFACE+'''),' + aClassname + ', '''+aClassname+''');') //this is a forward declaration that will be overriden later on + else fCurrentDTProc.Add(' CL.AddClassN(CL.FindClass(''TOBJECT''),''' + aClassname + ''');'); + if isInterface then //Birb + Include(RuntimeProcType, InterfaceImporter) //Birb + else //Birb + begin //Birb + if fCurrentRTProc = nil then + begin + Include(RunTimeProcType, ClassImporter); + fCurrentRTProc := RegisterProc('procedure RIRegister_' + UnitName + + '(CL: TPSRuntimeClassImporter);', RunTime, [PublicProc]); + end; + fCurrentRTProc.Add(' with CL.Add(' + aClassname + ') do'); + end; //Birb + exit; + end + + else if IfMatch(CSTII_of) then + begin + Match(CSTI_Identifier); + //teo --compiler complains when it comes to register a TClass type + fCurrentDTProc.Add(' //CL.AddTypeS(''' + aClassname + ''', ''class of ' + PrevOrgToken + ''');'); + exit; + end + + else if IfMatch(CSTI_OpenRound) then + begin + Match(CSTI_Identifier); + aClassParent := PrevOrgToken; + + if not isInterface then + while IfMatch(CSTI_Comma) do + Match(CSTI_Identifier); //Birb (ignore possible list of implemented interfaces after class ancestor) + + Match(CSTI_CloseRound); + + /////////////////// + + if TokenId = CSTI_Semicolon then //??? //Birb: I think this is an impossible case! + begin + if UseUnitAtDT then + if isInterface //Birb + then fCurrentDTProc.Add(' CL.AddInterface(CL.FindInterface(''IUNKNOWN''),' + aClassname + ', '''+aClassname+''');') + else fCurrentDTProc.Add(' CL.AddClass(CL.FindClass(''TOBJECT''),' + aClassname + ');') + else + if isInterface //Birb + then fCurrentDTProc.Add(' CL.AddInterface(CL.FindInterface(''IUNKNOWN''),' + aClassname + ', '''+aClassname+''');') + else fCurrentDTProc.Add(' CL.AddClassN(CL.FindClass(''TOBJECT''),''' + aClassname + ''');'); + if isInterface then //Birb + Include(RuntimeProcType, InterfaceImporter) //Birb + else //Birb + begin //Birb + if fCurrentRTProc = nil then + begin + Include(RunTimeProcType, ClassImporter); + fCurrentRTProc := RegisterProc('procedure RIRegister_' + UnitName + + '(CL: TPSRuntimeClassImporter);', RunTime, [PublicProc]); + end; + fCurrentRTProc.Add(' with CL.Add(' + aClassname + ') do'); + end; //Birb + exit; + end; + + /////////////////// + + end + + else + if isInterface //Birb + then aClassParent := STR_IINTERFACE //Birb (Delphi interfaces descent from IInterface if no ancestor is specified) + else aClassParent := 'TOBJECT'; + + if isInterface then //Birb + begin //Birb + Include(RuntimeProcType, InterfaceImporter); //Birb + OldRTProc := fCurrentRTProc; //Birb (using to avoid compiler warning later on - maybe can just use "nil" here) + end //Birb + else //Birb + begin //Birb + if fCurrentRTProc = nil then + begin + Include(RunTimeProcType, ClassImporter); + fCurrentRTProc := RegisterProc('procedure RIRegister_' + UnitName + + '(CL: TPSRuntimeClassImporter);', RunTime, [PublicProc]); + end; + OldRTProc := fCurrentRTProc; + fCurrentRTProc := RegisterProc('procedure RIRegister_' + aClassname + + '(CL: TPSRuntimeClassImporter);', RunTime, [PublicProc]); + fCurrentRTProc.Add(' with CL.Add(' + aClassname + ') do'); + fCurrentRTProc.Add(' begin'); + end; //Birb + + OldDTProc := fCurrentDTProc; + fCurrentDTProc := RegisterProc('procedure SIRegister_' + aClassname + + '(CL: TPSPascalCompiler);', CompileTime, [PublicProc]); + if UseUnitAtDT then + begin + AddRequiredUnit(UnitName, CompileTime, false); + + if isInterface //Birb + then fCurrentDTProc.Add(' with CL.AddInterface(CL.FindInterface(''' + aClassParent + '''),' + aClassname + ', '''+aClassname+''') do') + else fCurrentDTProc.Add(' with CL.AddClass(CL.FindClass(''' + aClassParent + '''),' + aClassname + ') do'); + fCurrentDTProc.Add(' begin'); + + if not isInterface then //Birb (note that Delphi does support interface properties, but on only for Delphi objects, not external objects [!!!should fix uPSCompiler to support that too - with some RegisterProperties method, since there's no published section at interface declarations]) + fCurrentDTProc.Add(' RegisterPublishedProperties;'); + end + else + begin + if isInterface then //Birb + begin + fCurrentDTProc.Add(' //with RegInterfaceS(CL,''' + aClassParent + ''', ''' + aClassname + ''') do'); //Birb + fCurrentDTProc.Add(' with CL.AddInterface(CL.FindInterface(''' + aClassParent + '''),' + aClassname + ', '''+aClassname+''') do') + end + else + begin + fCurrentDTProc.Add(' //with RegClassS(CL,''' + aClassParent + ''', ''' + aClassname + ''') do'); // teo + fCurrentDTProc.Add(' with CL.AddClassN(CL.FindClass(''' + aClassParent + '''),''' + aClassname + ''') do'); + end; + fCurrentDTProc.Add(' begin'); + end; + CurrPos := cp_public; + + if isInterface then //Birb + if not IfMatch(CSTI_OpenBlock) then //Birb: GUID string needed at interface declarations cause "CL.AddInterface" has a TGUID parameter above (!!!should have a PGUID so that we could maybe pass nil to it - else maybe should see if '' is accepted for a TGUID and peek ahead to see if a GUID is available, else use '') + RaiseError('Found ''' + GetTokenName(TokenID) + ''' instead of [''GUID-string'']', TokenRow, TokenCol) + else + begin //Birb: ignore ['GUID-string'] + Match(CSTI_String); + Match(CSTI_CloseBlock); + end; + + while not IfMatch(CSTII_End) do + case TokenID of + CSTII_Private: + begin + CurrPos := cp_private; + NextToken; + end; + CSTII_Protected: + begin + CurrPos := cp_Protected; + NextToken; + end; + CSTII_Public: + begin + CurrPos := cp_public; + NextToken; + end; + CSTII_Published: + begin + CurrPos := cp_published; + NextToken; + end; + CSTII_Procedure, CSTII_Function, CSTII_Constructor, CSTII_Destructor: + ProcessProc; + CSTI_Identifier: + ProcessVar; + CSTII_Property: + if isInterface then //Birb + begin + skipToSemicolon; //Birb (note that Delphi does support interface properties, but on only for Delphi objects, not external objects [!!!should fix uPSCompiler to support that too]) + if Token='DEFAULT' then //Birb: ignore optional "default;" specifier that may follow indexed/array properties + begin + NextToken; + Match(CSTI_SemiColon); + end + end + else + ProcessProp; //Birb: (!!!) do check if this works ok with "default;" specifier for indexed/array property declarations (since that one is after the property declaration's ending ";") + + CSTII_Class: + begin + // jgv: class procedure/function + NextToken; + If Not (TokenID in [CSTII_Procedure, CSTII_Function]) then + RaiseError ('class must be followed by "function" or "procedure"', TokenRow, TokenCol); + end; + + else RaiseError('Unknown keyword ''' + GetTokenName(TokenID) + '''', TokenRow, TokenCol); + + end; + if not isInterface then //Birb + fCurrentRTProc.Add(' end;'); + fCurrentDTProc.Add(' end;'); + if OldDTProc <> nil then + fCurrentDTProc := OldDTProc; + fCurrentDTProc.Add(' SIRegister_' + aClassname + '(CL);'); + if not isInterface then //Birb + begin + if OldRTProc <> nil then + fCurrentRTProc := OldRTProc; + fCurrentRTProc.Add(' RIRegister_' + aClassname + '(CL);'); + end; +end; {ParseClassOrInterfaceDef} //Birb + +procedure TUnitParser.ParseInterfaceDef(const aInterfaceName: string); +begin +{ Writeln('Interface Declaration not suported at position: ' + Inttostr(TokenRow) + ':' + Inttostr(TokenCol)); + while not (TokenId in [CSTI_EOF, CSTII_End]) do + NextToken; + NextToken; // skip the END +//todo 4 -cRequired : Allow parsing of interfaces +} + ParseClassOrInterfaceDef(aInterfaceName,true); //Birb +end; {ParseInterfaceDef} + +procedure TUnitParser.ParseClassDef(const aClassName: string); //Birb +begin + ParseClassOrInterfaceDef(aClassName,false); //Birb +end; {ParseClassDef} //Birb + +procedure TUnitParser.ParseType(aTokenID: TPSPasToken; + const TypeName: string; + var TypeDescriptor: string; + var CheckSemiColon: boolean); +var + S: string; + b: boolean; +begin + CheckSemiColon := True; + case aTokenID of + CSTI_Integer: // range + begin + TypeDescriptor := TypeDescriptor + 'Integer'; + while not (TokenId in [CSTI_EOF, CSTI_Semicolon]) do + begin + NextToken; + end; + Match(CSTI_Semicolon); + CheckSemicolon := False; + end; + CSTI_Identifier: // simple type by name (MyInt = Integer) + begin + Match(CSTI_Identifier); + TypeDescriptor := TypeDescriptor + PrevOrgToken; + end; + CSTI_Dereference: // ie 'PInteger = ^Integer' + begin { todo 3-cWishList : When pointers are supported by ROPPS, supported them or provide emulation } + Match(CSTI_Dereference); + TypeDescriptor := TypeDescriptor + ' ^'; + ParseType(CSTI_Identifier, TypeName, TypeDescriptor, CheckSemiColon); + Writeln('Pointers are not supported, this declaration will fail. At position :' + inttostr(TokenRow) + ':' + inttostr(TokenCol)); + TypeDescriptor := TypeDescriptor + ' // will not work'; + end; + CSTII_type: // type identity (MyInt = type Integer) + begin + Match(CSTII_type); +// TypeDescriptor := TypeDescriptor + 'type'; + ParseType(CSTI_Identifier, TypeName, TypeDescriptor, CheckSemiColon); + end; + CSTII_procedure, + CSTII_function: // parse a routine/method pointer + begin + ParseProcDecl(S, TypeDescriptor, S, [IsPointer]); + CheckSemiColon := false; + end; + CSTI_OpenRound: // enums (somename,somename2,..) + begin + Match(CSTI_OpenRound); + TypeDescriptor := TypeDescriptor + '( '; + b := false; + repeat + Match(CSTI_Identifier); + if b then + TypeDescriptor := TypeDescriptor + ', ' + PrevOrgToken + else + begin + b := true; + TypeDescriptor := TypeDescriptor + PrevOrgToken; + end; + if TokenID = CSTI_CloseRound then + begin + NextToken; + TypeDescriptor := TypeDescriptor + ' ) '; + break; + end + else + Match(CSTI_Comma); + until false; + end; + CSTII_record: // records (rec = record a : integer; end;) + begin + Match(CSTII_record); + TypeDescriptor := TypeDescriptor + 'record '; + b := false; + while TokenID = CSTI_Identifier do + begin + TypeDescriptor := TypeDescriptor + OrgToken + ' : '; + NextToken; + Match(CSTI_Colon); + ParseType(TokenId, TypeName, TypeDescriptor, CheckSemiColon); + if TypeDescriptor = '' then + b := true; // invalidat this type + Match(CSTI_SemiColon); + TypeDescriptor := TypeDescriptor + '; '; + end; + TypeDescriptor := TypeDescriptor + 'end '; + if b then TypeDescriptor := ''; + Match(CSTII_end); + end; + CSTII_set: // sets (set of (...)) + begin // parse a set declaration + Match(CSTII_set); + Match(CSTII_of); + TypeDescriptor := TypeDescriptor + 'set of '; + ParseType(TokenID, TypeName, TypeDescriptor, CheckSemiColon); + + { todo 1 -cWishList : When Sets are supported by ROPS, supported them } +// RaiseError('Sets are not supported',TokenPos); + end; + CSTII_array: // arrays (array [..] of ...) + begin + Match(CSTII_array); + b := false; + TypeDescriptor := TypeDescriptor + 'array '; + if Ifmatch(CSTI_OpenBlock) then + begin + TypeDescriptor := TypeDescriptor + '[ ' + ParseConstantExpression(S); + if IfMatch(CSTI_TwoDots) then + begin +// Match(CSTI_Period, '..'); + TypeDescriptor := TypeDescriptor + ' .. ' + ParseConstantExpression(S); + end; + TypeDescriptor := TypeDescriptor + '] '; + Match(CSTI_CloseBlock); + { TODO 1 -cWishList : When static arrays are supported by ROPS, supported them } + b := true; + end; + Match(CSTII_of); + TypeDescriptor := TypeDescriptor + 'of '; + //-- jgv parse array of const + If TokenID = CSTII_const then begin + TypeDescriptor := TypeDescriptor + 'const'; + NextToken; + end + else + //-- end jgv + Parsetype(TokenID, TypeName, TypeDescriptor, CheckSemiColon); + + if b then TypeDescriptor := ''; + end; + CSTII_Interface: // interfaces ( objectname = Interface ... end) + begin + TypeDescriptor := ''; // suppresses the default register action +// Writeln('Interfaces are not supported. At position :'+inttostr(TokenPos)); + ParseInterfaceDef(TypeName); + end; + CSTII_class: // classes ( objectname = class ... end) + begin + TypeDescriptor := ''; // suppresses the default register action + ParseClassDef(TypeName); + end; + else RaiseError('Expecting valid type, but found ''' + GetTokenName(TokenID) + '''', TokenRow, TokenCol); + end; +end; {ParseType} +(*----------------------------------------------------------------------------*) +procedure TUnitParser.ParseTypes; +var + TypeName : string; + TypeDescriptor, tmp : string; + CheckSemiColon : boolean; + Len, Index : integer; +begin {ParseTypes} + Match(CSTII_type); + repeat + // get the type name + Match(CSTI_Identifier); + TypeName := PrevOrgToken; + Match(CSTI_equal); + + // build the type discriptor + TypeDescriptor := ''; + ParseType(TokenID, TypeName, TypeDescriptor, CheckSemiColon); + if CheckSemiColon then + Match(CSTI_SemiColon); + if (TypeDescriptor <> '') then + begin + TypeDescriptor := trim(TypeDescriptor); + // break up the TypeDescriptor to make it fit with in 80 characters per line + tmp := ' CL.AddTypeS(''' + TypeName + ''', '''; + Len := Length(tmp) + length(TypeDescriptor) + 3; + if Len <= 80 then + fCurrentDTProc.Add(tmp + TypeDescriptor + ''');') + else + begin + Len := 79 - Length(tmp); + fCurrentDTProc.Add(tmp); + if Len > 0 then + begin + tmp := copy(TypeDescriptor, 1, Len); + Delete(TypeDescriptor, 1, Len); + Index := fCurrentDTProc.count - 1; + fCurrentDTProc[Index] := fCurrentDTProc[Index] + tmp + ''''; + end + else + begin + fCurrentDTProc.Add(' +''' + copy(TypeDescriptor, 1, 74) + ''''); + Delete(TypeDescriptor, 1, 74); + end; + while TypeDescriptor <> '' do + begin + fCurrentDTProc.Add(' +''' + copy(TypeDescriptor, 1, 74) + ''''); + Delete(TypeDescriptor, 1, 74); + end; + Index := fCurrentDTProc.count - 1; + fCurrentDTProc[Index] := fCurrentDTProc[Index] + ');'; + end; + end; + until (TokenID <> CSTI_Identifier); +end; {ParseTypes} + + + +procedure TUnitParser.ParserError(Parser: TObject; + Kind: TPSParserErrorKind); +var + S: string; +begin + Writeln('Error parsing file'); + case Kind of + iCommentError: S := 'Comment'; + iStringError: S := 'String'; + iCharError: S := 'Char'; + iSyntaxError: S := 'Syntax'; + end; + Writeln(S + ' Error, Position :' + Inttostr(TPSPascalParser(Parser).Row) + ':' + IntToStr(TPSPascalParser(Parser).Col)); +end; + +end. diff --git a/unit-importing/ParserUtils.pas b/unit-importing/ParserUtils.pas new file mode 100644 index 0000000..dc98e38 --- /dev/null +++ b/unit-importing/ParserUtils.pas @@ -0,0 +1,173 @@ +unit ParserUtils; + +interface +uses uPSUtils, SysUtils, Classes; + +const + version = 'v0.7'; + +procedure RaiseError(const errormsg: string; row, col: integer); +function GetLicence: string; + +function GetUsedUnitList(list: Tstringlist): string; + +function GetTokenName(TokenID: TPSPasToken): string; + +const + NewLine = #13#10; + +implementation + + +function GetTokenName(TokenID: TPSPasToken): string; +begin + case TokenID of + {Items that are used internally} + CSTIINT_Comment: Result := 'Comment(should not encountered)'; + CSTIINT_WhiteSpace: Result := 'WhiteSpace(should not encountered)'; + {Tokens} + CSTI_EOF: Result := 'End Of File'; + CSTI_Identifier: Result := 'Identifier'; + CSTI_SemiColon: Result := ';'; + CSTI_Comma: Result := ','; + CSTI_Period: Result := ';'; + CSTI_Colon: Result := ':'; + CSTI_OpenRound: Result := '('; + CSTI_CloseRound: Result := ')'; + CSTI_OpenBlock: Result := '['; + CSTI_CloseBlock: Result := ']'; + CSTI_Assignment: Result := ':='; + CSTI_Equal: Result := '='; + CSTI_NotEqual: Result := '<>'; + CSTI_Greater: Result := '>'; + CSTI_GreaterEqual: Result := '>='; + CSTI_Less: Result := '<'; + CSTI_LessEqual: Result := '<='; + CSTI_Plus: Result := '+'; + CSTI_Minus: Result := '-'; + CSTI_Divide: Result := '/'; + CSTI_Multiply: Result := '*'; + CSTI_Integer: Result := 'Integer'; + CSTI_Real: Result := 'Floatpoint'; + CSTI_String: Result := 'string'; + CSTI_Char: Result := 'Character'; + CSTI_HexInt: Result := 'Hexadecimal'; + CSTI_AddressOf: Result := '@'; + CSTI_Dereference: Result := '^'; + CSTI_TwoDots : Result := '..'; + {Identifiers} + CSTII_and: Result := 'and'; + CSTII_array: Result := 'array'; + CSTII_begin: Result := 'begin'; + CSTII_case: Result := 'case'; + CSTII_const: Result := 'const'; + CSTII_div: Result := 'div'; + CSTII_do: Result := 'do'; + CSTII_downto: Result := 'downto'; + CSTII_else: Result := 'else'; + CSTII_end: Result := 'end'; + CSTII_for: Result := 'for'; + CSTII_function: Result := 'function'; + CSTII_if: Result := 'if'; + CSTII_in: Result := 'in'; + CSTII_mod: Result := 'mod'; + CSTII_not: Result := 'not'; + CSTII_of: Result := 'of'; + CSTII_or: Result := 'or'; + CSTII_procedure: Result := 'procedure'; + CSTII_program: Result := 'program'; + CSTII_repeat: Result := 'repeat'; + CSTII_record: Result := 'record'; + CSTII_set: Result := 'set'; + CSTII_shl: Result := 'shl'; + CSTII_shr: Result := 'shr'; + CSTII_then: Result := 'then'; + CSTII_to: Result := 'to'; + CSTII_type: Result := 'type'; + CSTII_until: Result := 'until'; + CSTII_uses: Result := 'uses'; + CSTII_var: Result := 'var'; + CSTII_out: Result := 'out'; //Birb + CSTII_while: Result := 'while'; + CSTII_with: Result := 'with'; + CSTII_xor: Result := 'xor'; + CSTII_exit: Result := 'exit'; + CSTII_class: Result := 'class'; + CSTII_constructor: Result := 'constructor'; + CSTII_destructor: Result := 'destructor'; + CSTII_inherited: Result := 'inherited'; + CSTII_private: Result := 'private'; + CSTII_public: Result := 'public'; + CSTII_published: Result := 'published'; + CSTII_protected: Result := 'protected'; + CSTII_property: Result := 'property'; + CSTII_virtual: Result := 'virtual'; + CSTII_override: Result := 'override'; + //CSTII_default: Result := 'default'; //Birb + CSTII_As: Result := 'as'; + CSTII_Is: Result := 'is'; + CSTII_Unit: Result := 'unit'; + CSTII_Try: Result := 'try'; + CSTII_Except: Result := 'except'; + CSTII_Finally: Result := 'finally'; + CSTII_External: Result := 'external'; + CSTII_Forward: Result := 'forward'; + CSTII_Export: Result := 'export'; + CSTII_Label: Result := 'label'; + CSTII_Goto: Result := 'goto'; + CSTII_Chr: Result := 'char'; + CSTII_Ord: Result := 'ord'; + CSTII_Interface: Result := 'interface'; + CSTII_Implementation: Result := 'Implementation'; + else + Result := '[Unknown Token name]'; + end; +end; {GetTokenName} + +function GetUsedUnitList(list: Tstringlist): string; +var + index: integer; + charcount: integer; + s: string; +begin + if (list <> nil) and (list.Count <> 0) then + begin + Result := 'Uses ' + list[0]; + charcount := length(result); + for index := 1 to list.Count - 1 do + begin + s := list[index]; + inc(charcount, length(s)); + if charcount < 80 then + Result := Result + ', ' + s + else + begin + Result := Result + ', ' + NewLine + s; + charcount := 0; + end; + end; + Result := Result + ';'; + end + else + Result := ''; +end; {GetUsedUnitList} + +procedure RaiseError(const errormsg: string; row, col: integer); +begin + raise Exception.create(errormsg + ' At postion: ' + inttostr(row) + ':' + inttostr(col)); +end; {RaiseError} + +function GetLicence: string; +begin + result := + '{' + NewLine + + 'This file has been generated by UnitParser ' + version + ', written by M. Knight' + Newline + + 'and updated by NP. v/d Spek and George Birbilis. ' + Newline + + 'Source Code from Carlo Kok has been used to implement various sections of' + Newline + + 'UnitParser. Components of ROPS are used in the construction of UnitParser,' + Newline + + 'code implementing the class wrapper is taken from Carlo Kok''s conv utility' + Newline + + Newline + + '}'; +end; {GetLicence} + +end. diff --git a/unit-importing/TB_ReadMe.txt b/unit-importing/TB_ReadMe.txt new file mode 100644 index 0000000..1a8b989 --- /dev/null +++ b/unit-importing/TB_ReadMe.txt @@ -0,0 +1,56 @@ + +A modified UnitParser which creates a single import unit +--------------------------------------------------------- + IFPS3 1.21 + Delphi 7 Enterprise +--------------------------------------------------------- + +Hi there + +I've modified the "imp" application a little. +The "imp" application is written by M. Knight. + +Mainly I've added the private + procedure FinishParseSingleUnit; +to the ParserU.TUnitParser + +Now the UnitParser, (if the -added property- +SingleUnit is True), creates a single import unit file +after parsing the source file. + +The produced import file is given the name + UnitPrefix + '_' + SourceUnitName + '.pas' +when SingleUnit is True + +Also the + procedure TUnitParser.SaveToPath(const Path: string); +is added in order to save the produced file +(or files if SingleUnit is False) + +When SingleUnit is True the produced import file +contains + the compile-time registration code + the run-time registration code + and a TIFPS3Plugin descendant, say TImport_XXX, +which imports the registration code + +In order to use the produced import file, add +its name to a uses clause and then code + XXX_Importer := TImport_XXX.Create(Self); + TIFPS3CEPluginItem(Debugger.Plugins.Add).Plugin := XXX_Importer; +or just install TImport_XXX as a component, +drop it on a form, etc. etc... + +I prefer the first method since it's more flexible +and I modify my units all the time. + +Also, I've created an import file for the DBClient.pas +since I use the TClientDataset too often. +The DBClientImport folder contains the -truncated- +source of the DBClient.pas (that's all the code I import) +and the produced import file. You may take a look. + + +Theo Bebekis +teo@epektasis.gr + diff --git a/unit-importing/UFrmGotoLine.dfm b/unit-importing/UFrmGotoLine.dfm new file mode 100644 index 0000000000000000000000000000000000000000..e41c5f809e99a69ffa8c74451f4e81a15437bcd0 GIT binary patch literal 802 zcmaKq-)_?|7{y(OCQXyDA#uSSk+??#i5u?LwCN_LP1P9f1_Vy>b+P2wljCaTIe=H; z!FT~^{xscIiL2PLzTf%I(fK<@BwR1%F^Qw=ysvK0JzjLrgX*Fe(%Udg;cbZ9Ij_10qC zZ&--{IQ$cl9ph4i^NZ;sQd&J+qCn|)((0e^E^;MHN>@-kr|7mkoVRol&Y*x z-iqyjS1VB0A}jE2Tq|`N=g1@xO@Vtn<+ab{woE}aG2xeWO8CXFafu`IFw^Jb)DwO? zf*z7;b? z>Hu*62S5l}WU|#-3akCRYnu}{&B5huV)621f b then Result := a + else Result := b; +end; + +//------------------------------------------------------------------------------ +// check if two StringLists contain identical strings +//------------------------------------------------------------------------------ +function ListIdentical(l1,l2:TStringList):Boolean; +var + ix : Integer; +begin + Result := False; + if l1.count = l2.count then + begin + for ix := 0 to l1.count-1 do + begin + if (l1[ix] <> l2[ix]) then Exit; + end; + Result := True; + end; +end; + +{........................................................................... } +{ class TCommaSeparatedInfo } +{........................................................................... } + +constructor TCommaSeparatedInfo.Create; +begin + FValues := TStringList.Create; +end; + +destructor TCommaSeparatedInfo.Destroy; +begin + FValues.Free; + inherited; +end; + +function TCommaSeparatedInfo.GetBoolean(index: Integer): Boolean; +begin + // '1' stands for 'true', any other value for 'false' + Result := (Element[index] = '1'); +end; + +function TCommaSeparatedInfo.GetElement(index: Integer): String; +begin + result := FValues[index]; +end; + +function TCommaSeparatedInfo.GetInteger(index: Integer): Integer; +begin + Result := StrToIntDef(Element[index],-1); +end; + +function TCommaSeparatedInfo.GetValue: String; +begin + result := FValues.CommaText; +end; + +procedure TCommaSeparatedInfo.SetBoolean(index: Integer; + const Value: Boolean); +const + BoolText: array[Boolean] of string[1] = ('', '1'); +begin + SetElement(index, BoolText[Value]); +end; + +procedure TCommaSeparatedInfo.SetElement(index: Integer; + const Value: String); +begin + while (FValues.Count -1) < Index do FValues.Add(''); + FValues[index] := Value; +end; + +procedure TCommaSeparatedInfo.SetInteger(index: Integer; + const Value: Integer); +begin + SetElement(index, IntToStr(Value)); +end; + +procedure TCommaSeparatedInfo.SetValue(const Value: String); +begin + FValues.CommaText := Value; +end; + +{........................................................................... } +{ class TSectionList } +{........................................................................... } + +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ create new instance } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +constructor TSectionList.Create; +begin + inherited Create; + FPrevIndex := 0; +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ access to property SectionItems } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +function TSectionList.GetSectionItems(index: Integer): TStringList; +begin + Result := TStringList(Objects[index]); +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ erase duplicate entries } +{ results TRUE if changes were made } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +function TSectionList.EraseDuplicates(callBackProc:TEraseSectionCallback) : Boolean; +var + slDuplicateTracking : TStringList; + idxToDelete, + ixLow, + ixHigh, + ix : Integer; + + { swap two integer variables } + procedure SwapInt(var a,b:Integer); + var + c : Integer; + begin + c := a; + a := b; + b := c; + end; +begin + Result := False; { no changes made yet } + + if count > 1 then + begin + slDuplicateTracking := TStringList.Create; + slDuplicateTracking.Assign(Self); + { store current position in the objects field: } + for ix := 0 to slDuplicateTracking.count-1 do slDuplicateTracking.Objects[ix] := Pointer(ix); + { sort the list to find out duplicates } + slDuplicateTracking.Sort; + ixLow := 0; + for ix := 1 to slDuplicateTracking.count-1 do + begin + if (AnsiCompareText(slDuplicateTracking.STRINGS[ixLow], + slDuplicateTracking.STRINGS[ix]) <> 0) then + begin + ixLow := ix; + end else + begin + ixHigh := ix; + { find the previous entry (with lower integer number) } + if Integer(slDuplicateTracking.Objects[ixLow]) > + Integer(slDuplicateTracking.Objects[ixHigh]) then SwapInt(ixHigh,ixLow); + + if Assigned(callBackProc) then + begin + { ask callback/user wether to delete the higher (=true) + or the lower one (=false)} + if NOT callBackProc(slDuplicateTracking.STRINGS[ix], + SectionItems[Integer(slDuplicateTracking.Objects[ixLow])], + SectionItems[Integer(slDuplicateTracking.Objects[ixHigh])]) + then SwapInt(ixHigh,ixLow); + end; + idxToDelete := Integer(slDuplicateTracking.Objects[ixHigh]); + + { free associated object and mark it as unassigned } + SectionItems[idxToDelete].Free; + Objects[idxToDelete] := nil; + Result := True; { list had been changed } + end {if}; + end {for}; + + ix := 0; + while ix < count do + begin + if Objects[ix] = nil then Delete(ix) + else Inc(ix); + end; + slDuplicateTracking.Free; + end {if}; + +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ search string } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +function TSectionList.IndexOf(const S: AnsiString): Integer; +var + ix, + LastIX : Integer; + { This routine doesn't search from the first item each time, + but from the last successful item. It is likely that the + next item is to be found downward. } +begin + Result := -1; + if count = 0 then Exit; + + LastIX := FPrevIndex; + { Search from last successful point to the end: } + for ix := LastIX to count-1 do + begin + if (AnsiCompareText(Strings[ix], S) = 0) then begin + Result := ix; + FPrevIndex := ix; + Exit; + end; + end; + { Not found yet? Search from beginning to last successful point: } + for ix := 0 to LastIX-1 do + begin + if (AnsiCompareText(Strings[ix], S) = 0) then begin + Result := ix; + FPrevIndex := ix; + Exit; + end; + end; +end; + +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } + +function TSectionList.IndexOfName(const name: string): Integer; +var + P: Integer; + s1, + s2 : AnsiString; +begin + s2 := name; + for Result := 0 to Count - 1 do + begin + s1 := Strings[Result]; + P := AnsiPos('=', s1); + SetLength(s1,P-1); + if (P <> 0) AND ( + CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, + PChar(s1), -1, + PChar(s2), -1) + = 2) then Exit; + end; + Result := -1; +end; + +{........................................................................... } +{ class TBigIniFile } +{........................................................................... } + +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ create new instance } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +constructor TBigIniFile.Create(const FileName: string); +begin + FSectionList := TSectionList.Create; + FTextBufferSize := IniTextBufferSize; { you may set to zero to switch off } + FFlagDropCommentLines := False; { change this aDefaults if needed } + FFlagFilterOutInvalid := False; + FFlagDropWhiteSpace := False; + FFlagDropApostrophes := False; + FFlagTrimRight := False; + FFlagClearOnReadSectionValues := False; + FFileName := ''; + FPrevSectionIndex := 0; + FEraseSectionCallback := nil; + SetFileName(FileName); +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ destructor } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +destructor TBigIniFile.Destroy; +begin + FlushFile; + ClearSectionList; + FSectionList.Free; + inherited Destroy; +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ clean up } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +procedure TBigIniFile.ClearSectionList; +var + ixSections : Integer; +begin + with FSectionList do + begin + for ixSections := 0 to count -1 do + begin + SectionItems[ixSections].Free; + end; + Clear; + FPrevIndex := 0; + end; +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ Erases all data from the INI file } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +procedure TBigIniFile.Clear; +begin + ClearSectionList; +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ Append from File } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +procedure TBigIniFile.AppendFromFile(const aName : string); +var + CurrStringList : TStringList; + CurrSectionName : string; + lpTextBuffer : Pointer; + Source : TextFile; + OneLine : string; + LL : Integer; + LastPos, + EqPos : Integer; + nospace : Boolean; +begin + CurrStringList := nil; + lpTextBuffer := nil; {only to avoid compiler warnings} + FPrevSectionIndex := 0; + if FileExists(aName) then + begin + Assign (Source,aName); + if FTextBufferSize > 0 then + begin + GetMem(lpTextBuffer,FTextBufferSize); + SetTextBuf(Source,lpTextBuffer^,FTextBufferSize); + end; + Reset (Source); + while NOT Eof(Source) do + begin + ReadLn(Source,OneLine); + if OneLine = #$1A {EOF} then OneLine := ''; + { drop lines with leading ';' : } + if FFlagDropCommentLines then if OneLine <> '' then if (OneLine[1] = ';') then OneLine := ''; + { drop lines without '=' } + if OneLine <> '' then begin + LL := Length(OneLine); + if (OneLine[1] = '[') AND (OneLine[LL] = ']') then + begin + CurrSectionName := Copy(OneLine,2,LL-2); + CurrStringList := TStringList.Create; + FSectionList.AddObject(CurrSectionName,CurrStringList); + end + else begin + if FFlagDropWhiteSpace then + begin + nospace := False; + repeat + { delete white space left to equal sign } + EqPos := AnsiPos('=', OneLine); + if EqPos > 1 then begin + if OneLine[EqPos - 1] IN [' ', #9] then + Delete(OneLine, EqPos - 1, 1) + else + nospace := True; + end + else + nospace := True; + until nospace; + nospace := False; + EqPos := AnsiPos('=', OneLine); + if EqPos > 1 then begin + repeat + { delete white space right to equal sign } + if EqPos < Length(OneLine) then begin + if OneLine[EqPos + 1] IN [' ', #9] then + Delete(OneLine, EqPos + 1, 1) + else + nospace := True; + end + else + nospace := True; + until nospace; + end; + end; {FFlagDropWhiteSpace} + if FFlagDropApostrophes then + begin + EqPos := AnsiPos('=', OneLine); + if EqPos > 1 then begin + LL := Length(OneLine); + { filter out the apostrophes } + if EqPos < LL - 1 then begin + if (OneLine[EqPos + 1] = OneLine[LL]) AND (OneLine[LL] IN ['"', #39]) then + begin + Delete(OneLine, LL, 1); + Delete(OneLine, EqPos + 1, 1); + end; + end; + end; + end; {FFlagDropApostrophes} + if FFlagTrimRight then + begin + LastPos := Length(OneLine); + while ((LastPos > 0) AND (OneLine[LastPos] < #33)) do Dec(LastPos); + OneLine := Copy(OneLine,1,LastPos); + end; {FFlagTrimRight} + if (NOT FFlagFilterOutInvalid) OR (AnsiPos('=', OneLine) > 0) then + begin + if Assigned(CurrStringList) then CurrStringList.Add(OneLine); + end; + end; + end; + end; + + if FSectionList.EraseDuplicates(FEraseSectionCallback) then FHasChanged := True; + + Close(Source); + if FTextBufferSize > 0 then + begin + FreeMem(lpTextBuffer,FTextBufferSize); + end; + end; +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ Set or change FileName } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +procedure TBigIniFile.SetFileName(const aName : string); +begin + FlushFile; + ClearSectionList; + FFileName := aName; + if aName <> '' then AppendFromFile(aName); + FHasChanged := False; +end; + +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ find item in specified section } +{ depending on CreateNew-flag, the section is created, if not existing } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +function TBigIniFile.FindItemIndex(const aSection, aKey :string; CreateNew:Boolean; + var FoundStringList:TStringList):Integer; +var + SectionIndex : Integer; + LastIX : Integer; +begin + SectionIndex := -1; + + if FSectionList.count > 0 then + begin + LastIX := FPrevSectionIndex -1; + if LastIX < 0 then LastIX := FSectionList.count -1; + while (AnsiCompareText(aSection,FSectionList[FPrevSectionIndex]) <> 0) + AND (FPrevSectionIndex <> LastIX) do + begin + Inc(FPrevSectionIndex); + if FPrevSectionIndex = FSectionList.count then FPrevSectionIndex := 0; + end; + if AnsiCompareText(aSection,FSectionList[FPrevSectionIndex]) = 0 then + begin + SectionIndex := FPrevSectionIndex; + end; + end; + + if SectionIndex = -1 then + begin + if CreateNew then begin + FoundStringList := TStringList.Create; + FPrevSectionIndex := FSectionList.AddObject(aSection,FoundStringList); + end + else begin + FoundStringList := nil; + end; + Result := -1; + end + else begin + FoundStringList := FSectionList.SectionItems[SectionIndex]; + Result := FoundStringList.IndexOfName(aKey); + end; +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ the basic function: return single string } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +function TBigIniFile.ReadString(const aSection, aKey, aDefault: string): string; +var + ItemIndex : Integer; + CurrStringList : TStringList; +begin + ItemIndex := FindItemIndex(aSection,aKey,False,CurrStringList); + if ItemIndex = -1 then + begin + Result := aDefault + end + else begin + Result := Copy(CurrStringList[ItemIndex], Length(aKey) + 2, MaxInt); + end; +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ same as ReadString, but returns AnsiString type } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +function TBigIniFile.ReadAnsiString(const aSection, aKey, aDefault: string): AnsiString; +var + ItemIndex : Integer; + CurrStringList : TStringList; +begin + ItemIndex := FindItemIndex(aSection,aKey,False,CurrStringList); + if ItemIndex = -1 then + begin + Result := aDefault + end + else begin + Result := CurrStringList.Values[aKey]; + end; +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ here is the one to write the string } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +procedure TBigIniFile.WriteString(const aSection, aKey, aValue: string); +var + ItemIndex : Integer; + CurrStringList : TStringList; + newLine : string; +begin + if aKey = '' then + begin + {behaviour of WritePrivateProfileString: if all parameters are null strings, + the file is flushed to disk. Otherwise, if key name is a null string, + the entire Section is to be deleted} + if (aSection = '') AND (aValue = '') then FlushFile + else EraseSection(aSection); + end + else begin + newLine := aKey+'='+aValue; + ItemIndex := FindItemIndex(aSection,aKey,True,CurrStringList); + if ItemIndex = -1 then begin + CurrStringList.Add(newLine); + FHasChanged := True; + end + else begin + if (CurrStringList[ItemIndex] <> newLine) then + begin + FHasChanged := True; + CurrStringList[ItemIndex] := newLine; + end; + end; + end; +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ Same as writestring, but processes AnsiString type } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +procedure TBigIniFile.WriteAnsiString(const aSection, aKey, aValue: AnsiString); +var + ItemIndex : Integer; + CurrStringList : TStringList; + newLine : AnsiString; +begin + if aKey = '' then + begin + {behaviour of WritePrivateProfileString: if all parameters are null strings, + the file is flushed to disk. Otherwise, if key name is a null string, + the entire Section is to be deleted} + if (aSection = '') AND (aValue = '') then FlushFile + else EraseSection(aSection); + end + else begin + newLine := aKey+'='+aValue; + ItemIndex := FindItemIndex(aSection,aKey,True,CurrStringList); + if ItemIndex = -1 then begin + CurrStringList.Add(newLine); + FHasChanged := True; + end + else begin + if (CurrStringList[ItemIndex] <> newLine) then + begin + FHasChanged := True; + CurrStringList[ItemIndex] := newLine; + end; + end; + end; +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ read integer value } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +function TBigIniFile.ReadInteger(const aSection, aKey: string; + aDefault: Longint): Longint; +var + IStr: string; +begin + IStr := ReadString(aSection, aKey, ''); + if CompareText(Copy(IStr, 1, 2), '0x') = 0 then + IStr := '$' + Copy(IStr, 3, 255); + Result := StrToIntDef(IStr, aDefault); +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ Yes, you guessed right: this procedure writes an integer value } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +procedure TBigIniFile.WriteInteger(const aSection, aKey: string; aValue: Longint); +begin + WriteString(aSection, aKey, IntToStr(aValue)); +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ read boolean value } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +function TBigIniFile.ReadBool(const aSection, aKey: string; + aDefault: Boolean): Boolean; +begin + Result := ReadInteger(aSection, aKey, Ord(aDefault)) <> 0; +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ write boolean value } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +procedure TBigIniFile.WriteBool(const aSection, aKey: string; aValue: Boolean); +const + BoolText: array[Boolean] of string[1] = ('0', '1'); +begin + WriteString(aSection, aKey, BoolText[aValue]); +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ read date value } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +function TBigIniFile.ReadDate(const aSection, aKey: string; aDefault: TDateTime): TDateTime; +var + DateStr: string; +begin + DateStr := ReadString(aSection, aKey, ''); + Result := aDefault; + if DateStr <> '' then + try + Result := StrToDate(DateStr); + except + on EConvertError do + else raise; + end; +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ write date value } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +procedure TBigIniFile.WriteDate(const aSection, aKey: string; aValue: TDateTime); +begin + WriteString(aSection, aKey, DateToStr(aValue)); +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ read DateTime value } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +function TBigIniFile.ReadDateTime(const aSection, aKey: string; aDefault: TDateTime): TDateTime; +var + DateStr: string; +begin + DateStr := ReadString(aSection, aKey, ''); + Result := aDefault; + if DateStr <> '' then + try + Result := StrToDateTime(DateStr); + except + on EConvertError do + else raise; + end; +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ write DateTime value } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +procedure TBigIniFile.WriteDateTime(const aSection, aKey: string; aValue: TDateTime); +begin + WriteString(aSection, aKey, DateTimeToStr(aValue)); +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ read Float value } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +function TBigIniFile.ReadFloat(const aSection, aKey: string; aDefault: Double): Double; +var + FloatStr: string; +begin + FloatStr := ReadString(aSection, aKey, ''); + Result := aDefault; + if FloatStr <> '' then + try + Result := StrToFloat(FloatStr); + except + on EConvertError do + else raise; + end; +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ write Float value } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +procedure TBigIniFile.WriteFloat(const aSection, aKey: string; aValue: Double); +begin + WriteString(aSection, aKey, FloatToStr(aValue)); +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ read Time value } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +function TBigIniFile.ReadTime(const aSection, aKey: string; aDefault: TDateTime): TDateTime; +var + TimeStr: string; +begin + TimeStr := ReadString(aSection, aKey, ''); + Result := aDefault; + if TimeStr <> '' then + try + Result := StrToTime(TimeStr); + except + on EConvertError do + else raise; + end; +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ write Time value } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +procedure TBigIniFile.WriteTime(const aSection, aKey: string; aValue: TDateTime); +begin + WriteString(aSection, aKey, TimeToStr(aValue)); +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ read entire section (hoho, only the item names) } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +procedure TBigIniFile.ReadSection(const aSection: string; aStrings: TStrings); +var + SectionIndex : Integer; + CurrStringList : TStringList; + ix : Integer; +begin + SectionIndex := FSectionList.IndexOf(aSection); + if SectionIndex <> -1 then + begin + CurrStringList := FSectionList.SectionItems[SectionIndex]; + for ix := 0 to CurrStringList.count - 1 do + begin + if CurrStringList.Names[IX] = '' then continue; + if FFlagDropCommentLines and (CurrStringList.Names[IX][1] = ';') then continue; + aStrings.Add(CurrStringList.Names[ix]); + end; + end; +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ copy all section names to TStrings object } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +procedure TBigIniFile.ReadSections(aStrings: TStrings); +begin + aStrings.Assign(SectionNames); +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ read entire section } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +procedure TBigIniFile.ReadSectionValues(const aSection: string; aStrings: TStrings); +var + SectionIndex : Integer; +begin + SectionIndex := FSectionList.IndexOf(aSection); + if SectionIndex <> -1 then + begin + {In prior versions of TIniFile the target-Strings were _not_ cleared + That's why my procedure didn't either. Meanwhile, Borland changed their + mind and I added the following line for D5 compatibility. + Use ReadAppendSectionValues if needed} + if FFlagClearOnReadSectionValues then aStrings.Clear; // new since 3.09,3.10 + aStrings.AddStrings(FSectionList.SectionItems[SectionIndex]); + end; +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ copy all 'lines' to TStrings-object } +{ Note [2]: under Delphi 1, ReadAll may cause errors when a TMemo.Lines } +{ array is destination and source is greater than 64 KB } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +procedure TBigIniFile.ReadAll(aStrings:TStrings); +var + ixSections : Integer; + CurrStringList : TStringList; +begin + with FSectionList do + begin + for ixSections := 0 to count -1 do + begin + CurrStringList := SectionItems[ixSections]; + if CurrStringList.count > 0 then + begin + aStrings.Add('['+STRINGS[ixSections]+']'); + aStrings.AddStrings(CurrStringList); + aStrings.Add(''); + end; + end; + end; +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ flush (save) data to disk } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +procedure TBigIniFile.FlushFile; +var + CurrStringList : TStringList; + lpTextBuffer : Pointer; + Destin : TextFile; + ix, + ixSections : Integer; +begin + lpTextBuffer := nil; {only to avoid compiler warnings} + if FHasChanged then + begin + if FFileName <> '' then + begin + Assign (Destin,FFileName); + if FTextBufferSize > 0 then + begin + GetMem(lpTextBuffer,FTextBufferSize); + SetTextBuf (Destin,lpTextBuffer^,FTextBufferSize); + end; + Rewrite (Destin); + + with FSectionList do + begin + for ixSections := 0 to count -1 do + begin + CurrStringList := SectionItems[ixSections]; + if CurrStringList.count > 0 then + begin + WriteLn(Destin,'[',STRINGS[ixSections],']'); + for ix := 0 to CurrStringList.count -1 do + begin + WriteLn(Destin,CurrStringList[ix]); + end; + WriteLn(Destin); + end; + end; + end; + + Close(Destin); + if FTextBufferSize > 0 then + begin + FreeMem(lpTextBuffer,FTextBufferSize); + end; + end; + FHasChanged := False; + end; +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ Flushes buffered INI file data to disk } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +procedure TBigIniFile.UpdateFile; +begin + FlushFile; +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ erase specified section } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +procedure TBigIniFile.EraseSection(const aSection: string); +var + SectionIndex : Integer; +begin + SectionIndex := FSectionList.IndexOf(aSection); + if SectionIndex <> -1 then + begin + FSectionList.SectionItems[SectionIndex].Free; + FSectionList.Delete(SectionIndex); + FSectionList.FPrevIndex := 0; + FHasChanged := True; + if FPrevSectionIndex >= FSectionList.count then FPrevSectionIndex := 0; + end; +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ remove a single key } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +procedure TBigIniFile.DeleteKey(const aSection, aKey: string); +var + ItemIndex : Integer; + CurrStringList : TStringList; +begin + ItemIndex := FindItemIndex(aSection,aKey,True,CurrStringList); + if ItemIndex > -1 then begin + FHasChanged := True; + CurrStringList.Delete(ItemIndex); + end; +end; + +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ check for existance of a section } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +function TBigIniFile.HasSection(const aSection: String): Boolean; +begin + Result := (FSectionList.IndexOf(aSection) > -1) +end; + +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ Indicates whether a section exists } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +function TBigIniFile.SectionExists(const aSection: String): Boolean; +begin + Result := HasSection(aSection); +end; + +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ Indicates whether a key exists } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +function TBigIniFile.ValueExists(const aSection, aValue: string): Boolean; +var + S: TStringList; +begin + S := TStringList.Create; + try + ReadSection(aSection, S); + Result := S.IndexOf(aValue) > -1; + finally + S.Free; + end; +end; + +{........................................................................... } +{ class TBiggerIniFile } +{........................................................................... } + +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ write/replace complete section } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +procedure TBiggerIniFile.WriteSectionValues(const aSection: string; const aStrings: TStrings); +var + SectionIndex : Integer; + FoundStringList : TStringList; + ix : Integer; +begin + SectionIndex := FSectionList.IndexOf(aSection); + if SectionIndex = -1 then + begin + { create new section } + FoundStringList := TStringList.Create; + FSectionList.AddObject(aSection,FoundStringList); + FoundStringList.AddStrings(aStrings); + FHasChanged := True; + end + else begin + { compare existing section } + FoundStringList := FSectionList.SectionItems[SectionIndex]; + if FoundStringList.count <> aStrings.count then + begin + { if count differs, replace complete section } + FoundStringList.Clear; + FoundStringList.AddStrings(aStrings); + FHasChanged := True; + end + else begin + { compare line by line } + for ix := 0 to FoundStringList.count - 1 do + begin + if FoundStringList[ix] <> aStrings[ix] then + begin + FoundStringList[ix] := aStrings[ix]; + FHasChanged := True; + end; + end; + end; + end; +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ read a numbered list } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +procedure TBiggerIniFile.ReadNumberedList(const Section: string; + aStrings: TStrings; + Deflt: string; + aPrefix: String = ''; + IndexStart: Integer = 1); +var + maxEntries : Integer; + ix : Integer; +begin + maxEntries := ReadInteger(Section,cIniCount,0); + for ix := 0 to maxEntries -1 do begin + aStrings.Add(ReadString(Section,aPrefix+IntToStr(ix+IndexStart),Deflt)); + end; +end; +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ write a numbered list (TStrings contents) } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +procedure TBiggerIniFile.WriteNumberedList(const Section: string; + aStrings: TStrings; + aPrefix: String = ''; + IndexStart: Integer = 1); +var + prevCount, + ix : Integer; + prevHasChanged : Boolean; + oldSectionValues, + newSectionValues : TStringList; +begin + oldSectionValues := TStringList.Create; + newSectionValues := TStringList.Create; + + try + { store previous entries } + ReadSectionValues(Section,oldSectionValues); + + prevCount := ReadInteger(Section,cIniCount,0); + WriteInteger(Section,cIniCount,aStrings.count); + prevHasChanged := HasChanged; + + { remove all previous lines to get new ones together } + for ix := 0 to prevCount-1 do begin + DeleteKey(Section,aPrefix+IntToStr(ix+IndexStart)); + end; + for ix := 0 to aStrings.count -1 do begin + WriteString(Section,aPrefix+IntToStr(ix+IndexStart),aStrings[ix]); + end; + + { check if entries really had changed } + if NOT prevHasChanged then + begin + { read new entries and compare with old } + ReadSectionValues(Section,newSectionValues); + HasChanged := NOT ListIdentical(newSectionValues,oldSectionValues); + end; + finally + oldSectionValues.Free; + newSectionValues.Free; + end; +end; + +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ renames a section } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +procedure TBiggerIniFile.RenameSection(const OldSection, NewSection : String); +var + SectionIndex : Integer; +begin + if NewSection <> OldSection then + begin + SectionIndex := FSectionList.IndexOf(OldSection); + if SectionIndex <> -1 then + begin + FSectionList[SectionIndex] := NewSection; + end; + FHasChanged := True; + end; +end; + +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ renames a key } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +procedure TBiggerIniFile.RenameKey(const aSection, OldKey, NewKey : String); +var + ItemIndex : Integer; + CurrStringList : TStringList; +begin + if NewKey <> OldKey then + begin + ItemIndex := FindItemIndex(aSection,OldKey,False,CurrStringList); + if ItemIndex <> -1 then + begin + WriteString(aSection,NewKey,ReadString(aSection,OldKey,'')); + DeleteKey(aSection, OldKey); + end; + end; +end; + +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ reads data into a buffer } +{ result: actually read bytes } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +function TBiggerIniFile.ReadBinaryData(const aSection, aKey: String; var Buffer; BufSize: Integer): Integer; +var + ix : Integer; + bufPtr : PChar; + hexDump : AnsiString; +begin + hexDump := ReadAnsiString(aSection,aKey,''); + result := Length(hexDump) div 2; + if result > BufSize then result := BufSize; + + bufPtr := Pointer(Buffer); + for ix := 0 to result -1 do + begin + Byte(bufPtr[ix]) := StrToIntDef('$' + Copy(hexDump,1 + ix*2,2) ,0); + end; +end; + +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +{ writes data from a buffer } +{ each represented byte is stored as hexadecimal string } +{. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . } +procedure TBiggerIniFile.WriteBinaryData(const aSection, aKey: String; var Buffer; BufSize: Integer); +var + ix : Integer; + bufPtr : PChar; + hexDump : AnsiString; +begin + hexDump := ''; + bufPtr := Pointer(Buffer); + for ix := 0 to BufSize-1 do + begin + hexDump := hexDump + IntToHex(Byte(bufPtr[ix]),2); + end; + WriteAnsiString(aSection,aKey,hexDump); +end; + +{........................................................................... } +{ class TAppIniFile } +{........................................................................... } +constructor TAppIniFile.Create; +begin + inherited Create(ChangeFileExt(ModuleName(False),'.ini')); +end; + +{........................................................................... } +{ class TLibIniFile } +{........................................................................... } +constructor TLibIniFile.Create; +begin + inherited Create(ChangeFileExt(ModuleName(True),'.ini')); +end; + +end. + diff --git a/unit-importing/conv.ini b/unit-importing/conv.ini new file mode 100644 index 0000000..db6f98a --- /dev/null +++ b/unit-importing/conv.ini @@ -0,0 +1,133 @@ +[TObject] +[TPersistent] +PARENT-CLASS=TObject +[TComponent] +PARENT-CLASS=TPersistent +[TControl] +PARENT-CLASS=TComponent +Caption=READWRITE String +Color=READWRITE Longint +DragCursor=READWRITE Longint +DragMode=READWRITE TDragMode +Font=READWRITE TFont +ParentColor=READWRITE Boolean +ParentFont=READWRITE Boolean +ParentShowHint=READWRITE Boolean +PopupMenu=READWRITE TPopupMenu +Text=READWRITE string +OnClick=READWRITE TNotifyEvent +OnDblClick=READWRITE TNotifyEvent +OnDragDrop=READWRITE TDragDropEvent +OnDragOver=READWRITE TDragOverEvent +OnEndDrag=READWRITE TEndDragEvent +OnMouseDown=READWRITE TMouseEvent +OnMouseMove=READWRITE TMouseMoveEvent +OnMouseUp=READWRITE TMouseEvent +OnStartDrag=READWRITE TStartDragEvent +Align= +BoundsRect= +ClientHeight= +ClientOrigin= +ClientRect= +ClientWidth= +ControlState= +ControlSTyle= +Parent= +ShowHint= +Visible= +Enabled= +Left= +Top= +Width= +Height= +Cursor= +Hint= +[TWinControl] +PARENT-CLASS=TControl +Ctl3D=READWRITE Boolean +DefWndProc= +ParentCtl3D=READWRITE Boolean +WindowHandle=READWRITE Integer +OnEnter=READWRITE TNotifyEvent +OnExit=READWRITE TNotifyEvent +OnKeyDown=READWRITE TKeyEvent +OnKeyPress=READWRITE TKeyPressEvent +OnKeyUp=READWRITE TKeyEvent +Brush= +Handle= +Showing= +TabOrder= +TabStop= +HelpContext= +[TCustomLabel] +PARENT-CLASS=TWinControl +Alignment=READWRITE TAlignment +AutoSize=READWRITE Boolean +FocusControl=READWRITE TWinControl +ShowAccelChar=READWRITE Boolean +Transparent=READWRITE Boolean +WordWrap=READWRITE Boolean +[TCustomEdit] +PARENT-CLASS=TWinControl +AutoSelect=READWRITE Boolean +AutoSize=READWRITE Boolean +BorderStyle=READWRITE BorderStyle +CharCase=READWRITE TEditCharCase +HideSelection=READWRITE Boolean +MaxLength=READWRITE Integer +OEMConvert=READWRITE Boolean +PasswordChar=READWRITE Char +ReadOnly=READWRITE Boolean +OnChange=READWRITE TNotifyEvent +[TCustomMemo] +PARENT-CLASS=TCustomEdit +Alignment=READWRITE TAlignment +ScrollBars=READWRITE TScrollStyle +WantReturns=READWRITE Boolean +WantTabs=READWRITE Boolean +WordWrap=READWRITE Boolean +[TCustomComboBox] +PARENT-CLASS=TWinControl +DropDownCount=READWRITE Integer +EditHandle=READ Integer +ItemHeight=READWRITE Integer +ListHandle=READ Integer +MaxLength=READWRITE Integer +Sorted=READWRITE Boolean +Style=READWRITE TComboBoxStyle +OnChange=READWRITE TNotifyEvent +OnDropDown=READWRITE TNotifyEvent +OnDrawItem=READWRITE TDrawItemEvent +OnMeasureItem=READWRITE TMeasureItemEvent +Canvas= +DroppedDown= +Items= +ItemIndex= +SelStart= +SelStart= +SelText= +[TCustomCheckbox] +PARENT-CLASS=TWinControl +Alignment=READWRITE TAlignment +AllowGrayed=READWRITE Boolean +Checked=READWRITE Boolean +State=READWRITE TCheckBoxState +[TcustomListbox] +PARENT-CLASS=TWinControl +BorderStyle=READWRITE TBorderStyle +Columns=READWRITE Integer +ExtendedSelect=READWRITE Boolean +IntegralHeight=READWRITE Boolean +ItemHeight=READWRITE Integer +MultiSelect=READWRITE Boolean +Sorted=READWRITE Boolean +Style=READWRITE TListBoxStyle +TabWidth=READWRITE Integer +OnDrawItem=READWRITE TDrawItemEvent +OnMeasureItem=READWRITE TMeasureItemEvent +Canvas= +Items= +ItemIndex= +SelCount= +Selected= +TopIndex= diff --git a/unit-importing/imp.dpr b/unit-importing/imp.dpr new file mode 100644 index 0000000..d1d6f09 --- /dev/null +++ b/unit-importing/imp.dpr @@ -0,0 +1,19 @@ +program imp; + +uses + Forms, + Main in 'Main.pas' {frmMain}, + ParserU in 'ParserU.pas', + ParserUtils in 'ParserUtils.pas', + BigIni in 'BigIni.pas', + FormSettings in 'FormSettings.pas' {frmSettings}, + UFrmGotoLine in 'UFrmGotoLine.pas' {frmGotoLine}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TfrmMain, frmMain); + Application.CreateForm(TfrmGotoLine, frmGotoLine); + Application.Run; +end. diff --git a/unit-importing/imp.res b/unit-importing/imp.res new file mode 100644 index 0000000000000000000000000000000000000000..698b549079900423615f161e6b54be2d15cec048 GIT binary patch literal 21724 zcmeHv30Re7`u7b74u^d^vdbn10YUK~C<=nPD*_^Jpkk<)WRMZ2F(!s-yJm?wEw-xU zIBKaaE}+$zS~=6yI62OsW97{B&1ip{meIPu-~GJjJsplf*)-RD*LVHjtEcyH&a>RV zXSuiMz9k}xMPb$oK6ZGv`su$LP{&36mL6bo(<>$6LpsWA6c;k#|9CvLm-@dn(VCHm zhX;9jdXlfNFZl-fQea>p_2|)qdW83&(8w?f4-coXs4(i;vnTl_`jdaZ0O}FngMw0n zC?Yn3B9bGhM@}e34vC_;xHz&{ER>RxLVf!6p|rF#inYd4+<-VruqKct(?W6C@njjC zNJ&}Al-56udJj#aq`}FQn%kH9_wP^EOeWtlR?5!Krrg|IavyIb_X$Qa7MjRw zoHv;!c#+R|Kk_Q@A>Rpp4exp{a=+DwjJIRVWj^G! zIFL*YffRdP93|%Wri76eiY<(zz9afla#1qHO^&C`k-$AUg9gvcq269~PxI!@qXi2V&`mepL~|Fd^wAv_GD4yYZ(;z3O>J|Ar#Y=M=`DWWZf~G`t2G>sQu-T3H1N$yl=t>5%0FH~MTch7u(vCz=-nG>(xG`YAB~gqpe%F(l37T3);DJC+*(7 zn_hY46*_R>0Nr`&VQTttJvD#w0zG~HMSA{|-L&J=1GE!m@27|8_19mgU;XM=bnMtM zdiULT>Am;fqu>4Rcl6_AGt;@yGPHzx|E=@sEGd#ful|pa1+P{p(-< zqHn(W#(^Px_pza_+Gwt=UH08KU4N?emd7ZM!C>&N>$)a>X|kBjW>sIcFh~>gcP*CY zeD_&CSwhSqXdo?&XrQV)wz$o@z@b51LI@t!A|%9ukvtVi1_K#vR8?8Wd{;l&qUwiK z*EKXW)YsM3R##g>yxq}18dy}ld09j4^}*8;5<)C>D^@I9h6Z)2L2^=px7NUjil-~H zvR<<_NVX&;BqY?GJlWKQ7Pba8)yYYg5CKgFG&niBpkTgMKRGE04XRh1R1MS!AgM-3 zGMj}aX|Oz}phyEyi~7>QQr(0GE1GnYlFgn1S~W0Q7Fj13sTplZ#-kb}SfqhYQnk0) z>?aE+4UFEivdSh~g`Vo_YI}nuA!&ueP-hMa2}<*GR}GBDkhGH3sy?bq1CS&%)%{+_ zkQ5RXZ0!qzyhAMBMsu{aY;_svIaQ0PwvCXOkYHIM4OXmZsI$bRWfi3Pd3vIs1anMU z$(l8j#}d_6tNLn$ni>pn>i4L>tf4x(Z^87EG;i+^nbw$L1*_MsDY^mm(cpB08lkTJ zbYfz{$y2CbS3S#GvU=^*v_P{3q++Pm&5y3mC0bEiTU&SWyfmmk`{%QDNlD9oe{w}# z%`ofabB#od&TEjOV%{++B;(iQ61_xUAlPjT>H6?KRWm4rlf=#RG*ucbyxG_ z&po#~%WCaw%__O;(WhTNzB6kS>Z8HAOP4NPJb(UUX;6&;>aMpI-`o7$mMtxto7b*d zz2?!!HoyG#U-wV$1G$BrRd?xg)JKC)(4ZkHsRpF4d3^JhE!$hRZ{M+v2~li z&>MX6$tP!%l168h-q*YteZTb5_SV+6Bft6E-`{(rV2D2!n(7+r8cu!v1zHG67~!Lu zz>|*`iEbC zb?^G}EbHi->*~xn)3tImP~TyMhU(&0Kce_!AH;Dy=|y;ax-@HR9wUB3KvQ{5#SNhhnT zPk(f-{SV`_?mBwmfxaOjb++>$jEPQRfE8CRUv8>9r-Ah|+!@L|#{YtiJK5KBXoYEUbDOsoI#l`E$k z>e@BXr>bk)v2f>3C0pXsvW8ef8ngpcEsRgAf9l&S=dlncKbL7eRa<@bJT}v5oYD9k ztHn}}^MDbARW^VN2|-uBy^MLn&cMlSsFq0vEIHJ@M_Me^)nF`hlY~{uX&3Hv?%ONp zP+b-e+q=eg&`#XPXwalc(yN00E=b%EWqy>M}>d!%qQ(9fP*L&!5tG>*5a8Z6q}`w156x z0|EUf;bUlljo|b^NXSYztT=n=Yi*V;oo#}M!Ct7Y))uN`i}nVsfoz=>O-*XGWpmV2 zcO~RCIfUx+pX?1)y~c53Iu1c66-lbP-e9Fu6{kPXH3xxgXTb=CKSbUd{Vz*-< zChd=4w&B)oSdU;23JQYV77|3lRm6Ucj*cc{ijn*h{Kz-Mmm=dLsb_poib;qe|J(p& zx5g!EwyPz{Lf}l)w{Krc%pRokdwWSu|+SAR3%ISlOnoV_eCl(1m=5 z`;o^u*r%{feaHBc%R~@1#gz;tuotJek^2-(>@<8g(}i5hV5^pSkavkUc~15sze)b& zJ=KTI6U-ETT?9pq>q!Aq0w}aJlxQycpW{w0RRF#K{VjmqDRyR!7rESGB#)o@QPOzW zkL7XHZ(KSJ9W#^$O&UZgb5p3_{C?Eu=022Bl|cg*WKzz8T(Z_%Y3Smil%JokY)ajh z6#H@VGc?;*!4L97N?8(`;&sMhN zqT3eHt+(Dvx8HudFg9{;^dgTY*uYHz!KM_uvd0b- z*p;C>QC_lA_?~o%+&zFIU_*-i*mK_?*o}j!=Yd@6-I7fMewjz{FXvF|&Rj}8FoycS zGLG_JETj>8CQ{}4Idt=io2h9y#o}%0Gsn_9=WO;owB^@41$#0COp-0PU^cxj4 z`a~6#zH<{5{^llS57xciNb`T!NVojDiI#o1mX`eKA%e`Z+kp=}@BlsZ&_nddBabK> z@bSkVr>CBJik^S|d4guAY`_)W5B z?SI=(trw0_TU#5w@x~i;R(<>kdX z3Nob5$M1!Ossbp`h6weS3g%Fgt7rDYMB0kqr9xq0C`PENoE@L&WAX?B5ysg0HL+A& zT)3+^y0ExqYiMyx%hs~~LlS)gOlCBR%c-mBi{C5T_O@)@wQFZ#=(d)riFq}Nn5gLD z!U5TJ^$SO}loW4!{ZQN9J$rUlhE|PDy?JR}VlaLm5uaVZ?7{5oD@#iDzJ3T5_U>tk z?3=Un&XsrOB*rEt=G5J>_UYSVF<~WdzNuAcPRv`na@DH4SKYC6*&Qp_ZrZml)vFlu zaRe0(A8MPPy0Bs8s=M)QxO>B6PrZ8Jp;T`pelLAXt1v2i;ZphW-VJv@_T=XMuPsi@ zHyKOHOG}TwwY>^Mv`raQf2XwF`1rG%pIMTcIjPv>QQT5qdidzhQbohK)cTbhHf~&d zUu|~muxXVQg(g$w_VV&Q$M%$LM}^m`u1j3>z@{fs<1<1^WwD}yAjHbctB$`}TC#QT z-reOzkMv#m%qxjeQK2QW)@Jz~@7IsF048=uanbPjq4%fa_s|~V;0TH)!T>GDk5y_F zii!%YLsDhEQ3VySJJ3Pp-s8vHcEYOLwhb#ZCUK5zwF>N_Liv4HWohM+Kb;7ZS@cgz7-`uy;=-NGP@a3=+^o z)ge?kDpP&v&^Bz@X#EV?hA1zu+_|R>>%4tyNfEYOmA$q4P+5V)fz<|1%tK*G$6w_y zp#rN}QZljFv1`YQ+gji*+vfNU^bDwRjV|9nFZ%|ZEf@M&6jTq>8PsaCl}5bvf{)!j zE{)JCY{k$94GG2L42q~T=sU))&a@erzlz}-+#U58C{%cy^_T#B7mH%oW1tGyANg$i z+sh03fS(@)n}e195)m1p^p}X#PJ~=ci=$p?3CiCt`ij-6`Od{} zo|BUUU$-Ykjfy67c__Kv2*3A&Ao5xWzxSMA@?F$}{BAXqcY~Q?#>7%melo?D#8b|& z97ALH#qx_NI=?O(eMKrEt9AO_TUo#eqX3d&KQ>&)g^@8~e=F^Qg-l%kf z#ful){mQ-%gj3L_cuHIWKmVh76#Q&&3jIYt_;ummg`YS2U=H=#GJp~`52Tb=M$*L9 zlW6K)(`dpAWwd1F5=uBUf^rW{r3JsagBlwf>8`u(qI>VXm)5Rbt9+_I|M}19u_qtv z;8zu&>WeSFsAMTzA$0igVLE>NxZPJOep2y|{{8QNr!T+!(!L!3`{93Q;J-El0}{Nv zf(GcrXZrgG1o%T0fRZpmxJuH1jP#U*05{i^Q4usgC@3I3Gb267!_C#TM<^vEK!M53 zO!G7w1AN1y3Q{Jf7o?~6j~&?46djd6JR`Gg+LXeekU_b*IoFNNPEISFfiEoagYrg? z85!>zkUp_|YT2}u;$FiBNB2$h56Ubk8$Y8g4cbU}P-ccddYhR(V0_AejG&mHlq4^Z zGpRf?qkmdjN=j0KKRDdP^l25dW=f}}8N%?WAbrwI`C>|Xkfvr$N>3j(p&+Aok`9n2 zj?c)j!Tl-*wx?0!*^Q_mrPBwzvQdiIt|(_N7)k_62#P0)uDJg2&TKW|C-d*st5+@L%ZZqn7zPH8ii%=jU|?Wi zU|?Vy1_lNO1_lNO1_p);kY77six++0;6f)#FiH+eCCVTa!JsYN_jTa#JM8tC-o1No zf=s*s3>+UH&%nSx5(5JR!whK0-FSt=FdaUEP6J95%CxYN;Rj8{UjOnNA5ezBq453i zCp9&7Iqu6Z00RR90|Wnr7#JAZVeeeE9-z}5B_3s7_=t%2T&5VHYAWz#TvL>C=aSfxE&WxTGF*6oxN_p{FqRnOY-gsB#`U+e`X72nGg*9q#V#IO*C0 zI*lk6l$#=kNBu$QHx+sQ(|>$Gm|mx=cSc4=1!%Yc3=9m4Hb)Ft6ULo8LlfoMvuCR^ zW5x`gI&~^fnly=_2l2RZ<9O7lQ4Af4;SXZCbvYs;!udQnV>kf}{e&*iZ9+*wSrTzw z)WckbNp z#eg^qg+uz2Gw*PwJ756)7X$<7_Cm3utd1BS@eh}B&|hX??+Ly;x}qO?X@$%cFsOat zhylJQhQElHFJI2^9WivrAB_Ptv8Wl%rN$^}my{d#< z%WhM#CmZIwt70rNeeO&@e0}|f4jpF3Y9wPgse)Q0oFI{K2vGEQcVDMzbBC#X=BSwr^E<8f!_J?AS zHGTXAZ;mV)$(pFBKjuJPff|j2J2I5eW>MuF(O5%sckJ;#I=05l6*_8$8%_ zcL2NBdv&0H^ytws!sCEJ@wsckAbhB+^RRH?LawT+QuGT}q1!UR!ic|O*$W;MJQ=ZP zc3nf(Mr4QZCiyIS2x2lAv1F)^xnJhXUJv#F{oWn+4}9C3fI;!;AA{_Pr5RXDnM$DX|Q}iY|8^ZU5FRA(>%qS3!q`~v!-xxH#3ib;EPO35FHfz3@a*10dSl+b*mb5md)^()h+SjE zsj<(4q3klloym!H2;6_U*e0Ls?lF!-vmsOfllQlnmD81MWu@ z{UXw%a_M(iXbHj>kZ_G83JV$K8E zt;7gE5B|RTO_rXVw9AU(b zaZ5{!ns0gU-o2X!Q_u+RM=9K0n_ z(TrF_j@p;03gQrfsTcdMjb!h8LRIly6UhOO$20Dl7_o_rxI#uOAR{)95mU&B{bXZ- zkr6*DdQ$-O#^s_XI%0U|op%`Vc|RC~@E6fFWFN^MOc<4*?e!Zy+4rF^MocA#@9k%! zJBtw`$a~H4SV~3=B_no{V-Dmo;v5+CB#9cCCEE#c-jQB@JTqgLvuUb#UBr6-jW{cKN zn>MXg_?wOa@vV$_$ZNvz%rnn0e5jgUQy9mH8)ieb2k6JXc`gBS-yd{i&i7}l`Brqd z4h8*rD4-p5BfgXoN6Ls1WyEkYVmBGFq8zg!m1(Y<@OnlZwX>XFju>7B2F0TV!@70r z7_pq!i~%vj3WM-2!~(PHBsa(#?4RZ+oY^#%J<@@0+k6Y%h=XOsxiVr|8F8qL7+6MZ zFS{=Az}a@=9uq)fGKpeAO=X>iXPg->F?XVm+cdO{OItHNw@ym7$OO`BA>nHN8JH8}5NY^z4?~WZi zl-!g3h|5cjvJTzxCERh?b#K`_x||l7E$bouM2?JvP5{}u*ozV4&WPP-(La$}q5K-c zKf1D~g%=n%wMs@K zCxQ(V-PvU!Y}ngO@Z)%KUu$3Gn-M-J>)#m$k&B)9`SKt;i$u?K#DI8u{`~XL6$Zp$ z*m>(?k3H5U2GKip-CO3{S=U&zW{uK|MbAJ^hxk53hhz`f{(}D zrRdI>SAUWJju>Pt+)*hEGLMe(0rz1_uW;T=h&Qp@56?dPtkPc{F^I0M+tY#}H5a_H z(3_1DO>7-tRsJP8gI(EiVjDR6Dq;V(3jOkc_w8`TfEZ$hLH3ehbHpI$LFyy0Px-Gz z-xNNl+d#tiWWPx}{cOn|lsVKfh`xlpAr2oE!PbFRZM+zEw2c%h?=6IyhA$x(0B?FZck($9m=mvnj@G3a`$ZpVoY z=lv>3c~((?7;1(9JsJ>2&LF*d6|mc^8~9AZDur2H{I0%jAqACx}Hp ziJTRlzhT1$7Q0z+3lESpEqqDNq{s)6al#+PcPc#cw%cxFvGK+KD`!ZTyZSzmz10bZ zE`7GZP$6>L5rgz8`l#bN=)BcYPX8F4PnU7JEh_f3@Lrh@!QkjKw)yTaz}Fk2&v|EW zU}*hsV?cgg2fv2HnYQzs&S;nKaBls9;lh6lgXmkG`MrUm%YEaF1sM8uhC$BmYp=cb zAK6Q?heQYHg14T4uffhQo$2lDZ(t|_2BpV3o(I8zJU>RvrJXPRyXOHpgFI%;7`wc3 z!f*oe>zZiS@c=_!SL+~iCHl~BfBRdzuA%FEj`l-$wy5wc(HXkotta3Y_))YwV357k z?tC6(9dw;f?!bg^ATN^t@|VBZb#G@o?ya}pVzKp+`>Je;?~&6xunzwg?G6~^Oz-Fp zgRXn)wy5xR@qr325nbpSWZVVVakcu`Kjj-3@_?b;`8??B;Ecgp=lcN|TCtb9yjM@Key*T_3>E4;a=!Uuypm7*4<^QVV_QKR(~xVbFgA z{V}jbi?ElLL;qinbr9c7E6zhJbnhM5OUvP_tcAbzC!J>mlNz{D%UfA4?~4ffl=m3~ zfyx`jMc#x5Z=Q8kb9#ze))8xy!(-rVM)@`8LE_OoTPo%@Bx{LjSnQmw$kx;{#VY zmFmmV@h51!2&94CeN96kcE+(ATmSaF2mLpwL%5xE90JNVY$mvmamsMWz!xA!a3cY9 zm@Z6|9R-F!REVu75I@z0I`$8{0}bs%zyyPYhCqXF3@i&L9F7ug2>b-282Tp6TzCVo z9s<`%E;9@?PNy3Y-?_QaDeObQ4u^Rp>8}k9-3$S+m`MO}8p36g!4=t7I{mQJae?SG z1g-|)73^vVREAH@aYs20L6ckzw|J0B3jqe)24YsP9s(L(r$gXIuG3Ac4I%k&(+!e! zRV4ER6%rl?2+&T4z^_+N)PT$ZNQy&_oc&y2OF-2JA`F2%I@kF|kJSM*QToUB=yV9U zWq=FI4gJ7z2&9Z5OU|X#75R4>3LFz{xiJKi_FM{FkuE0LVTA-)ge|8H0bL%zH5B*& za~NJP>?mwbn8ex;$WKEW9Wvw$Q{0f-r=4yXyY?N0Bt7KLd9M%me87zLMO$qMD8#}G(_Lwpv}?U23ZI>jCNg4*fEt^<*yMvp?)9uoC@ zn#28m9^4ok! zUV%@?hVD!af4M)h<=kt%X{y1s$lyBB;4-hcJ&ZQl0$x@$1;Cp<{{}Wa$g3n^rBwNig>v{?n;rW7yNv0B<6*_WKC-wJNfMz zB(F)1-E_&s1gC`@*M@+j;OZeH<8ZnG`GSE@#f9%qkJ>k&=e~i_`?8VAhh%~11Gz}& zi#m{tggoTmAw3QmagxM0OHw?wqX%6<8v;%*=OKR(EcgRLGOfn>mPqv>6=p@<@aC%?}xG3O-u}>7T z@`f!L?mEZlyCE`kSHI{3L!u9&=iHcsc}OTk4k1znktK+vLCJ5NCE1=xzJ$Nfe!9UG zwIOhMj3Hpoz$5B3QOM~;I;sE0Xe2y>Y@{n9OEGo-800xhY9+EqizPP{DV!Ro#g?{9 zJ?K~35OBI6HxMa@SZ)}AjzhrKkhIbgS0rd6XR`FfO_KRIO>$h3s)`KRY30)#*&z6~ zUFyL`ff|Y-aAAPFL!={W%Z*cpFbZs1oC44Q27-)BB*G#`6seQQb~H>iAlFut7dS+a z6mU5~t3_Af*ml7R!GSNeA&~coArS3i-?aAAtuYWJ#(EWc(Je+~e;TH{A&=KCFPx;F zCcA~Zk)*e3Lx5(aO=1<`VC!m#5u-*(3hx3}B==?y&2|(?R}Z1}57Ws$1l%AP0w};G z;P%3DV@H8?z)g#T3>E|$;POK@FOrFoXNzlXZD!B|CILdnF1r!grS*^hgUM(^ARH8y zyEX)tTidkG=R)x)B)%dKRpU`$gP=rsl!JO;?;Ib%Jb%Oxj%*ONx8qtkcCLMP90Ew~ z6V*Km41r8qOp%l9zPf)W6c_?7)nmtwVJ*5D0&ZDsPA9?IY3H4yz-Go}2j&)VG|_;3 zUYrZulwoxAe6?WhrgQsG_O;N?g`G!rwP~RqKvLVA|Bw%kn^t2Wc1~*-Nf4}HWjJ~; zf`3S#oz?*ZvGXVl0Toe0p$XPbn>c>SZOG3f`WklG5||ocu*XbiP@&CM8u6BLjgOdq zsLh(3*g1%L5pxu-?XxytX2H)SX-8u8i_BLyErU|x?_{yAbC}+ zHB6{oiGvfLbSpEect&V<8zr7b?%m{GOZ-=IUm<;9k18K6avT|Xk194;;#AG~AzvVG z@mt(0X2|^=j+%;R5nr?vx$_WTn6yV;Bw}}k?Y7FH~W5x^Z%&a$;o{R z_N%%-!Rb(+k*~m(ydc1|+2ZSvnw~~7=OhG(UZ-z?4 z$Z=%kI5Kh`IdNehMt-NnHT?ln{|mYQkod7y#JuT!i0=$JkBnSRM&2YNuTs&Dd`vYb za?gYP@gXq(PVS84jtT!Jor;-|KA;>iGKzWArcG!U%g7JqoZKAyx=73|_SrtfcRvIv z$jFscb0&98(74sQLolc{l(j_;sahAIOZ=!3TZ8?u1pTC9y}yyW9Pus7eHB=`y3djQ zBXr39sq8ChC-IRGWfBMf1uSG`;G<7P19CW(ZyGt9DjrATKlJ&KbrGMx#9PQ-grZ~r zr*mM>yMu-7m3;@Et72iC`+&ex_gsPnd;JNVgAQi6^Z`2VK_8dFmssxIk$HcVb=Mz}o&9`{N97AHaERKnz=iV_o@t5x$K!yc=x= zuWp}4j4Y)MKAVg1R+pi6ItsHNO`u^k7Pi$`8V(ClC6BAV(gQpl`g9>9rK5>tE6cw& v3hoqZ`wQ7kt`q>aCBI4LvjH{nZ<r4IXf`6sp@$~d0FE20h^YbIWKtJl$s~7d| z-J5!c^`?-BPznnRqtM7u>eHtW`Ntc`kQzX}V|!Czav+6Ahf{cBIQ7mBp@^Z86cZCe zX0w@+l9H%@YJW;eNug*xp*Tw%nKR53lNC$mA@P)unMf%EQ>fpt1WFi^NXa<^ zXyCwsWXZ5lMn(n=9BQGgtSrjO$svz?9eGUDk*-ir-V=OCKhc|f^Zm)Yz?b|c`jbnk z8@Wz$C-+G@axKLqTG>$69r5Oq`>J$3M~$!h)I3O^*Z!7*MnSd@Fdp-I&!Ph zlUuc(+^fCFt=5a&7vk@m@%OEGFZL#nTYO1(8^&DjOWsR*k-okcMURM~_`H4;H`+|m zg)uZ>)Bs8>N~D-6v6L|yd{0TIAv3e7-<(9crgkt5U6f73hYzRGqeoL-ejbe~8cpNJ zkEe+fCsJPNa2i)WjtXZL(WFU}XzJ9dbnUg*(#)ANY53d`G`4yimE1C!u3cP4*I$1< z&7C`!=Fgu`3l}b=IZNi!>|e~GMT-{E;>C+;*|KGH`|Y=renl@btPCOjUA@Tr?qKr1 zzc=~bA54A^gp=XkKGf^3Nb*@5Oui3>l3#Nq`9Bg#h9@vrPsWm|Ihp!yNTpuS#8S|6 zeaZM#JOw>(rrxdn$k>`h!CR%IQ0Vql3f-AP;hQWJv2`GYY)_-m7t<(g_dtqxIg=uH zWm3dz=@jt_{(dckBKKZ{&so%GPZmY(%_7sD95TJ0Lw%neNU>WosPC?!WNObPQ(GQc zwvD9J9m6T(m3&IyH<1SKDWqvDr_-ocCeg&UnY3i}t*Dzv(e1-2;jIaj@>U_Gy;(%p zyfv9}-8GEj=bn3xHgDcczxvg$X#4iG{ug(zeg{(RP&GpYNwP-gtxFe*0}YeE2ZE|Ni^*!3Q7E?|=V$`uO9I z=}&+96P-GBia!1HQ~LYg|4#q>=RfJ}*|YSofBlR8{qKL%ci(+y6#!2E*4I_*jJ37P zoxbk&W37)oI(gjO+sG8-z8nqeRD;BXI3H^R9V(uv%*=ev)*#WG5EmC$ckEbG z6I$3B)Kn)Xn1h9Bazle-V+#uAS?ebzB%nd{iesvQ8UZBL2uVhx&?F5SvI~l=4Ai2& zG%!~;p}~qKjif}QmoTjw=*){OQ;O7#)+gdo4dTqwKqINz$7uAIg_8z4pIMn@Q!GMH zb#=A9L4uI9Lh(>%3=R%V@%K;-bh_Y_lGUm{s!IcqBsA6iLE|AII5NmG00j92n|*Y~ zC`;MuGSG9p7E^5-AwDk7yh0kRSW#bRHl<`1r1*Pzp`SRTDWzo1nknOnYO7U!H9}1d z1~~o))L&j-9W|if+L9C>pJ16*)9`}T>(&(Afcj`~qF#+q*Kr~~KJM6Y)UT_aWhq&` zc3Mg=qZy=PsMXDntj-}?QCnMEclL}lSbXX)r|J?CmjB_{in^NNmMQC+n`dN)g~j%b z&9#)QY2LAW#!#X<)NeX>_U!47)1Q8F`Y%lhaW$wuCnfXF=Et9VZgr-`GQg5qa_1vY zzkFnS<`~pRgVX2EojZHx%%{?z8Uxf_Zz;Z~`MFJ-S~oVYUA216Badx-`Q5+mozfqA z3p=as+?S}22A`opeL_MFNMG~##!Z{Hwr<_JY0H)^zdrEJNB`$&S$|(QI)>`Yzxq-& zI4cc~B_@mor|5ml)~#D#da13g?ZA7#`~07Wrda%RIy#1}+w_&z;Iq#@JC%?yHna5J z=8fq4rI)t0wY4Ao?ce|L!NUbZ4OnQZtFNm+{_R(2AtYghPihkDmRd^JKHmD0bl(2f z`yc)7@cJUl@C8_D9m&Z!^(`9MNc!wE?7oiMh8L`RdJF0wc;nUG>&r7OV{fXfGvZ9w z%F#f5hY{+l6Hj$CqQSLJ7**5SatP@PfmCIF+cOpL!I{z z2oA2Zod*$2bQ}Y$xN!b_Q{8DR(_j3dy1L`j)2B~0jkZkLvns_DSBC?1`||oaREP0~ z{_D?6{pB{M|4>`qaRv=OPMBpWnvxxCu5VHeYDJD&>wkLT!ioC24lC2gt7|*3aHo$a znqyKjhnj=ytp})D1fRA3@rxJEU?GluDbsqqw))f=Y^D=9qp{f*vw1Pj14a;0Sq~{B z1YNjz9`l5qfss19B6Nr*!NHn>k}sBjD-E!4YA?y= zlM{DFPTZ+ee_k#lBwD+N1nRzl^~8OO22F}2tvY1Hr46j-!Fr~f5)#m0#rO5C4eHN0 zlk|mM}{Nwz|FWrwKVj`$dY#%bknaGe6p#0L9c&l$}PB0TB4-FVFfa0_IDW6mPP0KI~ zWoBhkW_BhG9z2+a<%Svc{WSZq||KFZ?MXAO2x^45dy;qhaHQ(csC0DQQj;rOr#G{x|if z^s00kG(Ur~=jV`Rv4w^$8Af?|dCF(hd`0mOr%ahbB^4##`-n?NQsJUPDqC1a#r4HB zW6?~zpICK670q2Rmu|S>2IVhaciVN!S6p=KBD&?4Tj;jiZWF;p9*y4Q*#sZADS$jz z1&|(Z{c8BS_Xd&IeMT~@iXh*ILdbh;UW&L7` zf-l(jz-ThRF_sbzjHkpm^J&7Fyr&9BuvkUTW(+OzrLM^yZsy(!qBQ(xF3#l#ln} zhaVC&B0)FO$&)APlTSXOzy0lR%D;o&qi??XhAv!CC)9q7{(t(TvILfC*cf6oh7^{RloUsW1fmC5R~%0w+wX-T zAtA+;m6he?r6tA1QBg+JP_eb-0;yFP5*1RixvI)mp)e{$RS2YqvNG^k|G*H}BZ7y)a};>$LdXns`i9RB_>;th&Vu#aO5S?Q zTA?{UciGBStL|EL`?BS?uUy-*XI-*)G3MhSDje9~er@uC`jxBh!n5J74Uawb>b?h) zeRTM}^c`!3Ffpt9NZUsre|F6I0QdVS^A^737Wca>~Kg*U23 z#4ozP<%#6j^x#ritjIt;QF(dQk+(`qHt*iOv%Kix0SlgaB|b7Tq(s)*D8J+V#*tRA ziJehgG%|MBeaZMeq_+ex0;7m9K82q15&>NI(x&`%&SLO!fZ#Td-xLv@>KIqP)Cv`>uAZ z^VZEJMc8sx_SWi;$_g9~tTy<>JQS96{Z&2*60f7K3KZ znnly9rrY)Yy!rF!#v5-`I)BNMCHA6OtmY4v29cIR}O_(B;iUAdIv_K%{R{nKdvZ*Ql@#zwmH&O7Oz zd+wpNYuBon=r4cyOM2|d$GXHtB_{gfi!Ul&iBJX|IB0NEno!mJ}D@?wT|vobm$$ z1JW|m(*ix+U0r*JP+S}gl#GlNFQYENFD$YkX;NB2TH3(qYx?M;BJ)P3XOvB!S{N8S zI4382#Q3bll)@SK!W=s|ckH;)v3>z*lgg)+O;0NBJA6pgfD}VuMnPHrjItD18)1PN z=?3&RGi^|Q(xCJ}Q(#hpH^`Y>o{>HYnTTR5V41N3dt%d$LYBHG^JaA-WB!dSA z4-6g{Jg|)i1`iA#7(6g|VDQih{j?3fbkPqDE_9*jV!R8ym~ufqx_q3?3L}d>`w5&;DNyd|BO5^c<6w?a>;stP7jn=l(}J}!as1C>c-xMzVG5Q0?$AE zq@|^$;yH>tc<$f7KZ6JEi3j0J>cIwK#6lQ$2xFhAHG+jH=b^j3q^*PSz~Et9qdhEDLn;6c&m$OG1daVO5OB>B4Q zu2W^kj2S#_+BBX#c{0P!;RzEa@R%`U7&Z_ip2G;ca(H;S^LcRQ;V5`W6}mvT9wiB7 zY50i9PhF1Mm$D+lz7M&NttDGvgkfaUaif z=FIs)9)N>Td`N$C<{i#-7al-=r|G&C?`KMdRONAm!hSk_Qvl}#>P!UJ$9Ls4%S$`iq(L%#<0f~9yB z`gC+hKjx=m=+L1I9@IQJ@-TAbNUo`=;nk~GGj2dXUVlkjsE z^{V1>%schPUhFo{Lls?-{!3^25vxlbHf&g@tZ`2~$eENqFY|u2Jit@qAw!06bab@R z6LO~Ec=mXvp&uANjO?>d%tOr|xlD0m_nY4x2vL2%Qq<+*e)7P#u+*x}`V1?L`{!ybwHHeIm zxxG>zWQ`E_yX-p5o;{o4TQTCUN|uU@6&VJs6a&M=y(7Sb)z;|3gUmbjzLHfUuYq%7 zw;McJe^&r|EcWg~|Jbo(O(NsKgOYPs!-L47p3cL91q-;Us!Gu>yb9gsL1qR%ie)c& zPV{16!|b+(tc~ankxlZq*df47FtA>zkGWs&$KDV02K_!=_77syE#N`P=^w)b;?S4y zAm7PZ7nv&hKxA%wW<2{9__J%7Rfc#LdND93~H+vL$;wA`|aY2DWbPRalE9D_SKVRu3O+Sd9y7%6D6%W7*Dfue&i%t;Q zWlrL<%nX^qZWSJ^TZTPcaHOs#3?mP&sz%21Y4?WaHKZq=XAI~dSu4LTJskxUk zD>64`M2y<6z{j!Ay}j9QT`21o`!aBQ4BVhP%Oclub92=ih|KOcv>)c(n_Xvmu-9Ed z3~U(#N5;Mngs{uC?%(+o_^B&M&~p?#u*QR&GsFmZ&z?P(@K9D(#)!c)0!s|MmD0hQ ze!%^PqF?kHt}I#foX`$jpxW!YTYTB@Xe0yA#zD{aWqo~sS`T0v8Q4Y!c9Bztr801g znDbujUZR7Xhx}g?!o5%*_%sF{jXmoP>|Uh%w_kxF0B6sH0GYB=G#-BOi(fEe8+`EK zK?bgiTU%Sze9L?1&YcWw7$Y8{c#yi9o|Zi&Yaq1CnFfZCeK5bS<(R(}y|`CP3^|R{y_$kJ;Hg*!E{}nsW8mHxI6HQk1>KwN z^99a`J8Y~98OxCencJgBk9Off)?@G9y$n3tB|ONU)p)=qw3-WGAsIMMcAMkLzV`)l z(584rGq8XhxhF#v-~_=_U-nxY!9I6~sN%OKf&(6pW!x1pu!9WT9|Nn$z|Ju+e++CU z>k4!Xe5=?^0k9hz#7=bN;l20XW8mkmmhO;whSJWj20f&ty{;y zT3$5|!1O8}M0NqI%dV5%p>ME%nj>*$Q&{#$7rJfpEp!8?%D|yAu%-;0C%DvcweT)1U_-zIbn=2|R*wGgiJIEXJFqMn0*GGoNv16 zCKj8oJ73f}z69T)0X}z|*tQxELI?20b{>{4U8>ek^x5U)lE@&<))0QTZQG{wp6o~9 zr5Tue7QY*qbOt7yfq7=&&z1d&`~qc{iVVM;FWOCvtN~c~Hi;W(Jczyc#TQ@Lc@Y0r zWUH*h<>V6XFzmLs>>W){i_VtykbWXYN5Ce4Ze8Ndz@Rg*^(^)$avxM&L*z$K{?Y2a3*A{HcBUf_z`OI8Uw)~00EWUYTOWJu zu^xF4yHm5hWxkzljWui5D7#qf4CGu$>_cow_Jlv4mY$~k6|oI_@~6e0b&gev?TmRf zi2irvLB_%zl;T0=(NRC(zDwB^&U*=X5xf8J?6c1*`_+*Lv9&dST6jp#fvha_VcjG> zTLxKFd`Zq=Pkx;E29B{x`2TG}zdVqA+njj-##iwmdr5e6;9>k6VmdDNmaz*}M;-N*Gd+iM#8o+~!6=>@qwh(el>^#Ui zbhnorZEwv7()N;erhiOK;4ggY2^JzLx^F_s<7TGKFAv`$7jBT;|PQ-dm+MIXy1`loj zZ61*S)+MgtaHj1tr#sr^JDghscYcE^L9-Pc}w?LV@Y zWDkiA(1UC}idchPUOLm;-DmJn1Rj(f>v$f72jt-~Fq3w<^i$6Ra{74OxN&xU<;25L z=&!4yUE>El1|ktpG3O@4|1lrU5*FM z_SSq+k?Rrz6wam{&VmH zTcZLz9M$xs<6ioaJZ!^Wy2K{w>p6WrfF7K1J&+Sg{M%!oSx9#iy?8}BL6?~~0-}&v3ztb+1 z{KWhnxgAyWC~r)ZN#2;i26=P4=cRc&(K0GED!iEb^Q!+rjKF|6M+NX$Ex>5BY4JY6 zo!~CC6EXWX-07}C4rLMU)qfWGE<^$ol8g9ai-vWPSPN)Scdt$~sMtI3Q*y80iTnK) zU|vk!F^V|)I4X5{ue;y0?_d`jfVXK8|6Fh>663r|8U+6&n41QzPwkEIi!eS@K1FKZ zIlf_2rQ(jWL&Mc*G>F|U{+Gm}<^E2vHR6{^d{OQ=ghs(@2=2r-4;l@EnfZQAN?oSY zG&TN0$8qIv_%^BNt5dsY6&l3X6I(#Lw-r4lx=G?P8VyoM{BW^x#kUsxf)fo2^CDy5 zF6$PT8Q8@WXuo{c9@qt`uxmOs-(6^sc!2n6a+fc9`$}k#`(c?gnF}WxI%FPPCc8c1 zTIDYD->Hp_Sb_m}oE>5#%AJcN4RVJe@yj2gLE1_jP{y^Li|*E%-XVexvNa zFVSBGXi(=Eegz|kOvOmW7n1vWiEj%{8#iuL@i(DC{2HMFd4Ym=W8@z)^7+_xss|&7 z(jL#1JuJM989RoN&&bGOWZ&j6_Wz}cJy-Q&m(ec2!TH)IJP8eQ$07H_LW9ItUVr^{ z6>kQPc$I+Q=MDnZgQ`uVmNFkFot^u;qDIir?|gEZY3kX1NW#o zj2ugjL_wY;BQKJXx5&s!WyUqqiU_%6l>_`Q#Loud|o5QBpa~V0JjJ!}r z{wE{%laUL`$XiuBBafGnSF3OU4sx;$ddyCP;0uHX@p&a~-rZUte-{`{ci>H;IAZ4@ z#WV6#8F{IkymuTUx0R7ki@Rx8reb2`1T%7X73N0tro_-4Y?v0<=Pja3WgaAMhx|}R z-l^J?5=U^RLHt(a7&Dc)GV*m9Ika4QbRi=bmT5ZHcAOt0f0>at&C|=LU!t=_KWq0r zn1@>Uz!ee~78>ME3c0C_oK^dt6geb#9XXpK2gDx|If?vSM&2|dr zXDd0W>29$bG_0D8A$r-tj!MOx7&L!Ten;-CqCqfMj%QPoQI4`2dDggV@n*VN$H*rJ zKE|Dq8{S2Ci!I=6N7-z-4o&yNZ*9?N5Pp%HtM-A!fq#gGQDa6ia>f~X;f#E8&Kj0= ziT%(64Heq>@cm7o!5*WRSf0=zYaw#jF@7sDTJ9V~7K#oKdL@R9{BlNqJ0tg-1*@UW zyYwsTD>jA0JahoJ_`N*{LLl4MXfz1sS>jU~4YDV-v)QeDu;~lrYBO@D)jrX5mYgM} zFKoCy8x2Jo@7f!>PhvSoe<}^mI!j_wjc*$p^Wc7CL3zZfv<974riP4Ok2N{hKBy9d(wbyStMQuqQiVH(s*WG(NB7 zZ9AI{kPn^OJUHsC?&JgRD?4CM)*^OwMe}_nbVwb@>Ria*2F$}Y(4gWt@WI+ZLmTFy z1#@4Ec}Ts|{-hqaBY&3YTf|+KB9st{c#HldzHhgcM!cn5$1ZJlh*q0CCYyOYqg8_H<8~FV9y12OXRUP42Vwa@VX zym8Gg54H9B{sF>)`*WHzBA$n=TYx&jN#cotN(32h1Prw`10P6A8q1?i@hvz zR%E5zrOUn-|3!Wi{||jg&cTlOA@NVTm+2H989vCP;!BDzC->44f0p}3=|lFEoKxf= zGxCxZwqJ1O#=PLKkXL*WxPWxA9pp?)AEL*lh@B)hfwV{7GB9?)9Y=&KzL2-f$VFz) zoBX~;-;cAR*)%SOk-yBy7iQmShTY)rn2aNL z0fK!MdqCt2a+w*q&y2idU?hS61XdC`$Bg`9MjkOE7n%LT{AG`Rt>LA#KE%#J?lbpW zkOVwqKiE>)j2vV}4l*Mrnd2AqXXIatFa1Z@V_%6~DEQAdU{ fixed some bug's here. +- Some constant expressions cause the parser to get confused + (=). It will then prompt for the correct + Expression type (string, integer, char, boolean, etc) + +Todo: +- Add MUCH better error reporting +- Add a symbol table to keep track of dereferenced data types to flag them + as non importable & allow better constant parsing. +- Add support for interfaces to be correctly parsed & generate wrapper + classes for them. +- Combining more then one orginal file to one IFPS-import file. +- Handling constante sets. +- Add correct support to handle Abstract functions and Procedures. + +Added in version 0.5 (NVDS): +- Posiblity to see the Orginal soure code, master source code and after converting + the result code files. +- Added the choice of makking a single file or not. +- Created a INI-project file with all the settings. +- Modified files are saved as *.int. +- Fixed the way of handling Overloaded functions. +- Now all identifiers are all normal cased. + +Added in version 0.4 : +- Fixed spelling errors in readme.txt & output file +- Fixed parsing of multidimensional arrays & arrays with the size of a type +- Improved error reporting, by default the last 5 tokens are reported. It is + posible to have more tokens listed. The token string is RECONTRUCTED so will + NOT containt any comments, formatting or exact casing. + +Added in version 0.31 : +- Fixed error that would result in the files bwing written to in the root + of the drive, if a output dir wasnt supplied. +- Fixed error in code generation when the '-U' flag was used (prevent the + class parent's name from being written). +- Now defaults to '-u' instead of '-UseUnitAtDT' +- Updated readme.txt + +Added in version 0.3 : +- Added command line options +- Added the better clas registration code generation (handles forward + declarations) +- now uses the 'conv.ini' file that Carlo Kok's Conv utility does. +- Altered the file BigIni.pas to NOT include references to VCL + +Added in version 0.2 (not release to public): +- Added an option that controls how the design time import module is + generated. + Now it is posible to generate design time wrapper units without using the + wrapped unit. +- Fixed a bug in the constant expression parser, #10#13 is now interpreted + as a string instead as a char +- Output files are now generated in the same directory as the file being + wrapped by default. + With the option of forcing all generated files into a spesific folder. + +