diff --git a/Projects/SAMufasaGUI/project1.lpi b/Projects/SAMufasaGUI/project1.lpi
index dfa41b1..d06eef3 100644
--- a/Projects/SAMufasaGUI/project1.lpi
+++ b/Projects/SAMufasaGUI/project1.lpi
@@ -7,7 +7,7 @@
-
+
@@ -24,20 +24,24 @@
-
+
-
+
+
+
+
+
-
+
-
-
+
+
-
+
@@ -166,10 +170,10 @@
-
-
-
-
+
+
+
+
@@ -298,20 +302,20 @@
-
-
-
-
+
+
+
+
-
-
-
-
+
+
+
+
@@ -327,22 +331,20 @@
-
-
-
+
-
-
-
-
+
+
+
+
-
+
@@ -360,27 +362,23 @@
-
-
-
+
-
-
-
+
-
-
-
+
+
+
@@ -394,136 +392,195 @@
-
+
-
-
-
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
@@ -533,7 +590,7 @@
-
+
diff --git a/Projects/SAMufasaGUI/project1.lpr b/Projects/SAMufasaGUI/project1.lpr
index 217e502..3d596a9 100644
--- a/Projects/SAMufasaGUI/project1.lpr
+++ b/Projects/SAMufasaGUI/project1.lpr
@@ -8,7 +8,7 @@ uses
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, LResources, Window, files, MufasaTypes, Client, TestUnit, finder,
- MMLThread;
+ MMLThread, mmlpsthread;
{$IFDEF WINDOWS}{$R project1.rc}{$ENDIF}
@@ -16,6 +16,7 @@ begin
Application.Title:='Mufasa Stand Alone';
{$I project1.lrs}
Application.Initialize;
+
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
diff --git a/Projects/SAMufasaGUI/testunit.lfm b/Projects/SAMufasaGUI/testunit.lfm
index c7d2ccd..ac1f496 100644
--- a/Projects/SAMufasaGUI/testunit.lfm
+++ b/Projects/SAMufasaGUI/testunit.lfm
@@ -14,8 +14,1404 @@ object Form1: TForm1
Height = 25
Top = 16
Width = 75
- Caption = 'Button1'
+ Caption = 'Run'
OnClick = Button1Click
TabOrder = 0
end
+ object SynEdit1: TSynEdit
+ Left = 8
+ Height = 296
+ Top = 64
+ Width = 728
+ Align = alCustom
+ Font.Height = -13
+ Font.Name = 'Courier New'
+ Font.Pitch = fpFixed
+ Font.Quality = fqNonAntialiased
+ ParentColor = False
+ ParentFont = False
+ TabOrder = 1
+ Gutter.Width = 57
+ Gutter.MouseActions = <
+ item
+ Shift = []
+ ShiftMask = []
+ Button = mbLeft
+ ClickCount = ccAny
+ ClickDir = cdDown
+ Command = 13
+ MoveCaret = False
+ Option = 0
+ Priority = 0
+ end
+ item
+ Shift = []
+ ShiftMask = []
+ Button = mbRight
+ ClickCount = ccSingle
+ ClickDir = cdUp
+ Command = 12
+ MoveCaret = False
+ Option = 0
+ Priority = 0
+ end>
+ Highlighter = SynFreePascalSyn1
+ Keystrokes = <
+ item
+ Command = ecUp
+ ShortCut = 38
+ end
+ item
+ Command = ecSelUp
+ ShortCut = 8230
+ end
+ item
+ Command = ecScrollUp
+ ShortCut = 16422
+ end
+ item
+ Command = ecDown
+ ShortCut = 40
+ end
+ item
+ Command = ecSelDown
+ ShortCut = 8232
+ end
+ item
+ Command = ecScrollDown
+ ShortCut = 16424
+ end
+ item
+ Command = ecLeft
+ ShortCut = 37
+ end
+ item
+ Command = ecSelLeft
+ ShortCut = 8229
+ end
+ item
+ Command = ecWordLeft
+ ShortCut = 16421
+ end
+ item
+ Command = ecSelWordLeft
+ ShortCut = 24613
+ end
+ item
+ Command = ecRight
+ ShortCut = 39
+ end
+ item
+ Command = ecSelRight
+ ShortCut = 8231
+ end
+ item
+ Command = ecWordRight
+ ShortCut = 16423
+ end
+ item
+ Command = ecSelWordRight
+ ShortCut = 24615
+ end
+ item
+ Command = ecPageDown
+ ShortCut = 34
+ end
+ item
+ Command = ecSelPageDown
+ ShortCut = 8226
+ end
+ item
+ Command = ecPageBottom
+ ShortCut = 16418
+ end
+ item
+ Command = ecSelPageBottom
+ ShortCut = 24610
+ end
+ item
+ Command = ecPageUp
+ ShortCut = 33
+ end
+ item
+ Command = ecSelPageUp
+ ShortCut = 8225
+ end
+ item
+ Command = ecPageTop
+ ShortCut = 16417
+ end
+ item
+ Command = ecSelPageTop
+ ShortCut = 24609
+ end
+ item
+ Command = ecLineStart
+ ShortCut = 36
+ end
+ item
+ Command = ecSelLineStart
+ ShortCut = 8228
+ end
+ item
+ Command = ecEditorTop
+ ShortCut = 16420
+ end
+ item
+ Command = ecSelEditorTop
+ ShortCut = 24612
+ end
+ item
+ Command = ecLineEnd
+ ShortCut = 35
+ end
+ item
+ Command = ecSelLineEnd
+ ShortCut = 8227
+ end
+ item
+ Command = ecEditorBottom
+ ShortCut = 16419
+ end
+ item
+ Command = ecSelEditorBottom
+ ShortCut = 24611
+ end
+ item
+ Command = ecToggleMode
+ ShortCut = 45
+ end
+ item
+ Command = ecCopy
+ ShortCut = 16429
+ end
+ item
+ Command = ecPaste
+ ShortCut = 8237
+ end
+ item
+ Command = ecDeleteChar
+ ShortCut = 46
+ end
+ item
+ Command = ecCut
+ ShortCut = 8238
+ end
+ item
+ Command = ecDeleteLastChar
+ ShortCut = 8
+ end
+ item
+ Command = ecDeleteLastChar
+ ShortCut = 8200
+ end
+ item
+ Command = ecDeleteLastWord
+ ShortCut = 16392
+ end
+ item
+ Command = ecUndo
+ ShortCut = 32776
+ end
+ item
+ Command = ecRedo
+ ShortCut = 40968
+ end
+ item
+ Command = ecLineBreak
+ ShortCut = 13
+ end
+ item
+ Command = ecSelectAll
+ ShortCut = 16449
+ end
+ item
+ Command = ecCopy
+ ShortCut = 16451
+ end
+ item
+ Command = ecBlockIndent
+ ShortCut = 24649
+ end
+ item
+ Command = ecLineBreak
+ ShortCut = 16461
+ end
+ item
+ Command = ecInsertLine
+ ShortCut = 16462
+ end
+ item
+ Command = ecDeleteWord
+ ShortCut = 16468
+ end
+ item
+ Command = ecBlockUnindent
+ ShortCut = 24661
+ end
+ item
+ Command = ecPaste
+ ShortCut = 16470
+ end
+ item
+ Command = ecCut
+ ShortCut = 16472
+ end
+ item
+ Command = ecDeleteLine
+ ShortCut = 16473
+ end
+ item
+ Command = ecDeleteEOL
+ ShortCut = 24665
+ end
+ item
+ Command = ecUndo
+ ShortCut = 16474
+ end
+ item
+ Command = ecRedo
+ ShortCut = 24666
+ end
+ item
+ Command = ecGotoMarker0
+ ShortCut = 16432
+ end
+ item
+ Command = ecGotoMarker1
+ ShortCut = 16433
+ end
+ item
+ Command = ecGotoMarker2
+ ShortCut = 16434
+ end
+ item
+ Command = ecGotoMarker3
+ ShortCut = 16435
+ end
+ item
+ Command = ecGotoMarker4
+ ShortCut = 16436
+ end
+ item
+ Command = ecGotoMarker5
+ ShortCut = 16437
+ end
+ item
+ Command = ecGotoMarker6
+ ShortCut = 16438
+ end
+ item
+ Command = ecGotoMarker7
+ ShortCut = 16439
+ end
+ item
+ Command = ecGotoMarker8
+ ShortCut = 16440
+ end
+ item
+ Command = ecGotoMarker9
+ ShortCut = 16441
+ end
+ item
+ Command = ecSetMarker0
+ ShortCut = 24624
+ end
+ item
+ Command = ecSetMarker1
+ ShortCut = 24625
+ end
+ item
+ Command = ecSetMarker2
+ ShortCut = 24626
+ end
+ item
+ Command = ecSetMarker3
+ ShortCut = 24627
+ end
+ item
+ Command = ecSetMarker4
+ ShortCut = 24628
+ end
+ item
+ Command = ecSetMarker5
+ ShortCut = 24629
+ end
+ item
+ Command = ecSetMarker6
+ ShortCut = 24630
+ end
+ item
+ Command = ecSetMarker7
+ ShortCut = 24631
+ end
+ item
+ Command = ecSetMarker8
+ ShortCut = 24632
+ end
+ item
+ Command = ecSetMarker9
+ ShortCut = 24633
+ end
+ item
+ Command = EcFoldLevel1
+ ShortCut = 41009
+ end
+ item
+ Command = EcFoldLevel2
+ ShortCut = 41010
+ end
+ item
+ Command = EcFoldLevel1
+ ShortCut = 41011
+ end
+ item
+ Command = EcFoldLevel1
+ ShortCut = 41012
+ end
+ item
+ Command = EcFoldLevel1
+ ShortCut = 41013
+ end
+ item
+ Command = EcFoldLevel6
+ ShortCut = 41014
+ end
+ item
+ Command = EcFoldLevel7
+ ShortCut = 41015
+ end
+ item
+ Command = EcFoldLevel8
+ ShortCut = 41016
+ end
+ item
+ Command = EcFoldLevel9
+ ShortCut = 41017
+ end
+ item
+ Command = EcFoldLevel0
+ ShortCut = 41008
+ end
+ item
+ Command = EcFoldCurrent
+ ShortCut = 41005
+ end
+ item
+ Command = EcUnFoldCurrent
+ ShortCut = 41003
+ end
+ item
+ Command = EcToggleMarkupWord
+ ShortCut = 32845
+ end
+ item
+ Command = ecNormalSelect
+ ShortCut = 24654
+ end
+ item
+ Command = ecColumnSelect
+ ShortCut = 24643
+ end
+ item
+ Command = ecLineSelect
+ ShortCut = 24652
+ end
+ item
+ Command = ecTab
+ ShortCut = 9
+ end
+ item
+ Command = ecShiftTab
+ ShortCut = 8201
+ end
+ item
+ Command = ecMatchBracket
+ ShortCut = 24642
+ end
+ item
+ Command = ecColSelUp
+ ShortCut = 40998
+ end
+ item
+ Command = ecColSelDown
+ ShortCut = 41000
+ end
+ item
+ Command = ecColSelLeft
+ ShortCut = 40997
+ end
+ item
+ Command = ecColSelRight
+ ShortCut = 40999
+ end
+ item
+ Command = ecColSelPageDown
+ ShortCut = 40994
+ end
+ item
+ Command = ecColSelPageBottom
+ ShortCut = 57378
+ end
+ item
+ Command = ecColSelPageUp
+ ShortCut = 40993
+ end
+ item
+ Command = ecColSelPageTop
+ ShortCut = 57377
+ end
+ item
+ Command = ecColSelLineStart
+ ShortCut = 40996
+ end
+ item
+ Command = ecColSelLineEnd
+ ShortCut = 40995
+ end
+ item
+ Command = ecColSelEditorTop
+ ShortCut = 57380
+ end
+ item
+ Command = ecColSelEditorBottom
+ ShortCut = 57379
+ end>
+ MouseActions = <
+ item
+ Shift = []
+ ShiftMask = [ssShift, ssAlt]
+ Button = mbLeft
+ ClickCount = ccSingle
+ ClickDir = cdDown
+ Command = 1
+ MoveCaret = True
+ Option = 0
+ Priority = 0
+ end
+ item
+ Shift = [ssShift]
+ ShiftMask = [ssShift, ssAlt]
+ Button = mbLeft
+ ClickCount = ccSingle
+ ClickDir = cdDown
+ Command = 1
+ MoveCaret = True
+ Option = 1
+ Priority = 0
+ end
+ item
+ Shift = [ssAlt]
+ ShiftMask = [ssShift, ssAlt]
+ Button = mbLeft
+ ClickCount = ccSingle
+ ClickDir = cdDown
+ Command = 3
+ MoveCaret = True
+ Option = 0
+ Priority = 0
+ end
+ item
+ Shift = [ssShift, ssAlt]
+ ShiftMask = [ssShift, ssAlt]
+ Button = mbLeft
+ ClickCount = ccSingle
+ ClickDir = cdDown
+ Command = 3
+ MoveCaret = True
+ Option = 1
+ Priority = 0
+ end
+ item
+ Shift = []
+ ShiftMask = []
+ Button = mbRight
+ ClickCount = ccSingle
+ ClickDir = cdUp
+ Command = 12
+ MoveCaret = False
+ Option = 0
+ Priority = 0
+ end
+ item
+ Shift = []
+ ShiftMask = []
+ Button = mbLeft
+ ClickCount = ccDouble
+ ClickDir = cdDown
+ Command = 6
+ MoveCaret = True
+ Option = 0
+ Priority = 0
+ end
+ item
+ Shift = []
+ ShiftMask = []
+ Button = mbLeft
+ ClickCount = ccTriple
+ ClickDir = cdDown
+ Command = 7
+ MoveCaret = True
+ Option = 0
+ Priority = 0
+ end
+ item
+ Shift = []
+ ShiftMask = []
+ Button = mbLeft
+ ClickCount = ccQuad
+ ClickDir = cdDown
+ Command = 8
+ MoveCaret = True
+ Option = 0
+ Priority = 0
+ end
+ item
+ Shift = []
+ ShiftMask = []
+ Button = mbMiddle
+ ClickCount = ccSingle
+ ClickDir = cdDown
+ Command = 10
+ MoveCaret = True
+ Option = 0
+ Priority = 0
+ end
+ item
+ Shift = [ssCtrl]
+ ShiftMask = [ssShift, ssAlt, ssCtrl]
+ Button = mbLeft
+ ClickCount = ccSingle
+ ClickDir = cdUp
+ Command = 11
+ MoveCaret = False
+ Option = 0
+ Priority = 0
+ end>
+ MouseSelActions = <
+ item
+ Shift = []
+ ShiftMask = []
+ Button = mbLeft
+ ClickCount = ccSingle
+ ClickDir = cdDown
+ Command = 9
+ MoveCaret = False
+ Option = 0
+ Priority = 0
+ end>
+ Lines.Strings = (
+ 'program new;'
+ 'begin'
+ 'end.'
+ )
+ BracketHighlightStyle = sbhsBoth
+ object TSynGutterPartList
+ object TSynGutterMarks
+ Width = 23
+ end
+ object TSynGutterLineNumber
+ Width = 17
+ MouseActions = <>
+ MarkupInfo.Background = clBtnFace
+ MarkupInfo.Foreground = clNone
+ DigitCount = 2
+ ShowOnlyLineNumbersMultiplesOf = 1
+ ZeroStart = False
+ LeadingZeros = False
+ end
+ object TSynGutterChanges
+ Width = 4
+ ModifiedColor = 59900
+ SavedColor = clGreen
+ end
+ object TSynGutterSeparator
+ Width = 2
+ end
+ object TSynGutterCodeFolding
+ MouseActions = <
+ item
+ Shift = []
+ ShiftMask = []
+ Button = mbRight
+ ClickCount = ccSingle
+ ClickDir = cdUp
+ Command = 16
+ MoveCaret = False
+ Option = 0
+ Priority = 0
+ end
+ item
+ Shift = []
+ ShiftMask = [ssShift]
+ Button = mbMiddle
+ ClickCount = ccAny
+ ClickDir = cdDown
+ Command = 14
+ MoveCaret = False
+ Option = 0
+ Priority = 0
+ end
+ item
+ Shift = [ssShift]
+ ShiftMask = [ssShift]
+ Button = mbMiddle
+ ClickCount = ccAny
+ ClickDir = cdDown
+ Command = 14
+ MoveCaret = False
+ Option = 1
+ Priority = 0
+ end
+ item
+ Shift = []
+ ShiftMask = []
+ Button = mbLeft
+ ClickCount = ccAny
+ ClickDir = cdDown
+ Command = 0
+ MoveCaret = False
+ Option = 0
+ Priority = 0
+ end>
+ MarkupInfo.Background = clNone
+ MarkupInfo.Foreground = clGray
+ MouseActionsExpanded = <
+ item
+ Shift = []
+ ShiftMask = []
+ Button = mbLeft
+ ClickCount = ccAny
+ ClickDir = cdDown
+ Command = 14
+ MoveCaret = False
+ Option = 0
+ Priority = 0
+ end>
+ MouseActionsCollapsed = <
+ item
+ Shift = [ssCtrl]
+ ShiftMask = [ssCtrl]
+ Button = mbLeft
+ ClickCount = ccAny
+ ClickDir = cdDown
+ Command = 15
+ MoveCaret = False
+ Option = 0
+ Priority = 0
+ end
+ item
+ Shift = []
+ ShiftMask = [ssCtrl]
+ Button = mbLeft
+ ClickCount = ccAny
+ ClickDir = cdDown
+ Command = 15
+ MoveCaret = False
+ Option = 1
+ Priority = 0
+ end>
+ end
+ end
+ end
+ object SynMemo1: TSynMemo
+ Cursor = crIBeam
+ Left = 20
+ Height = 125
+ Top = 387
+ Width = 654
+ Font.Height = -13
+ Font.Name = 'Courier New'
+ Font.Pitch = fpFixed
+ Font.Quality = fqNonAntialiased
+ ParentColor = False
+ ParentFont = False
+ TabOrder = 2
+ Gutter.Width = 57
+ Gutter.MouseActions = <
+ item
+ Shift = []
+ ShiftMask = []
+ Button = mbLeft
+ ClickCount = ccAny
+ ClickDir = cdDown
+ Command = 13
+ MoveCaret = False
+ Option = 0
+ Priority = 0
+ end
+ item
+ Shift = []
+ ShiftMask = []
+ Button = mbRight
+ ClickCount = ccSingle
+ ClickDir = cdUp
+ Command = 12
+ MoveCaret = False
+ Option = 0
+ Priority = 0
+ end>
+ Keystrokes = <
+ item
+ Command = ecUp
+ ShortCut = 38
+ end
+ item
+ Command = ecSelUp
+ ShortCut = 8230
+ end
+ item
+ Command = ecScrollUp
+ ShortCut = 16422
+ end
+ item
+ Command = ecDown
+ ShortCut = 40
+ end
+ item
+ Command = ecSelDown
+ ShortCut = 8232
+ end
+ item
+ Command = ecScrollDown
+ ShortCut = 16424
+ end
+ item
+ Command = ecLeft
+ ShortCut = 37
+ end
+ item
+ Command = ecSelLeft
+ ShortCut = 8229
+ end
+ item
+ Command = ecWordLeft
+ ShortCut = 16421
+ end
+ item
+ Command = ecSelWordLeft
+ ShortCut = 24613
+ end
+ item
+ Command = ecRight
+ ShortCut = 39
+ end
+ item
+ Command = ecSelRight
+ ShortCut = 8231
+ end
+ item
+ Command = ecWordRight
+ ShortCut = 16423
+ end
+ item
+ Command = ecSelWordRight
+ ShortCut = 24615
+ end
+ item
+ Command = ecPageDown
+ ShortCut = 34
+ end
+ item
+ Command = ecSelPageDown
+ ShortCut = 8226
+ end
+ item
+ Command = ecPageBottom
+ ShortCut = 16418
+ end
+ item
+ Command = ecSelPageBottom
+ ShortCut = 24610
+ end
+ item
+ Command = ecPageUp
+ ShortCut = 33
+ end
+ item
+ Command = ecSelPageUp
+ ShortCut = 8225
+ end
+ item
+ Command = ecPageTop
+ ShortCut = 16417
+ end
+ item
+ Command = ecSelPageTop
+ ShortCut = 24609
+ end
+ item
+ Command = ecLineStart
+ ShortCut = 36
+ end
+ item
+ Command = ecSelLineStart
+ ShortCut = 8228
+ end
+ item
+ Command = ecEditorTop
+ ShortCut = 16420
+ end
+ item
+ Command = ecSelEditorTop
+ ShortCut = 24612
+ end
+ item
+ Command = ecLineEnd
+ ShortCut = 35
+ end
+ item
+ Command = ecSelLineEnd
+ ShortCut = 8227
+ end
+ item
+ Command = ecEditorBottom
+ ShortCut = 16419
+ end
+ item
+ Command = ecSelEditorBottom
+ ShortCut = 24611
+ end
+ item
+ Command = ecToggleMode
+ ShortCut = 45
+ end
+ item
+ Command = ecCopy
+ ShortCut = 16429
+ end
+ item
+ Command = ecPaste
+ ShortCut = 8237
+ end
+ item
+ Command = ecDeleteChar
+ ShortCut = 46
+ end
+ item
+ Command = ecCut
+ ShortCut = 8238
+ end
+ item
+ Command = ecDeleteLastChar
+ ShortCut = 8
+ end
+ item
+ Command = ecDeleteLastChar
+ ShortCut = 8200
+ end
+ item
+ Command = ecDeleteLastWord
+ ShortCut = 16392
+ end
+ item
+ Command = ecUndo
+ ShortCut = 32776
+ end
+ item
+ Command = ecRedo
+ ShortCut = 40968
+ end
+ item
+ Command = ecLineBreak
+ ShortCut = 13
+ end
+ item
+ Command = ecSelectAll
+ ShortCut = 16449
+ end
+ item
+ Command = ecCopy
+ ShortCut = 16451
+ end
+ item
+ Command = ecBlockIndent
+ ShortCut = 24649
+ end
+ item
+ Command = ecLineBreak
+ ShortCut = 16461
+ end
+ item
+ Command = ecInsertLine
+ ShortCut = 16462
+ end
+ item
+ Command = ecDeleteWord
+ ShortCut = 16468
+ end
+ item
+ Command = ecBlockUnindent
+ ShortCut = 24661
+ end
+ item
+ Command = ecPaste
+ ShortCut = 16470
+ end
+ item
+ Command = ecCut
+ ShortCut = 16472
+ end
+ item
+ Command = ecDeleteLine
+ ShortCut = 16473
+ end
+ item
+ Command = ecDeleteEOL
+ ShortCut = 24665
+ end
+ item
+ Command = ecUndo
+ ShortCut = 16474
+ end
+ item
+ Command = ecRedo
+ ShortCut = 24666
+ end
+ item
+ Command = ecGotoMarker0
+ ShortCut = 16432
+ end
+ item
+ Command = ecGotoMarker1
+ ShortCut = 16433
+ end
+ item
+ Command = ecGotoMarker2
+ ShortCut = 16434
+ end
+ item
+ Command = ecGotoMarker3
+ ShortCut = 16435
+ end
+ item
+ Command = ecGotoMarker4
+ ShortCut = 16436
+ end
+ item
+ Command = ecGotoMarker5
+ ShortCut = 16437
+ end
+ item
+ Command = ecGotoMarker6
+ ShortCut = 16438
+ end
+ item
+ Command = ecGotoMarker7
+ ShortCut = 16439
+ end
+ item
+ Command = ecGotoMarker8
+ ShortCut = 16440
+ end
+ item
+ Command = ecGotoMarker9
+ ShortCut = 16441
+ end
+ item
+ Command = ecSetMarker0
+ ShortCut = 24624
+ end
+ item
+ Command = ecSetMarker1
+ ShortCut = 24625
+ end
+ item
+ Command = ecSetMarker2
+ ShortCut = 24626
+ end
+ item
+ Command = ecSetMarker3
+ ShortCut = 24627
+ end
+ item
+ Command = ecSetMarker4
+ ShortCut = 24628
+ end
+ item
+ Command = ecSetMarker5
+ ShortCut = 24629
+ end
+ item
+ Command = ecSetMarker6
+ ShortCut = 24630
+ end
+ item
+ Command = ecSetMarker7
+ ShortCut = 24631
+ end
+ item
+ Command = ecSetMarker8
+ ShortCut = 24632
+ end
+ item
+ Command = ecSetMarker9
+ ShortCut = 24633
+ end
+ item
+ Command = EcFoldLevel1
+ ShortCut = 41009
+ end
+ item
+ Command = EcFoldLevel2
+ ShortCut = 41010
+ end
+ item
+ Command = EcFoldLevel1
+ ShortCut = 41011
+ end
+ item
+ Command = EcFoldLevel1
+ ShortCut = 41012
+ end
+ item
+ Command = EcFoldLevel1
+ ShortCut = 41013
+ end
+ item
+ Command = EcFoldLevel6
+ ShortCut = 41014
+ end
+ item
+ Command = EcFoldLevel7
+ ShortCut = 41015
+ end
+ item
+ Command = EcFoldLevel8
+ ShortCut = 41016
+ end
+ item
+ Command = EcFoldLevel9
+ ShortCut = 41017
+ end
+ item
+ Command = EcFoldLevel0
+ ShortCut = 41008
+ end
+ item
+ Command = EcFoldCurrent
+ ShortCut = 41005
+ end
+ item
+ Command = EcUnFoldCurrent
+ ShortCut = 41003
+ end
+ item
+ Command = EcToggleMarkupWord
+ ShortCut = 32845
+ end
+ item
+ Command = ecNormalSelect
+ ShortCut = 24654
+ end
+ item
+ Command = ecColumnSelect
+ ShortCut = 24643
+ end
+ item
+ Command = ecLineSelect
+ ShortCut = 24652
+ end
+ item
+ Command = ecTab
+ ShortCut = 9
+ end
+ item
+ Command = ecShiftTab
+ ShortCut = 8201
+ end
+ item
+ Command = ecMatchBracket
+ ShortCut = 24642
+ end
+ item
+ Command = ecColSelUp
+ ShortCut = 40998
+ end
+ item
+ Command = ecColSelDown
+ ShortCut = 41000
+ end
+ item
+ Command = ecColSelLeft
+ ShortCut = 40997
+ end
+ item
+ Command = ecColSelRight
+ ShortCut = 40999
+ end
+ item
+ Command = ecColSelPageDown
+ ShortCut = 40994
+ end
+ item
+ Command = ecColSelPageBottom
+ ShortCut = 57378
+ end
+ item
+ Command = ecColSelPageUp
+ ShortCut = 40993
+ end
+ item
+ Command = ecColSelPageTop
+ ShortCut = 57377
+ end
+ item
+ Command = ecColSelLineStart
+ ShortCut = 40996
+ end
+ item
+ Command = ecColSelLineEnd
+ ShortCut = 40995
+ end
+ item
+ Command = ecColSelEditorTop
+ ShortCut = 57380
+ end
+ item
+ Command = ecColSelEditorBottom
+ ShortCut = 57379
+ end>
+ MouseActions = <
+ item
+ Shift = []
+ ShiftMask = [ssShift, ssAlt]
+ Button = mbLeft
+ ClickCount = ccSingle
+ ClickDir = cdDown
+ Command = 1
+ MoveCaret = True
+ Option = 0
+ Priority = 0
+ end
+ item
+ Shift = [ssShift]
+ ShiftMask = [ssShift, ssAlt]
+ Button = mbLeft
+ ClickCount = ccSingle
+ ClickDir = cdDown
+ Command = 1
+ MoveCaret = True
+ Option = 1
+ Priority = 0
+ end
+ item
+ Shift = [ssAlt]
+ ShiftMask = [ssShift, ssAlt]
+ Button = mbLeft
+ ClickCount = ccSingle
+ ClickDir = cdDown
+ Command = 3
+ MoveCaret = True
+ Option = 0
+ Priority = 0
+ end
+ item
+ Shift = [ssShift, ssAlt]
+ ShiftMask = [ssShift, ssAlt]
+ Button = mbLeft
+ ClickCount = ccSingle
+ ClickDir = cdDown
+ Command = 3
+ MoveCaret = True
+ Option = 1
+ Priority = 0
+ end
+ item
+ Shift = []
+ ShiftMask = []
+ Button = mbRight
+ ClickCount = ccSingle
+ ClickDir = cdUp
+ Command = 12
+ MoveCaret = False
+ Option = 0
+ Priority = 0
+ end
+ item
+ Shift = []
+ ShiftMask = []
+ Button = mbLeft
+ ClickCount = ccDouble
+ ClickDir = cdDown
+ Command = 6
+ MoveCaret = True
+ Option = 0
+ Priority = 0
+ end
+ item
+ Shift = []
+ ShiftMask = []
+ Button = mbLeft
+ ClickCount = ccTriple
+ ClickDir = cdDown
+ Command = 7
+ MoveCaret = True
+ Option = 0
+ Priority = 0
+ end
+ item
+ Shift = []
+ ShiftMask = []
+ Button = mbLeft
+ ClickCount = ccQuad
+ ClickDir = cdDown
+ Command = 8
+ MoveCaret = True
+ Option = 0
+ Priority = 0
+ end
+ item
+ Shift = []
+ ShiftMask = []
+ Button = mbMiddle
+ ClickCount = ccSingle
+ ClickDir = cdDown
+ Command = 10
+ MoveCaret = True
+ Option = 0
+ Priority = 0
+ end
+ item
+ Shift = [ssCtrl]
+ ShiftMask = [ssShift, ssAlt, ssCtrl]
+ Button = mbLeft
+ ClickCount = ccSingle
+ ClickDir = cdUp
+ Command = 11
+ MoveCaret = False
+ Option = 0
+ Priority = 0
+ end>
+ MouseSelActions = <
+ item
+ Shift = []
+ ShiftMask = []
+ Button = mbLeft
+ ClickCount = ccSingle
+ ClickDir = cdDown
+ Command = 9
+ MoveCaret = False
+ Option = 0
+ Priority = 0
+ end>
+ Lines.Strings = (
+ 'SynMemo1'
+ )
+ OnChange = SynMemo1Change
+ object TSynGutterPartList
+ object TSynGutterMarks
+ Width = 23
+ end
+ object TSynGutterLineNumber
+ Width = 17
+ MouseActions = <>
+ MarkupInfo.Background = clBtnFace
+ MarkupInfo.Foreground = clNone
+ DigitCount = 2
+ ShowOnlyLineNumbersMultiplesOf = 1
+ ZeroStart = False
+ LeadingZeros = False
+ end
+ object TSynGutterChanges
+ Width = 4
+ ModifiedColor = 59900
+ SavedColor = clGreen
+ end
+ object TSynGutterSeparator
+ Width = 2
+ end
+ object TSynGutterCodeFolding
+ MouseActions = <
+ item
+ Shift = []
+ ShiftMask = []
+ Button = mbRight
+ ClickCount = ccSingle
+ ClickDir = cdUp
+ Command = 16
+ MoveCaret = False
+ Option = 0
+ Priority = 0
+ end
+ item
+ Shift = []
+ ShiftMask = [ssShift]
+ Button = mbMiddle
+ ClickCount = ccAny
+ ClickDir = cdDown
+ Command = 14
+ MoveCaret = False
+ Option = 0
+ Priority = 0
+ end
+ item
+ Shift = [ssShift]
+ ShiftMask = [ssShift]
+ Button = mbMiddle
+ ClickCount = ccAny
+ ClickDir = cdDown
+ Command = 14
+ MoveCaret = False
+ Option = 1
+ Priority = 0
+ end
+ item
+ Shift = []
+ ShiftMask = []
+ Button = mbLeft
+ ClickCount = ccAny
+ ClickDir = cdDown
+ Command = 0
+ MoveCaret = False
+ Option = 0
+ Priority = 0
+ end>
+ MarkupInfo.Background = clNone
+ MarkupInfo.Foreground = clGray
+ MouseActionsExpanded = <
+ item
+ Shift = []
+ ShiftMask = []
+ Button = mbLeft
+ ClickCount = ccAny
+ ClickDir = cdDown
+ Command = 14
+ MoveCaret = False
+ Option = 0
+ Priority = 0
+ end>
+ MouseActionsCollapsed = <
+ item
+ Shift = [ssCtrl]
+ ShiftMask = [ssCtrl]
+ Button = mbLeft
+ ClickCount = ccAny
+ ClickDir = cdDown
+ Command = 15
+ MoveCaret = False
+ Option = 0
+ Priority = 0
+ end
+ item
+ Shift = []
+ ShiftMask = [ssCtrl]
+ Button = mbLeft
+ ClickCount = ccAny
+ ClickDir = cdDown
+ Command = 15
+ MoveCaret = False
+ Option = 1
+ Priority = 0
+ end>
+ end
+ end
+ end
+ object SynFreePascalSyn1: TSynFreePascalSyn
+ Enabled = False
+ CompilerMode = pcmObjFPC
+ NestedComments = True
+ left = 498
+ top = 89
+ end
end
diff --git a/Projects/SAMufasaGUI/testunit.lrs b/Projects/SAMufasaGUI/testunit.lrs
index 0223a6d..b39f748 100644
--- a/Projects/SAMufasaGUI/testunit.lrs
+++ b/Projects/SAMufasaGUI/testunit.lrs
@@ -1,10 +1,286 @@
-{ This is an automatically generated lazarus resource file }
-
-LazarusResources.Add('TForm1','FORMDATA',[
- 'TPF0'#6'TForm1'#5'Form1'#4'Left'#3'q'#1#6'Height'#3#15#2#3'Top'#3#223#0#5'Wi'
- +'dth'#3#11#3#13'ActiveControl'#7#7'Button1'#7'Caption'#6#5'Form1'#12'ClientH'
- +'eight'#3#15#2#11'ClientWidth'#3#11#3#8'Position'#7#14'poScreenCenter'#10'LC'
- +'LVersion'#6#6'0.9.29'#0#7'TButton'#7'Button1'#4'Left'#2#8#6'Height'#2#25#3
- +'Top'#2#16#5'Width'#2'K'#7'Caption'#6#7'Button1'#7'OnClick'#7#12'Button1Clic'
- +'k'#8'TabOrder'#2#0#0#0#0
-]);
+{ This is an automatically generated lazarus resource file }
+
+LazarusResources.Add('TForm1','FORMDATA',[
+ 'TPF0'#6'TForm1'#5'Form1'#4'Left'#3'q'#1#6'Height'#3#15#2#3'Top'#3#223#0#5'Wi'
+ +'dth'#3#11#3#13'ActiveControl'#7#7'Button1'#7'Caption'#6#5'Form1'#12'ClientH'
+ +'eight'#3#15#2#11'ClientWidth'#3#11#3#8'Position'#7#14'poScreenCenter'#10'LC'
+ +'LVersion'#6#6'0.9.29'#0#7'TButton'#7'Button1'#4'Left'#2#8#6'Height'#2#25#3
+ +'Top'#2#16#5'Width'#2'K'#7'Caption'#6#3'Run'#7'OnClick'#7#12'Button1Click'#8
+ +'TabOrder'#2#0#0#0#8'TSynEdit'#8'SynEdit1'#4'Left'#2#8#6'Height'#3'('#1#3'To'
+ +'p'#2'@'#5'Width'#3#216#2#5'Align'#7#8'alCustom'#11'Font.Height'#2#243#9'Fon'
+ +'t.Name'#6#11'Courier New'#10'Font.Pitch'#7#7'fpFixed'#12'Font.Quality'#7#16
+ +'fqNonAntialiased'#11'ParentColor'#8#10'ParentFont'#8#8'TabOrder'#2#1#12'Gut'
+ +'ter.Width'#2'9'#19'Gutter.MouseActions'#14#1#5'Shift'#11#0#9'ShiftMask'#11#0
+ +#6'Button'#7#6'mbLeft'#10'ClickCount'#7#5'ccAny'#8'ClickDir'#7#6'cdDown'#7'C'
+ +'ommand'#2#13#9'MoveCaret'#8#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#0
+ +#9'ShiftMask'#11#0#6'Button'#7#7'mbRight'#10'ClickCount'#7#8'ccSingle'#8'Cli'
+ +'ckDir'#7#4'cdUp'#7'Command'#2#12#9'MoveCaret'#8#6'Option'#2#0#8'Priority'#2
+ +#0#0#0#11'Highlighter'#7#17'SynFreePascalSyn1'#10'Keystrokes'#14#1#7'Command'
+ +#7#4'ecUp'#8'ShortCut'#2'&'#0#1#7'Command'#7#7'ecSelUp'#8'ShortCut'#3'& '#0#1
+ +#7'Command'#7#10'ecScrollUp'#8'ShortCut'#3'&@'#0#1#7'Command'#7#6'ecDown'#8
+ +'ShortCut'#2'('#0#1#7'Command'#7#9'ecSelDown'#8'ShortCut'#3'( '#0#1#7'Comman'
+ +'d'#7#12'ecScrollDown'#8'ShortCut'#3'(@'#0#1#7'Command'#7#6'ecLeft'#8'ShortC'
+ +'ut'#2'%'#0#1#7'Command'#7#9'ecSelLeft'#8'ShortCut'#3'% '#0#1#7'Command'#7#10
+ +'ecWordLeft'#8'ShortCut'#3'%@'#0#1#7'Command'#7#13'ecSelWordLeft'#8'ShortCut'
+ +#3'%`'#0#1#7'Command'#7#7'ecRight'#8'ShortCut'#2''''#0#1#7'Command'#7#10'ecS'
+ +'elRight'#8'ShortCut'#3''' '#0#1#7'Command'#7#11'ecWordRight'#8'ShortCut'#3
+ +'''@'#0#1#7'Command'#7#14'ecSelWordRight'#8'ShortCut'#3'''`'#0#1#7'Command'#7
+ +#10'ecPageDown'#8'ShortCut'#2'"'#0#1#7'Command'#7#13'ecSelPageDown'#8'ShortC'
+ +'ut'#3'" '#0#1#7'Command'#7#12'ecPageBottom'#8'ShortCut'#3'"@'#0#1#7'Command'
+ +#7#15'ecSelPageBottom'#8'ShortCut'#3'"`'#0#1#7'Command'#7#8'ecPageUp'#8'Shor'
+ +'tCut'#2'!'#0#1#7'Command'#7#11'ecSelPageUp'#8'ShortCut'#3'! '#0#1#7'Command'
+ +#7#9'ecPageTop'#8'ShortCut'#3'!@'#0#1#7'Command'#7#12'ecSelPageTop'#8'ShortC'
+ +'ut'#3'!`'#0#1#7'Command'#7#11'ecLineStart'#8'ShortCut'#2'$'#0#1#7'Command'#7
+ +#14'ecSelLineStart'#8'ShortCut'#3'$ '#0#1#7'Command'#7#11'ecEditorTop'#8'Sho'
+ +'rtCut'#3'$@'#0#1#7'Command'#7#14'ecSelEditorTop'#8'ShortCut'#3'$`'#0#1#7'Co'
+ +'mmand'#7#9'ecLineEnd'#8'ShortCut'#2'#'#0#1#7'Command'#7#12'ecSelLineEnd'#8
+ +'ShortCut'#3'# '#0#1#7'Command'#7#14'ecEditorBottom'#8'ShortCut'#3'#@'#0#1#7
+ +'Command'#7#17'ecSelEditorBottom'#8'ShortCut'#3'#`'#0#1#7'Command'#7#12'ecTo'
+ +'ggleMode'#8'ShortCut'#2'-'#0#1#7'Command'#7#6'ecCopy'#8'ShortCut'#3'-@'#0#1
+ +#7'Command'#7#7'ecPaste'#8'ShortCut'#3'- '#0#1#7'Command'#7#12'ecDeleteChar'
+ +#8'ShortCut'#2'.'#0#1#7'Command'#7#5'ecCut'#8'ShortCut'#3'. '#0#1#7'Command'
+ +#7#16'ecDeleteLastChar'#8'ShortCut'#2#8#0#1#7'Command'#7#16'ecDeleteLastChar'
+ +#8'ShortCut'#3#8' '#0#1#7'Command'#7#16'ecDeleteLastWord'#8'ShortCut'#3#8'@'
+ +#0#1#7'Command'#7#6'ecUndo'#8'ShortCut'#4#8#128#0#0#0#1#7'Command'#7#6'ecRed'
+ +'o'#8'ShortCut'#4#8#160#0#0#0#1#7'Command'#7#11'ecLineBreak'#8'ShortCut'#2#13
+ +#0#1#7'Command'#7#11'ecSelectAll'#8'ShortCut'#3'A@'#0#1#7'Command'#7#6'ecCop'
+ +'y'#8'ShortCut'#3'C@'#0#1#7'Command'#7#13'ecBlockIndent'#8'ShortCut'#3'I`'#0
+ +#1#7'Command'#7#11'ecLineBreak'#8'ShortCut'#3'M@'#0#1#7'Command'#7#12'ecInse'
+ +'rtLine'#8'ShortCut'#3'N@'#0#1#7'Command'#7#12'ecDeleteWord'#8'ShortCut'#3'T'
+ +'@'#0#1#7'Command'#7#15'ecBlockUnindent'#8'ShortCut'#3'U`'#0#1#7'Command'#7#7
+ +'ecPaste'#8'ShortCut'#3'V@'#0#1#7'Command'#7#5'ecCut'#8'ShortCut'#3'X@'#0#1#7
+ +'Command'#7#12'ecDeleteLine'#8'ShortCut'#3'Y@'#0#1#7'Command'#7#11'ecDeleteE'
+ +'OL'#8'ShortCut'#3'Y`'#0#1#7'Command'#7#6'ecUndo'#8'ShortCut'#3'Z@'#0#1#7'Co'
+ +'mmand'#7#6'ecRedo'#8'ShortCut'#3'Z`'#0#1#7'Command'#7#13'ecGotoMarker0'#8'S'
+ +'hortCut'#3'0@'#0#1#7'Command'#7#13'ecGotoMarker1'#8'ShortCut'#3'1@'#0#1#7'C'
+ +'ommand'#7#13'ecGotoMarker2'#8'ShortCut'#3'2@'#0#1#7'Command'#7#13'ecGotoMar'
+ +'ker3'#8'ShortCut'#3'3@'#0#1#7'Command'#7#13'ecGotoMarker4'#8'ShortCut'#3'4@'
+ +#0#1#7'Command'#7#13'ecGotoMarker5'#8'ShortCut'#3'5@'#0#1#7'Command'#7#13'ec'
+ +'GotoMarker6'#8'ShortCut'#3'6@'#0#1#7'Command'#7#13'ecGotoMarker7'#8'ShortCu'
+ +'t'#3'7@'#0#1#7'Command'#7#13'ecGotoMarker8'#8'ShortCut'#3'8@'#0#1#7'Command'
+ +#7#13'ecGotoMarker9'#8'ShortCut'#3'9@'#0#1#7'Command'#7#12'ecSetMarker0'#8'S'
+ +'hortCut'#3'0`'#0#1#7'Command'#7#12'ecSetMarker1'#8'ShortCut'#3'1`'#0#1#7'Co'
+ +'mmand'#7#12'ecSetMarker2'#8'ShortCut'#3'2`'#0#1#7'Command'#7#12'ecSetMarker'
+ +'3'#8'ShortCut'#3'3`'#0#1#7'Command'#7#12'ecSetMarker4'#8'ShortCut'#3'4`'#0#1
+ +#7'Command'#7#12'ecSetMarker5'#8'ShortCut'#3'5`'#0#1#7'Command'#7#12'ecSetMa'
+ +'rker6'#8'ShortCut'#3'6`'#0#1#7'Command'#7#12'ecSetMarker7'#8'ShortCut'#3'7`'
+ +#0#1#7'Command'#7#12'ecSetMarker8'#8'ShortCut'#3'8`'#0#1#7'Command'#7#12'ecS'
+ ,'etMarker9'#8'ShortCut'#3'9`'#0#1#7'Command'#7#12'EcFoldLevel1'#8'ShortCut'#4
+ +'1'#160#0#0#0#1#7'Command'#7#12'EcFoldLevel2'#8'ShortCut'#4'2'#160#0#0#0#1#7
+ +'Command'#7#12'EcFoldLevel1'#8'ShortCut'#4'3'#160#0#0#0#1#7'Command'#7#12'Ec'
+ +'FoldLevel1'#8'ShortCut'#4'4'#160#0#0#0#1#7'Command'#7#12'EcFoldLevel1'#8'Sh'
+ +'ortCut'#4'5'#160#0#0#0#1#7'Command'#7#12'EcFoldLevel6'#8'ShortCut'#4'6'#160
+ +#0#0#0#1#7'Command'#7#12'EcFoldLevel7'#8'ShortCut'#4'7'#160#0#0#0#1#7'Comman'
+ +'d'#7#12'EcFoldLevel8'#8'ShortCut'#4'8'#160#0#0#0#1#7'Command'#7#12'EcFoldLe'
+ +'vel9'#8'ShortCut'#4'9'#160#0#0#0#1#7'Command'#7#12'EcFoldLevel0'#8'ShortCut'
+ +#4'0'#160#0#0#0#1#7'Command'#7#13'EcFoldCurrent'#8'ShortCut'#4'-'#160#0#0#0#1
+ +#7'Command'#7#15'EcUnFoldCurrent'#8'ShortCut'#4'+'#160#0#0#0#1#7'Command'#7
+ +#18'EcToggleMarkupWord'#8'ShortCut'#4'M'#128#0#0#0#1#7'Command'#7#14'ecNorma'
+ +'lSelect'#8'ShortCut'#3'N`'#0#1#7'Command'#7#14'ecColumnSelect'#8'ShortCut'#3
+ +'C`'#0#1#7'Command'#7#12'ecLineSelect'#8'ShortCut'#3'L`'#0#1#7'Command'#7#5
+ +'ecTab'#8'ShortCut'#2#9#0#1#7'Command'#7#10'ecShiftTab'#8'ShortCut'#3#9' '#0
+ +#1#7'Command'#7#14'ecMatchBracket'#8'ShortCut'#3'B`'#0#1#7'Command'#7#10'ecC'
+ +'olSelUp'#8'ShortCut'#4'&'#160#0#0#0#1#7'Command'#7#12'ecColSelDown'#8'Short'
+ +'Cut'#4'('#160#0#0#0#1#7'Command'#7#12'ecColSelLeft'#8'ShortCut'#4'%'#160#0#0
+ +#0#1#7'Command'#7#13'ecColSelRight'#8'ShortCut'#4''''#160#0#0#0#1#7'Command'
+ +#7#16'ecColSelPageDown'#8'ShortCut'#4'"'#160#0#0#0#1#7'Command'#7#18'ecColSe'
+ +'lPageBottom'#8'ShortCut'#4'"'#224#0#0#0#1#7'Command'#7#14'ecColSelPageUp'#8
+ +'ShortCut'#4'!'#160#0#0#0#1#7'Command'#7#15'ecColSelPageTop'#8'ShortCut'#4'!'
+ +#224#0#0#0#1#7'Command'#7#17'ecColSelLineStart'#8'ShortCut'#4'$'#160#0#0#0#1
+ +#7'Command'#7#15'ecColSelLineEnd'#8'ShortCut'#4'#'#160#0#0#0#1#7'Command'#7
+ +#17'ecColSelEditorTop'#8'ShortCut'#4'$'#224#0#0#0#1#7'Command'#7#20'ecColSel'
+ +'EditorBottom'#8'ShortCut'#4'#'#224#0#0#0#0#12'MouseActions'#14#1#5'Shift'#11
+ +#0#9'ShiftMask'#11#7'ssShift'#5'ssAlt'#0#6'Button'#7#6'mbLeft'#10'ClickCount'
+ +#7#8'ccSingle'#8'ClickDir'#7#6'cdDown'#7'Command'#2#1#9'MoveCaret'#9#6'Optio'
+ +'n'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#7'ssShift'#0#9'ShiftMask'#11#7'ssShi'
+ +'ft'#5'ssAlt'#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#8'ccSingle'#8'ClickDi'
+ +'r'#7#6'cdDown'#7'Command'#2#1#9'MoveCaret'#9#6'Option'#2#1#8'Priority'#2#0#0
+ +#1#5'Shift'#11#5'ssAlt'#0#9'ShiftMask'#11#7'ssShift'#5'ssAlt'#0#6'Button'#7#6
+ +'mbLeft'#10'ClickCount'#7#8'ccSingle'#8'ClickDir'#7#6'cdDown'#7'Command'#2#3
+ +#9'MoveCaret'#9#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#7'ssShift'#5's'
+ +'sAlt'#0#9'ShiftMask'#11#7'ssShift'#5'ssAlt'#0#6'Button'#7#6'mbLeft'#10'Clic'
+ +'kCount'#7#8'ccSingle'#8'ClickDir'#7#6'cdDown'#7'Command'#2#3#9'MoveCaret'#9
+ +#6'Option'#2#1#8'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMask'#11#0#6'Button'
+ +#7#7'mbRight'#10'ClickCount'#7#8'ccSingle'#8'ClickDir'#7#4'cdUp'#7'Command'#2
+ +#12#9'MoveCaret'#8#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMa'
+ +'sk'#11#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#8'ccDouble'#8'ClickDir'#7#6
+ +'cdDown'#7'Command'#2#6#9'MoveCaret'#9#6'Option'#2#0#8'Priority'#2#0#0#1#5'S'
+ +'hift'#11#0#9'ShiftMask'#11#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#8'ccTri'
+ +'ple'#8'ClickDir'#7#6'cdDown'#7'Command'#2#7#9'MoveCaret'#9#6'Option'#2#0#8
+ +'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMask'#11#0#6'Button'#7#6'mbLeft'#10
+ +'ClickCount'#7#6'ccQuad'#8'ClickDir'#7#6'cdDown'#7'Command'#2#8#9'MoveCaret'
+ +#9#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMask'#11#0#6'Butto'
+ +'n'#7#8'mbMiddle'#10'ClickCount'#7#8'ccSingle'#8'ClickDir'#7#6'cdDown'#7'Com'
+ +'mand'#2#10#9'MoveCaret'#9#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#6's'
+ +'sCtrl'#0#9'ShiftMask'#11#7'ssShift'#5'ssAlt'#6'ssCtrl'#0#6'Button'#7#6'mbLe'
+ +'ft'#10'ClickCount'#7#8'ccSingle'#8'ClickDir'#7#4'cdUp'#7'Command'#2#11#9'Mo'
+ +'veCaret'#8#6'Option'#2#0#8'Priority'#2#0#0#0#15'MouseSelActions'#14#1#5'Shi'
+ +'ft'#11#0#9'ShiftMask'#11#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#8'ccSingl'
+ +'e'#8'ClickDir'#7#6'cdDown'#7'Command'#2#9#9'MoveCaret'#8#6'Option'#2#0#8'Pr'
+ +'iority'#2#0#0#0#13'Lines.Strings'#1#6#12'program new;'#6#5'begin'#6#4'end.'
+ +#0#21'BracketHighlightStyle'#7#8'sbhsBoth'#0#18'TSynGutterPartList'#0#0#15'T'
+ +'SynGutterMarks'#0#5'Width'#2#23#0#0#20'TSynGutterLineNumber'#0#5'Width'#2#17
+ +#12'MouseActions'#14#0#21'MarkupInfo.Background'#7#9'clBtnFace'#21'MarkupInf'
+ +'o.Foreground'#7#6'clNone'#10'DigitCount'#2#2#30'ShowOnlyLineNumbersMultiple'
+ +'sOf'#2#1#9'ZeroStart'#8#12'LeadingZeros'#8#0#0#17'TSynGutterChanges'#0#5'Wi'
+ +'dth'#2#4#13'ModifiedColor'#4#252#233#0#0#10'SavedColor'#7#7'clGreen'#0#0#19
+ +'TSynGutterSeparator'#0#5'Width'#2#2#0#0#21'TSynGutterCodeFolding'#0#12'Mous'
+ +'eActions'#14#1#5'Shift'#11#0#9'ShiftMask'#11#0#6'Button'#7#7'mbRight'#10'Cl'
+ +'ickCount'#7#8'ccSingle'#8'ClickDir'#7#4'cdUp'#7'Command'#2#16#9'MoveCaret'#8
+ +#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMask'#11#7'ssShift'#0
+ +#6'Button'#7#8'mbMiddle'#10'ClickCount'#7#5'ccAny'#8'ClickDir'#7#6'cdDown'#7
+ ,'Command'#2#14#9'MoveCaret'#8#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#7
+ +'ssShift'#0#9'ShiftMask'#11#7'ssShift'#0#6'Button'#7#8'mbMiddle'#10'ClickCou'
+ +'nt'#7#5'ccAny'#8'ClickDir'#7#6'cdDown'#7'Command'#2#14#9'MoveCaret'#8#6'Opt'
+ +'ion'#2#1#8'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMask'#11#0#6'Button'#7#6
+ +'mbLeft'#10'ClickCount'#7#5'ccAny'#8'ClickDir'#7#6'cdDown'#7'Command'#2#0#9
+ +'MoveCaret'#8#6'Option'#2#0#8'Priority'#2#0#0#0#21'MarkupInfo.Background'#7#6
+ +'clNone'#21'MarkupInfo.Foreground'#7#6'clGray'#20'MouseActionsExpanded'#14#1
+ +#5'Shift'#11#0#9'ShiftMask'#11#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#5'cc'
+ +'Any'#8'ClickDir'#7#6'cdDown'#7'Command'#2#14#9'MoveCaret'#8#6'Option'#2#0#8
+ +'Priority'#2#0#0#0#21'MouseActionsCollapsed'#14#1#5'Shift'#11#6'ssCtrl'#0#9
+ +'ShiftMask'#11#6'ssCtrl'#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#5'ccAny'#8
+ +'ClickDir'#7#6'cdDown'#7'Command'#2#15#9'MoveCaret'#8#6'Option'#2#0#8'Priori'
+ +'ty'#2#0#0#1#5'Shift'#11#0#9'ShiftMask'#11#6'ssCtrl'#0#6'Button'#7#6'mbLeft'
+ +#10'ClickCount'#7#5'ccAny'#8'ClickDir'#7#6'cdDown'#7'Command'#2#15#9'MoveCar'
+ +'et'#8#6'Option'#2#1#8'Priority'#2#0#0#0#0#0#0#0#8'TSynMemo'#8'SynMemo1'#6'C'
+ +'ursor'#7#7'crIBeam'#4'Left'#2#20#6'Height'#2'}'#3'Top'#3#131#1#5'Width'#3
+ +#142#2#11'Font.Height'#2#243#9'Font.Name'#6#11'Courier New'#10'Font.Pitch'#7
+ +#7'fpFixed'#12'Font.Quality'#7#16'fqNonAntialiased'#11'ParentColor'#8#10'Par'
+ +'entFont'#8#8'TabOrder'#2#2#12'Gutter.Width'#2'9'#19'Gutter.MouseActions'#14
+ +#1#5'Shift'#11#0#9'ShiftMask'#11#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#5
+ +'ccAny'#8'ClickDir'#7#6'cdDown'#7'Command'#2#13#9'MoveCaret'#8#6'Option'#2#0
+ +#8'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMask'#11#0#6'Button'#7#7'mbRight'
+ +#10'ClickCount'#7#8'ccSingle'#8'ClickDir'#7#4'cdUp'#7'Command'#2#12#9'MoveCa'
+ +'ret'#8#6'Option'#2#0#8'Priority'#2#0#0#0#10'Keystrokes'#14#1#7'Command'#7#4
+ +'ecUp'#8'ShortCut'#2'&'#0#1#7'Command'#7#7'ecSelUp'#8'ShortCut'#3'& '#0#1#7
+ +'Command'#7#10'ecScrollUp'#8'ShortCut'#3'&@'#0#1#7'Command'#7#6'ecDown'#8'Sh'
+ +'ortCut'#2'('#0#1#7'Command'#7#9'ecSelDown'#8'ShortCut'#3'( '#0#1#7'Command'
+ +#7#12'ecScrollDown'#8'ShortCut'#3'(@'#0#1#7'Command'#7#6'ecLeft'#8'ShortCut'
+ +#2'%'#0#1#7'Command'#7#9'ecSelLeft'#8'ShortCut'#3'% '#0#1#7'Command'#7#10'ec'
+ +'WordLeft'#8'ShortCut'#3'%@'#0#1#7'Command'#7#13'ecSelWordLeft'#8'ShortCut'#3
+ +'%`'#0#1#7'Command'#7#7'ecRight'#8'ShortCut'#2''''#0#1#7'Command'#7#10'ecSel'
+ +'Right'#8'ShortCut'#3''' '#0#1#7'Command'#7#11'ecWordRight'#8'ShortCut'#3''''
+ +'@'#0#1#7'Command'#7#14'ecSelWordRight'#8'ShortCut'#3'''`'#0#1#7'Command'#7
+ +#10'ecPageDown'#8'ShortCut'#2'"'#0#1#7'Command'#7#13'ecSelPageDown'#8'ShortC'
+ +'ut'#3'" '#0#1#7'Command'#7#12'ecPageBottom'#8'ShortCut'#3'"@'#0#1#7'Command'
+ +#7#15'ecSelPageBottom'#8'ShortCut'#3'"`'#0#1#7'Command'#7#8'ecPageUp'#8'Shor'
+ +'tCut'#2'!'#0#1#7'Command'#7#11'ecSelPageUp'#8'ShortCut'#3'! '#0#1#7'Command'
+ +#7#9'ecPageTop'#8'ShortCut'#3'!@'#0#1#7'Command'#7#12'ecSelPageTop'#8'ShortC'
+ +'ut'#3'!`'#0#1#7'Command'#7#11'ecLineStart'#8'ShortCut'#2'$'#0#1#7'Command'#7
+ +#14'ecSelLineStart'#8'ShortCut'#3'$ '#0#1#7'Command'#7#11'ecEditorTop'#8'Sho'
+ +'rtCut'#3'$@'#0#1#7'Command'#7#14'ecSelEditorTop'#8'ShortCut'#3'$`'#0#1#7'Co'
+ +'mmand'#7#9'ecLineEnd'#8'ShortCut'#2'#'#0#1#7'Command'#7#12'ecSelLineEnd'#8
+ +'ShortCut'#3'# '#0#1#7'Command'#7#14'ecEditorBottom'#8'ShortCut'#3'#@'#0#1#7
+ +'Command'#7#17'ecSelEditorBottom'#8'ShortCut'#3'#`'#0#1#7'Command'#7#12'ecTo'
+ +'ggleMode'#8'ShortCut'#2'-'#0#1#7'Command'#7#6'ecCopy'#8'ShortCut'#3'-@'#0#1
+ +#7'Command'#7#7'ecPaste'#8'ShortCut'#3'- '#0#1#7'Command'#7#12'ecDeleteChar'
+ +#8'ShortCut'#2'.'#0#1#7'Command'#7#5'ecCut'#8'ShortCut'#3'. '#0#1#7'Command'
+ +#7#16'ecDeleteLastChar'#8'ShortCut'#2#8#0#1#7'Command'#7#16'ecDeleteLastChar'
+ +#8'ShortCut'#3#8' '#0#1#7'Command'#7#16'ecDeleteLastWord'#8'ShortCut'#3#8'@'
+ +#0#1#7'Command'#7#6'ecUndo'#8'ShortCut'#4#8#128#0#0#0#1#7'Command'#7#6'ecRed'
+ +'o'#8'ShortCut'#4#8#160#0#0#0#1#7'Command'#7#11'ecLineBreak'#8'ShortCut'#2#13
+ +#0#1#7'Command'#7#11'ecSelectAll'#8'ShortCut'#3'A@'#0#1#7'Command'#7#6'ecCop'
+ +'y'#8'ShortCut'#3'C@'#0#1#7'Command'#7#13'ecBlockIndent'#8'ShortCut'#3'I`'#0
+ +#1#7'Command'#7#11'ecLineBreak'#8'ShortCut'#3'M@'#0#1#7'Command'#7#12'ecInse'
+ +'rtLine'#8'ShortCut'#3'N@'#0#1#7'Command'#7#12'ecDeleteWord'#8'ShortCut'#3'T'
+ +'@'#0#1#7'Command'#7#15'ecBlockUnindent'#8'ShortCut'#3'U`'#0#1#7'Command'#7#7
+ +'ecPaste'#8'ShortCut'#3'V@'#0#1#7'Command'#7#5'ecCut'#8'ShortCut'#3'X@'#0#1#7
+ +'Command'#7#12'ecDeleteLine'#8'ShortCut'#3'Y@'#0#1#7'Command'#7#11'ecDeleteE'
+ +'OL'#8'ShortCut'#3'Y`'#0#1#7'Command'#7#6'ecUndo'#8'ShortCut'#3'Z@'#0#1#7'Co'
+ +'mmand'#7#6'ecRedo'#8'ShortCut'#3'Z`'#0#1#7'Command'#7#13'ecGotoMarker0'#8'S'
+ +'hortCut'#3'0@'#0#1#7'Command'#7#13'ecGotoMarker1'#8'ShortCut'#3'1@'#0#1#7'C'
+ +'ommand'#7#13'ecGotoMarker2'#8'ShortCut'#3'2@'#0#1#7'Command'#7#13'ecGotoMar'
+ +'ker3'#8'ShortCut'#3'3@'#0#1#7'Command'#7#13'ecGotoMarker4'#8'ShortCut'#3'4@'
+ +#0#1#7'Command'#7#13'ecGotoMarker5'#8'ShortCut'#3'5@'#0#1#7'Command'#7#13'ec'
+ ,'GotoMarker6'#8'ShortCut'#3'6@'#0#1#7'Command'#7#13'ecGotoMarker7'#8'ShortCu'
+ +'t'#3'7@'#0#1#7'Command'#7#13'ecGotoMarker8'#8'ShortCut'#3'8@'#0#1#7'Command'
+ +#7#13'ecGotoMarker9'#8'ShortCut'#3'9@'#0#1#7'Command'#7#12'ecSetMarker0'#8'S'
+ +'hortCut'#3'0`'#0#1#7'Command'#7#12'ecSetMarker1'#8'ShortCut'#3'1`'#0#1#7'Co'
+ +'mmand'#7#12'ecSetMarker2'#8'ShortCut'#3'2`'#0#1#7'Command'#7#12'ecSetMarker'
+ +'3'#8'ShortCut'#3'3`'#0#1#7'Command'#7#12'ecSetMarker4'#8'ShortCut'#3'4`'#0#1
+ +#7'Command'#7#12'ecSetMarker5'#8'ShortCut'#3'5`'#0#1#7'Command'#7#12'ecSetMa'
+ +'rker6'#8'ShortCut'#3'6`'#0#1#7'Command'#7#12'ecSetMarker7'#8'ShortCut'#3'7`'
+ +#0#1#7'Command'#7#12'ecSetMarker8'#8'ShortCut'#3'8`'#0#1#7'Command'#7#12'ecS'
+ +'etMarker9'#8'ShortCut'#3'9`'#0#1#7'Command'#7#12'EcFoldLevel1'#8'ShortCut'#4
+ +'1'#160#0#0#0#1#7'Command'#7#12'EcFoldLevel2'#8'ShortCut'#4'2'#160#0#0#0#1#7
+ +'Command'#7#12'EcFoldLevel1'#8'ShortCut'#4'3'#160#0#0#0#1#7'Command'#7#12'Ec'
+ +'FoldLevel1'#8'ShortCut'#4'4'#160#0#0#0#1#7'Command'#7#12'EcFoldLevel1'#8'Sh'
+ +'ortCut'#4'5'#160#0#0#0#1#7'Command'#7#12'EcFoldLevel6'#8'ShortCut'#4'6'#160
+ +#0#0#0#1#7'Command'#7#12'EcFoldLevel7'#8'ShortCut'#4'7'#160#0#0#0#1#7'Comman'
+ +'d'#7#12'EcFoldLevel8'#8'ShortCut'#4'8'#160#0#0#0#1#7'Command'#7#12'EcFoldLe'
+ +'vel9'#8'ShortCut'#4'9'#160#0#0#0#1#7'Command'#7#12'EcFoldLevel0'#8'ShortCut'
+ +#4'0'#160#0#0#0#1#7'Command'#7#13'EcFoldCurrent'#8'ShortCut'#4'-'#160#0#0#0#1
+ +#7'Command'#7#15'EcUnFoldCurrent'#8'ShortCut'#4'+'#160#0#0#0#1#7'Command'#7
+ +#18'EcToggleMarkupWord'#8'ShortCut'#4'M'#128#0#0#0#1#7'Command'#7#14'ecNorma'
+ +'lSelect'#8'ShortCut'#3'N`'#0#1#7'Command'#7#14'ecColumnSelect'#8'ShortCut'#3
+ +'C`'#0#1#7'Command'#7#12'ecLineSelect'#8'ShortCut'#3'L`'#0#1#7'Command'#7#5
+ +'ecTab'#8'ShortCut'#2#9#0#1#7'Command'#7#10'ecShiftTab'#8'ShortCut'#3#9' '#0
+ +#1#7'Command'#7#14'ecMatchBracket'#8'ShortCut'#3'B`'#0#1#7'Command'#7#10'ecC'
+ +'olSelUp'#8'ShortCut'#4'&'#160#0#0#0#1#7'Command'#7#12'ecColSelDown'#8'Short'
+ +'Cut'#4'('#160#0#0#0#1#7'Command'#7#12'ecColSelLeft'#8'ShortCut'#4'%'#160#0#0
+ +#0#1#7'Command'#7#13'ecColSelRight'#8'ShortCut'#4''''#160#0#0#0#1#7'Command'
+ +#7#16'ecColSelPageDown'#8'ShortCut'#4'"'#160#0#0#0#1#7'Command'#7#18'ecColSe'
+ +'lPageBottom'#8'ShortCut'#4'"'#224#0#0#0#1#7'Command'#7#14'ecColSelPageUp'#8
+ +'ShortCut'#4'!'#160#0#0#0#1#7'Command'#7#15'ecColSelPageTop'#8'ShortCut'#4'!'
+ +#224#0#0#0#1#7'Command'#7#17'ecColSelLineStart'#8'ShortCut'#4'$'#160#0#0#0#1
+ +#7'Command'#7#15'ecColSelLineEnd'#8'ShortCut'#4'#'#160#0#0#0#1#7'Command'#7
+ +#17'ecColSelEditorTop'#8'ShortCut'#4'$'#224#0#0#0#1#7'Command'#7#20'ecColSel'
+ +'EditorBottom'#8'ShortCut'#4'#'#224#0#0#0#0#12'MouseActions'#14#1#5'Shift'#11
+ +#0#9'ShiftMask'#11#7'ssShift'#5'ssAlt'#0#6'Button'#7#6'mbLeft'#10'ClickCount'
+ +#7#8'ccSingle'#8'ClickDir'#7#6'cdDown'#7'Command'#2#1#9'MoveCaret'#9#6'Optio'
+ +'n'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#7'ssShift'#0#9'ShiftMask'#11#7'ssShi'
+ +'ft'#5'ssAlt'#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#8'ccSingle'#8'ClickDi'
+ +'r'#7#6'cdDown'#7'Command'#2#1#9'MoveCaret'#9#6'Option'#2#1#8'Priority'#2#0#0
+ +#1#5'Shift'#11#5'ssAlt'#0#9'ShiftMask'#11#7'ssShift'#5'ssAlt'#0#6'Button'#7#6
+ +'mbLeft'#10'ClickCount'#7#8'ccSingle'#8'ClickDir'#7#6'cdDown'#7'Command'#2#3
+ +#9'MoveCaret'#9#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#7'ssShift'#5's'
+ +'sAlt'#0#9'ShiftMask'#11#7'ssShift'#5'ssAlt'#0#6'Button'#7#6'mbLeft'#10'Clic'
+ +'kCount'#7#8'ccSingle'#8'ClickDir'#7#6'cdDown'#7'Command'#2#3#9'MoveCaret'#9
+ +#6'Option'#2#1#8'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMask'#11#0#6'Button'
+ +#7#7'mbRight'#10'ClickCount'#7#8'ccSingle'#8'ClickDir'#7#4'cdUp'#7'Command'#2
+ +#12#9'MoveCaret'#8#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMa'
+ +'sk'#11#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#8'ccDouble'#8'ClickDir'#7#6
+ +'cdDown'#7'Command'#2#6#9'MoveCaret'#9#6'Option'#2#0#8'Priority'#2#0#0#1#5'S'
+ +'hift'#11#0#9'ShiftMask'#11#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#8'ccTri'
+ +'ple'#8'ClickDir'#7#6'cdDown'#7'Command'#2#7#9'MoveCaret'#9#6'Option'#2#0#8
+ +'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMask'#11#0#6'Button'#7#6'mbLeft'#10
+ +'ClickCount'#7#6'ccQuad'#8'ClickDir'#7#6'cdDown'#7'Command'#2#8#9'MoveCaret'
+ +#9#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#0#9'ShiftMask'#11#0#6'Butto'
+ +'n'#7#8'mbMiddle'#10'ClickCount'#7#8'ccSingle'#8'ClickDir'#7#6'cdDown'#7'Com'
+ +'mand'#2#10#9'MoveCaret'#9#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#6's'
+ +'sCtrl'#0#9'ShiftMask'#11#7'ssShift'#5'ssAlt'#6'ssCtrl'#0#6'Button'#7#6'mbLe'
+ +'ft'#10'ClickCount'#7#8'ccSingle'#8'ClickDir'#7#4'cdUp'#7'Command'#2#11#9'Mo'
+ +'veCaret'#8#6'Option'#2#0#8'Priority'#2#0#0#0#15'MouseSelActions'#14#1#5'Shi'
+ +'ft'#11#0#9'ShiftMask'#11#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#8'ccSingl'
+ +'e'#8'ClickDir'#7#6'cdDown'#7'Command'#2#9#9'MoveCaret'#8#6'Option'#2#0#8'Pr'
+ +'iority'#2#0#0#0#13'Lines.Strings'#1#6#8'SynMemo1'#0#8'OnChange'#7#14'SynMem'
+ +'o1Change'#0#18'TSynGutterPartList'#0#0#15'TSynGutterMarks'#0#5'Width'#2#23#0
+ +#0#20'TSynGutterLineNumber'#0#5'Width'#2#17#12'MouseActions'#14#0#21'MarkupI'
+ ,'nfo.Background'#7#9'clBtnFace'#21'MarkupInfo.Foreground'#7#6'clNone'#10'Dig'
+ +'itCount'#2#2#30'ShowOnlyLineNumbersMultiplesOf'#2#1#9'ZeroStart'#8#12'Leadi'
+ +'ngZeros'#8#0#0#17'TSynGutterChanges'#0#5'Width'#2#4#13'ModifiedColor'#4#252
+ +#233#0#0#10'SavedColor'#7#7'clGreen'#0#0#19'TSynGutterSeparator'#0#5'Width'#2
+ +#2#0#0#21'TSynGutterCodeFolding'#0#12'MouseActions'#14#1#5'Shift'#11#0#9'Shi'
+ +'ftMask'#11#0#6'Button'#7#7'mbRight'#10'ClickCount'#7#8'ccSingle'#8'ClickDir'
+ +#7#4'cdUp'#7'Command'#2#16#9'MoveCaret'#8#6'Option'#2#0#8'Priority'#2#0#0#1#5
+ +'Shift'#11#0#9'ShiftMask'#11#7'ssShift'#0#6'Button'#7#8'mbMiddle'#10'ClickCo'
+ +'unt'#7#5'ccAny'#8'ClickDir'#7#6'cdDown'#7'Command'#2#14#9'MoveCaret'#8#6'Op'
+ +'tion'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#7'ssShift'#0#9'ShiftMask'#11#7'ss'
+ +'Shift'#0#6'Button'#7#8'mbMiddle'#10'ClickCount'#7#5'ccAny'#8'ClickDir'#7#6
+ +'cdDown'#7'Command'#2#14#9'MoveCaret'#8#6'Option'#2#1#8'Priority'#2#0#0#1#5
+ +'Shift'#11#0#9'ShiftMask'#11#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#5'ccAn'
+ +'y'#8'ClickDir'#7#6'cdDown'#7'Command'#2#0#9'MoveCaret'#8#6'Option'#2#0#8'Pr'
+ +'iority'#2#0#0#0#21'MarkupInfo.Background'#7#6'clNone'#21'MarkupInfo.Foregro'
+ +'und'#7#6'clGray'#20'MouseActionsExpanded'#14#1#5'Shift'#11#0#9'ShiftMask'#11
+ +#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#5'ccAny'#8'ClickDir'#7#6'cdDown'#7
+ +'Command'#2#14#9'MoveCaret'#8#6'Option'#2#0#8'Priority'#2#0#0#0#21'MouseActi'
+ +'onsCollapsed'#14#1#5'Shift'#11#6'ssCtrl'#0#9'ShiftMask'#11#6'ssCtrl'#0#6'Bu'
+ +'tton'#7#6'mbLeft'#10'ClickCount'#7#5'ccAny'#8'ClickDir'#7#6'cdDown'#7'Comma'
+ +'nd'#2#15#9'MoveCaret'#8#6'Option'#2#0#8'Priority'#2#0#0#1#5'Shift'#11#0#9'S'
+ +'hiftMask'#11#6'ssCtrl'#0#6'Button'#7#6'mbLeft'#10'ClickCount'#7#5'ccAny'#8
+ +'ClickDir'#7#6'cdDown'#7'Command'#2#15#9'MoveCaret'#8#6'Option'#2#1#8'Priori'
+ +'ty'#2#0#0#0#0#0#0#0#17'TSynFreePascalSyn'#17'SynFreePascalSyn1'#7'Enabled'#8
+ +#12'CompilerMode'#7#9'pcmObjFPC'#14'NestedComments'#9#4'left'#3#242#1#3'top'
+ +#2'Y'#0#0#0
+]);
diff --git a/Projects/SAMufasaGUI/testunit.pas b/Projects/SAMufasaGUI/testunit.pas
index eeb91af..3e851c7 100644
--- a/Projects/SAMufasaGUI/testunit.pas
+++ b/Projects/SAMufasaGUI/testunit.pas
@@ -6,7 +6,8 @@ interface
uses
Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
- StdCtrls, Client, MufasaTypes, mmlthread;
+ StdCtrls, SynEdit, SynHighlighterPas, SynMemo, Client, MufasaTypes,
+ mmlpsthread;
type
@@ -14,7 +15,11 @@ type
TForm1 = class(TForm)
Button1: TButton;
+ SynEdit1: TSynEdit;
+ SynFreePascalSyn1: TSynFreePascalSyn;
+ SynMemo1: TSynMemo;
procedure Button1Click(Sender: TObject);
+ procedure SynMemo1Change(Sender: TObject);
private
{ private declarations }
public
@@ -254,13 +259,24 @@ end;
procedure TForm1.Button1Click(Sender: TObject);
Var
//MyThread: TMyThread;
- MMLThread: TMMLThread;
+// MMLThread: TMMLThread;
+ MMLPSThread : TMMLPSThread;
begin
{ MyThread := TMyThread.Create(True);
MyThread.Resume; }
- MMLThread := TMMLThread.Create(True);
- MMLThread.Resume;
+{ MMLThread := TMMLThread.Create(True);
+ MMLThread.Resume;}
+ MMLPSThread := TMMLPSThread.Create(True);
+ MMLPSThread.SetPSScript(SynEdit1.Lines.Text);
+ MMLPSThread.SetDebug(SynMemo1);
+ MMLPSThread.Resume;
+
+end;
+
+procedure TForm1.SynMemo1Change(Sender: TObject);
+begin
+
end;
initialization
diff --git a/Units/MMLAddon/mmlpsthread.pas b/Units/MMLAddon/mmlpsthread.pas
new file mode 100644
index 0000000..dee8699
--- /dev/null
+++ b/Units/MMLAddon/mmlpsthread.pas
@@ -0,0 +1,245 @@
+unit mmlpsthread;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils, client, uPSComponent,uPSCompiler,uPSRuntime,SynMemo;
+
+type
+
+ { TMMLPSThread }
+
+ TMMLPSThread = class(TThread)
+ protected
+// PSScript : TPSScript;
+// PSClient : TPSScript;
+// Client: TClient;
+// DebugTo : TStrings;
+ Client : TClient;
+ PSScript : TPSScript;
+ DebugTo : TSynMemo;
+ procedure OnCompile(Sender: TPSScript);
+ procedure AfterExecute(Sender : TPSScript);
+ function RequireFile(Sender: TObject; const OriginFileName: String;
+ var FileName, OutPut: string): Boolean;
+ procedure OnCompImport(Sender: TObject; x: TPSPascalCompiler);
+ procedure OnExecImport(Sender: TObject; se: TPSExec; x: TPSRuntimeClassImporter);
+ procedure OutputMessages;
+ procedure Execute; override;
+ public
+ procedure SetPSScript(Script : string);
+ procedure SetDebug( Strings : TSynMemo );
+ function SetClientInfo : boolean;
+// function CompilePSScript : boolean;
+// function
+ constructor Create(CreateSuspended: Boolean);
+ destructor Destroy;
+ end;
+
+implementation
+uses
+ MufasaTypes,{$ifdef mswindows}windows,{$endif}
+ uPSC_std, uPSC_Controls,uPSC_Classes,uPSC_Graphics,uPSC_stdctrls,uPSC_Forms,uPSC_extctrls, //Compile-libs
+ uPSR_std, uPSR_Controls,uPSR_Classes,uPSR_Graphics,uPSR_stdctrls,uPSR_Forms,uPSR_extctrls; //Runtime-libs
+
+
+threadvar
+ CurrThread : TMMLPSThread;
+
+{Some General PS Functions here}
+procedure Writeln(str : string);
+begin;
+ if CurrThread.DebugTo <> nil then
+ CurrThread.DebugTo.Lines.Add(Str);
+ //Just overwriting itz.. soz.
+end;
+
+function ThreadSafeCall(ProcName: string; var V: TVariantArray): Variant;
+var
+ i : integer;
+begin;
+ Writeln('We have a length of: ' + inttostr(length(v)));
+ Try
+ Result := CurrThread.PSScript.Exec.RunProcPVar(v,CurrThread.PSScript.Exec.GetProc(Procname));
+ Except
+ Writeln('We has some errors :-(');
+ end;
+end;
+
+{
+ Note to Raymond: For PascalScript, Create it on the .Create,
+ Execute it on the .Execute, and don't forget to Destroy it on .Destroy.
+
+ Furthermore, all the wrappers can be in the unit "implementation" section.
+ Better still to create an .inc for it, otherwise this unit will become huge.
+ (You can even split up the .inc's in stuff like color, bitmap, etc. )
+
+ Also, don't add PS to this unit, but make a seperate unit for it.
+ Unit "MMLPSThread", perhaps?
+
+ See the TestUnit for use of this thread, it's pretty straightforward.
+
+ It may also be wise to turn the "Importing of wrappers" into an include as
+ well, it will really make the unit more straightforward to use and read.
+}
+
+
+constructor TMMLPSThread.Create(CreateSuspended : boolean);
+begin
+ if Client <> nil then
+ Writeln('ThreadClient seems to be set, so not recreating it.') //reset client to defaults?
+ //ThreadClient.ResetToDefaults
+ else
+ Client := TClient.Create;
+ if PSScript <> nil then
+ PSScript.Free;
+ // Create Stuff here
+ PSScript := TPSScript.Create(nil);
+ PSScript.UsePreProcessor:= True;
+ PSScript.OnNeedFile := @RequireFile;
+
+
+ PSScript.OnCompile:= @OnCompile;
+ PSScript.OnCompImport:= @OnCompImport;
+ PSScript.OnExecImport:= @OnExecImport;
+ PSScript.OnAfterExecute:= @AfterExecute;
+ {$IFDEF CPU386 }
+ PSScript.Defines.Add ('CPU386');
+ {$ENDIF }
+ PSScript.Defines.Add ('MUFASA');
+ PSScript.Defines.Add ('COGAT');
+ PSScript.Defines.Add ('RAYMONDPOWNS');
+ {$IFDEF MSWINDOWS }
+ PSScript.Defines.Add ('MSWINDOWS');
+ PSScript.Defines.Add ('WIN32');
+ PSScript.Defines.Add ('WINDOWS');
+ {$ENDIF }
+ {$IFDEF LINUX }
+ PSScript.Defines.Add ('LINUX');
+ {$ENDIF }
+ FreeOnTerminate := True;
+ inherited Create(CreateSuspended);
+end;
+
+destructor TMMLPSThread.Destroy;
+begin
+ Client.Free;
+ PSScript.Free;
+ inherited Destroy;
+end;
+
+procedure TMMLPSThread.OnCompile(Sender: TPSScript);
+begin
+ //Here we add all the initalizing, of BMPArray etc
+ Sender.AddFunction(@ThreadSafeCall,'function ThreadSafeCall(ProcName: string; var V: TVariantArray): Variant;');
+ Sender.AddFunction(@Writeln,'procedure writeln(s : string);');
+ //Also the functions get added into the engine, right here.
+end;
+
+procedure TMMLPSThread.AfterExecute(Sender: TPSScript);
+begin
+ //Here we add all the Script-freeing-leftovers (like BMParray etc)
+end;
+
+function TMMLPSThread.RequireFile(Sender: TObject;
+ const OriginFileName: String; var FileName, OutPut: string): Boolean;
+begin
+
+end;
+
+procedure TMMLPSThread.OnCompImport(Sender: TObject; x: TPSPascalCompiler);
+begin
+ SIRegister_Std(x);
+ SIRegister_Controls(x);
+ SIRegister_Classes(x, true);
+ SIRegister_Graphics(x, true);
+ SIRegister_stdctrls(x);
+ SIRegister_Forms(x);
+ SIRegister_ExtCtrls(x);
+end;
+
+procedure TMMLPSThread.OnExecImport(Sender: TObject; se: TPSExec;
+ x: TPSRuntimeClassImporter);
+begin
+ RIRegister_Std(x);
+ RIRegister_Classes(x, True);
+ RIRegister_Controls(x);
+ RIRegister_Graphics(x, True);
+ RIRegister_stdctrls(x);
+ RIRegister_Forms(x);
+ RIRegister_ExtCtrls(x);
+end;
+
+procedure TMMLPSThread.OutputMessages;
+var
+ l: Longint;
+ b: Boolean;
+begin
+ b := False;
+ for l := 0 to PSScript.CompilerMessageCount - 1 do
+ begin
+ Writeln(PSScript.CompilerErrorToStr(l));
+ if (not b) and (PSScript.CompilerMessages[l] is TIFPSPascalCompilerError) then
+ begin
+ b := True;
+// FormMain.CurrSynEdit.SelStart := PSScript.CompilerMessages[l].Pos;
+
+ end;
+ end;
+end;
+
+procedure TMMLPSThread.Execute;
+var
+ time, i, ii: Integer;
+begin;
+ CurrThread := Self;
+ time := GetTickCount;
+ try
+ if PSScript.Compile then
+ begin
+ OutputMessages;
+ Writeln('Compiled succesfully in ' + IntToStr(GetTickCount - time) + ' ms.');
+// if not (ScriptState = SCompiling) then
+ if not PSScript.Execute then
+ begin
+// FormMain.CurrSynEdit.SelStart := Script.PSScript.ExecErrorPosition;
+ Writeln(PSScript.ExecErrorToString +' at '+Inttostr(PSScript.ExecErrorProcNo)+'.'
+ +Inttostr(PSScript.ExecErrorByteCodePosition));
+ end else Writeln('Succesfully executed');
+ end else
+ begin
+ OutputMessages;
+ Writeln('Compiling failed');
+ end;
+ except
+ on E : Exception do
+ Writeln('Error: ' + E.Message);
+ end;
+end;
+
+procedure TMMLPSThread.SetPSScript(Script: string);
+begin
+ PSScript.Script.Text:= Script;
+end;
+
+procedure TMMLPSThread.SetDebug(Strings: TSynMemo);
+begin
+ DebugTo := Strings;
+end;
+
+function TMMLPSThread.SetClientInfo: boolean;
+begin
+ //Set the client handle, etc
+end;
+
+{ Include stuff here? }
+
+//{$I inc/colors.inc}
+//{$I inc/bitmaps.inc}
+
+
+end.
+
+
diff --git a/Units/MMLCore/mufasatypes.pas b/Units/MMLCore/mufasatypes.pas
index eb2030b..681f136 100644
--- a/Units/MMLCore/mufasatypes.pas
+++ b/Units/MMLCore/mufasatypes.pas
@@ -23,7 +23,7 @@ type
TClickType = (mouse_Left, mouse_Right, mouse_Middle);
TMousePress = (mouse_Down, mouse_Up);
TPointArray = array of TPoint;
-
+ TVariantArray = Array of Variant;
implementation
diff --git a/Units/PascalScript/PascalScript.inc b/Units/PascalScript/PascalScript.inc
new file mode 100644
index 0000000..7e30390
--- /dev/null
+++ b/Units/PascalScript/PascalScript.inc
@@ -0,0 +1,62 @@
+{----------------------------------------------------------------------------}
+{ RemObjects Pascal Script }
+{ }
+{ compiler: Delphi 2 and up, Kylix 3 and up }
+{ platform: Win32, Linux }
+{ }
+{ (c)opyright RemObjects Software. all rights reserved. }
+{ }
+{----------------------------------------------------------------------------}
+
+
+{$INCLUDE eDefines.inc}
+
+{$IFDEF FPC}{$MODE DELPHI}{$H+}{$ENDIF}
+
+{$IFDEF VER125}{C4}{$B-}{$X+}{$T-}{$H+}{$ENDIF}
+{$IFDEF VER110}{C3}{$B-}{$X+}{$T-}{$H+}{$ENDIF}
+{$IFDEF VER93}{C1}{$B-}{$X+}{$T-}{$H+}{$ENDIF}
+
+{$IFDEF DELPHI4UP}
+ {$DEFINE PS_HAVEVARIANT}
+ {$DEFINE PS_DYNARRAY}
+{$ENDIF}
+
+{$IFNDEF FPC}
+ {$B-}{$X+}{$T-}{$H+}
+{$ELSE}
+ {$R-}{$Q-}
+{$ENDIF}
+
+{$IFNDEF FPC}
+{$IFNDEF DELPHI4UP}
+{$IFNDEF LINUX}
+ {$DEFINE PS_NOINT64}
+{$ENDIF}
+{$ENDIF}
+
+{$IFDEF DELPHI2}
+ {$DEFINE PS_NOINT64}
+ {$DEFINE PS_NOWIDESTRING}
+ {$B-}{$X+}{$T-}{$H+}
+{$ENDIF}
+
+{$IFDEF LINUX}{KYLIX}{$DEFINE CLX}{$DEFINE DELPHI3UP}{$DEFINE DELPHI6UP}{$ENDIF}
+{$ENDIF}
+{$R-}{$Q-}
+
+
+{
+Defines:
+ IFPS3_NOSMARTLIST - Don't use the smart list option
+}
+
+{$UNDEF DEBUG}
+
+{$IFDEF CLX}
+{$DEFINE PS_NOIDISPATCH} // not implemented
+{$ENDIF}
+
+{$IFDEF FPC}
+ {$I PascalScriptFPC.inc}
+{$ENDIF}
diff --git a/Units/PascalScript/PascalScriptFPC.inc b/Units/PascalScript/PascalScriptFPC.inc
new file mode 100644
index 0000000..96883ce
--- /dev/null
+++ b/Units/PascalScript/PascalScriptFPC.inc
@@ -0,0 +1,15 @@
+
+ {$DEFINE PS_HAVEVARIANT}
+ {$DEFINE PS_DYNARRAY}
+ {$DEFINE PS_NOIDISPATCH}
+ {$if (fpc_version=2) and (fpc_release>=3) and (fpc_patch>=1)}
+ {.$if (fpc_version=2) and (fpc_release>=2) and (fpc_patch>=4)}
+ {$UNDEF FPC_OLD_FIX}
+ {$UNDEF PS_FPCSTRINGWORKAROUND}
+ {FreePascal 2.3.1 and above has much Delphi compatibility bugs fixed}
+ {$else}
+ {$DEFINE FPC_OLD_FIX}
+ {$DEFINE PS_FPCSTRINGWORKAROUND}
+ {$ifend}
+ {$DEFINE DELPHI3UP}
+ {$DEFINE DELPHI6UP}
diff --git a/Units/PascalScript/PascalScript_Core_Ext_Reg.pas b/Units/PascalScript/PascalScript_Core_Ext_Reg.pas
new file mode 100644
index 0000000..1a9de6e
--- /dev/null
+++ b/Units/PascalScript/PascalScript_Core_Ext_Reg.pas
@@ -0,0 +1,30 @@
+unit PascalScript_Core_Ext_Reg;
+
+{----------------------------------------------------------------------------}
+{ RemObjects Pascal Script }
+{ }
+{ compiler: Delphi 2 and up, Kylix 3 and up }
+{ platform: Win32, Linux }
+{ }
+{ (c)opyright RemObjects Software. all rights reserved. }
+{ }
+{----------------------------------------------------------------------------}
+
+{$I PascalScript.inc}
+
+interface
+
+procedure Register;
+
+implementation
+
+uses
+ Classes,
+ uPSComponentExt;
+
+procedure Register;
+begin
+ RegisterComponents('RemObjects Pascal Script',[TPSScriptExtension]);
+end;
+
+end.
diff --git a/Units/PascalScript/PascalScript_Core_Reg.pas b/Units/PascalScript/PascalScript_Core_Reg.pas
new file mode 100644
index 0000000..5987b51
--- /dev/null
+++ b/Units/PascalScript/PascalScript_Core_Reg.pas
@@ -0,0 +1,65 @@
+unit PascalScript_Core_Reg;
+
+{----------------------------------------------------------------------------
+/ RemObjects Pascal Script
+/
+/ compiler: Delphi 2 and up, Kylix 3 and up
+/ platform: Win32, Linux
+/
+/ (c)opyright RemObjects Software. all rights reserved.
+/
+----------------------------------------------------------------------------}
+
+{$I PascalScript.inc}
+
+interface
+
+{$IFNDEF FPC}
+{$R PascalScript_Core_Glyphs.res}
+{$ENDIF}
+
+procedure Register;
+
+implementation
+
+uses
+ Classes,
+ {$IFDEF FPC}
+ LResources,
+ {$ENDIF}
+ uPSComponent,
+ uPSDebugger,
+ uPSComponent_Default,
+ {$IFNDEF FPC}
+ uPSComponent_COM,
+ {$ENDIF}
+ uPSComponent_DB,
+ uPSComponent_Forms,
+ uPSComponent_Controls,
+ uPSComponent_StdCtrls;
+
+procedure Register;
+begin
+ RegisterComponents('Pascal Script', [TPSScript,
+ TPSScriptDebugger,
+ TPSDllPlugin,
+ TPSImport_Classes,
+ TPSImport_DateUtils,
+ {$IFNDEF FPC}
+ TPSImport_ComObj,
+ {$ENDIF}
+ TPSImport_DB,
+ TPSImport_Forms,
+ TPSImport_Controls,
+ TPSImport_StdCtrls,
+ TPSCustumPlugin]);
+end;
+
+
+{$IFDEF FPC}
+ initialization;
+ {$i pascalscript.lrs}
+{$ENDIF}
+
+
+end.
diff --git a/Units/PascalScript/PascalScript_Core_Reg_noDB.pas b/Units/PascalScript/PascalScript_Core_Reg_noDB.pas
new file mode 100644
index 0000000..d756512
--- /dev/null
+++ b/Units/PascalScript/PascalScript_Core_Reg_noDB.pas
@@ -0,0 +1,48 @@
+unit PascalScript_Core_Reg_noDB;
+
+{----------------------------------------------------------------------------}
+{ RemObjects Pascal Script
+{
+{ compiler: Delphi 2 and up, Kylix 3 and up
+{ platform: Win32, Linux
+{
+{ (c)opyright RemObjects Software. all rights reserved.
+{
+{----------------------------------------------------------------------------}
+
+{$I PascalScript.inc}
+
+interface
+
+{$R PascalScript_Core_Glyphs.res}
+
+procedure Register;
+
+implementation
+
+uses
+ Classes,
+ uPSComponent,
+ uPSComponentExt,
+ uPSDebugger,
+ uPSComponent_Default,
+ uPSComponent_COM,
+ uPSComponent_Forms,
+ uPSComponent_Controls,
+ uPSComponent_StdCtrls;
+
+procedure Register;
+begin
+ RegisterComponents('Pascal Script', [TPSScript,
+ TPSScriptDebugger,
+ TPSDllPlugin,
+ TPSImport_Classes,
+ TPSImport_DateUtils,
+ TPSImport_ComObj,
+ TPSImport_Forms,
+ TPSImport_Controls,
+ TPSImport_StdCtrls,
+ TPSScriptExtension]);
+end;
+
+end.
diff --git a/Units/PascalScript/PascalScript_RO_Reg.pas b/Units/PascalScript/PascalScript_RO_Reg.pas
new file mode 100644
index 0000000..1369293
--- /dev/null
+++ b/Units/PascalScript/PascalScript_RO_Reg.pas
@@ -0,0 +1,34 @@
+unit PascalScript_RO_Reg;
+
+{----------------------------------------------------------------------------}
+{ RemObjects Pascal Script
+{
+{ compiler: Delphi 2 and up, Kylix 3 and up
+{ platform: Win32, Linux
+{
+{ (c)opyright RemObjects Software. all rights reserved.
+{
+{ Using this code requires a valid license of Pascal Script
+{ which can be obtained at http://www.remobjects.com.
+{----------------------------------------------------------------------------}
+
+{$I PascalScript.inc}
+
+interface
+
+{$R PascalScript_RO_Glyphs.res}
+
+procedure Register;
+
+implementation
+
+uses
+ Classes,
+ uROPSServerLink;
+
+procedure Register;
+begin
+ RegisterComponents('Pascal Script', [TPSRemObjectsSdkPlugin]);
+end;
+
+end.
diff --git a/Units/PascalScript/arm.inc b/Units/PascalScript/arm.inc
new file mode 100644
index 0000000..1765635
--- /dev/null
+++ b/Units/PascalScript/arm.inc
@@ -0,0 +1,312 @@
+{ implementation of the arm procedure call standard for function calls in pascal script
+ Copyright (c) 2008 by Henry Vermaak (henry.vermaak@gmail.com)
+
+ todo: add eabi (define FPC_ABI_EABI) and wince support
+
+ notes:
+
+ most arm cpus don't allow unaligned access. by default (?) the linux kernel
+ is set up to try and correct unaligned access, which can lead to strange behaviour.
+ to turn this off, try (as root):
+
+ echo 4 > /proc/cpu/alignment
+
+ if you have an alignment problem, you will now get a crash with a backtrace like this:
+ (make sure you compile with -O- -gl)
+
+ An unhandled exception occurred at $0006C014 :
+ EBusError : Bus error or misaligned data access
+ $0006C014 PROCESSREPEAT, line 9670 of upscompiler.pas
+ $00068AAC TPSPASCALCOMPILER__PROCESSSUB, line 10459 of upscompiler.pas
+ $0007D0B4 TPSPASCALCOMPILER__COMPILE, line 11704 of upscompiler.pas
+
+ you can fix this by using the "unaligned" keyword around the pointer operation.
+ search for occurances of "unaligned" to see how this is done,
+ (use $ifdef FPC_REQUIRES_PROPER_ALIGNMENT).
+
+ for more information, visit:
+
+ http://www.aleph1.co.uk/oldsite/armlinux/book/afaq.html
+}
+
+const
+ rtINT = 0;
+ rtINT64 = 1;
+ rtFLOAT = 2;
+
+type
+ Trint = array[1..4] of dword;
+ Trfloat = array[1..4] of double;
+
+{$goto on}
+{ define labels }
+label
+ stack_loop,
+ load_regs,
+ asmcall_end,
+ int_result,
+ int64_result,
+ float_result;
+
+{ call a function from a pointer }
+{ resulttype: 0 = int, 1 = int64, 2 = float }
+function armasmcall(rint: Trint; rfloat: Trfloat; proc, stack: pointer; stacksize, resulttype: integer): pointer; assembler; nostackframe;
+asm
+ mov r12, r13
+ stmfd r13!, {r4, r5, r6, r7, r8, r9, r10, r11, r12, r14, r15}
+ sub r11, r12, #4
+ mov r4, #80 (* space for preserved registers and parameters *)
+ ldr r5, [r11, #4] (* stacksize we need for subroutine *)
+ add r4, r4, r5
+ sub r13, r13, r4 (* create stack space *)
+
+ (* store parameters on stack *)
+ str r0, [r11, #-44] (* rint *)
+ str r1, [r11, #-48] (* rfloat *)
+ str r2, [r11, #-52] (* proc *)
+ str r3, [r11, #-56] (* stack *)
+ ldr r0, [r11, #4]
+ str r0, [r11, #-60] (* stacksize *)
+ ldr r0, [r11, #8]
+ str r0, [r11, #-64] (* resulttype *)
+
+ (* store params for sub-routine that don't fit into r0-r3 at start of stack *)
+ ldr r0, [r11, #-60] (* stacksize *)
+ cmp r0, #0
+ beq load_regs (* skip if no stack *)
+ mov r1, r13 (* this points to the bottom now *)
+ ldr r2, [r11, #-56] (* stack pointer *)
+stack_loop:
+ ldmia r2!, {r4} (* get stack + update pos *)
+ stmia r1!, {r4} (* store stack + update pos *)
+ subs r0, r0, #4
+ bne stack_loop
+
+load_regs:
+ (* load general regs *)
+ ldr r4, [r11, #-44] (* rint *)
+ ldr r0, [r4]
+ ldr r1, [r4, #4]
+ ldr r2, [r4, #8]
+ ldr r3, [r4, #12]
+
+{$ifdef FPUFPA}
+ (* load float regs *)
+ ldr r4, [r11, #-48] (* rfloat *)
+ ldfd f0, [r4]
+ ldfd f1, [r4, #8]
+ ldfd f2, [r4, #16]
+ ldfd f3, [r4, #24]
+{$endif}
+
+ (* branch to the proc pointer *)
+ ldr r4, [r11, #-52]
+ mov r14, r15
+ mov r15, r4
+(* blx r4 *)
+
+ ldr r4, [r11, #-64] (* get resulttype *)
+ cmp r4, #1
+ blt int_result
+ beq int64_result
+ bgt float_result
+
+int_result:
+ str r0, [r11, #-72]
+ b asmcall_end
+
+int64_result:
+ str r0, [r11, #-72]
+ str r1, [r11, #-68]
+ b asmcall_end
+
+float_result:
+{$ifdef FPUFPA}
+ stfd f0, [r11, #-72]
+{$else}
+ b int64_result
+{$endif}
+ b asmcall_end
+
+asmcall_end:
+ sub r0, r11, #72 (* return pointer to result on stack *)
+
+ ldmea r11,{r4,r5,r6,r7,r8,r9,r10,r11,r13,r15}
+end;
+
+function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean;
+var
+ rint: Trint; { registers r0 to r3 }
+ rfloat: Trfloat; { registers f0 to f3 }
+ st: packed array of byte; { stack }
+ i, j, rindex, findex, stindex: integer;
+ fvar: PPSVariantIFC;
+ IsConstructor: Boolean;
+
+ { add a dword to stack }
+ procedure addstackdword(value: dword);
+ begin
+ setlength(st, stindex+4);
+ pdword(@st[stindex])^ := value;
+ inc(stindex, 4);
+ end;
+
+ { add a float to stack }
+ procedure addstackfloat(value: pointer; size: integer);
+ begin
+ setlength(st, stindex + (size * 4));
+ if size = 1
+ then psingle(@st[stindex])^ := single(value^)
+ else pdouble(@st[stindex])^ := double(value^);
+ inc(stindex, size*4);
+ end;
+
+ { add to the general registers or overflow to stack }
+ procedure addgen(value: dword);
+ begin
+ if rindex <= 4
+ then begin
+ rint[rindex] := value;
+ inc(rindex);
+ end
+ else begin
+ addstackdword(value);
+ end;
+ end;
+ { add to the float registers or overflow to stack }
+ { size = 1 for single, 2 for double }
+ procedure addfloat(value: pointer; size: integer);
+ begin
+ if findex <= 4
+ then begin
+ if size = 1
+ then rfloat[findex] := single(value^)
+ else rfloat[findex] := double(value^);
+ inc(findex);
+ end
+ else begin
+ addstackfloat(value, size);
+ end;
+ end;
+
+begin
+ if (Integer(CallingConv) and 64) <> 0 then begin
+ IsConstructor := true;
+ CAllingConv := TPSCallingConvention(Integer(CallingConv) and not 64);
+ end else IsConstructor := false;
+
+ rindex := 1;
+ findex := 1;
+ stindex := 0;
+ setlength(st, stindex);
+ Result := False;
+
+ { the pointer of the result needs to be passed first in the case of some result types }
+ if assigned(res)
+ then begin
+ case res.atype.basetype of
+ btStaticArray, btRecord: addgen(dword(res.dta));
+ end;
+ end;
+
+ { process all parameters }
+ for i := 0 to Params.Count-1 do begin
+ if Params[i] = nil
+ then Exit;
+ fvar := Params[i];
+
+ { cook dynamic arrays - fpc stores size-1 at @array-4 }
+ if (fvar.aType.BaseType = btArray)
+ then dec(pdword(pointer(fvar.dta^)-4)^);
+
+ if fvar.varparam
+ then begin { var param }
+ case fvar.aType.BaseType of
+ { add var params here }
+ btArray, btVariant, btSet, btStaticArray, btRecord, btInterface, btClass, {$IFNDEF PS_NOWIDESTRING} btUnicodeString, btWideString, btWideChar, {$ENDIF}
+ btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency
+ {$IFNDEF PS_NOINT64}, bts64{$ENDIF}: addgen(dword(fvar.dta));
+ else begin
+ writeln(stderr, 'Parameter type not recognised!');
+ Exit;
+ end;
+ end; { case }
+ end else begin { not a var param }
+ case fvar.aType.BaseType of
+// btArray, btVariant, btSet, btStaticArray, btRecord, btInterface, btClass, {$IFNDEF PS_NOWIDESTRING} btWideString, btWideChar, {$ENDIF}
+// btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency
+// {$IFNDEF PS_NOINT64}, bts64{$ENDIF}: writeln('normal param');
+
+ { add normal params here }
+ btString: addgen(dword(pstring(fvar.dta)^));
+ btU8, btS8: addgen(dword(pbyte(fvar.dta)^));
+ btU16, BtS16: addgen(dword(pword(fvar.dta)^));
+ btU32, btS32: addgen(dword(pdword(fvar.dta)^));
+ btSingle: {$ifdef FPUFPA}
+ addfloat(fvar.dta, 1);
+ {$else}
+ addgen(dword(psingle(fvar.dta)^));
+ {$endif}
+ btDouble{, btExtended}: {$ifdef FPUFPA}
+ addfloat(fvar.dta, 2);
+ {$else}
+ begin
+ addgen(lo(qword(pdouble(fvar.dta)^)));
+ addgen(hi(qword(pdouble(fvar.dta)^)));
+ end;
+ {$endif}
+ btPChar: addgen(dword(ppchar(fvar.dta)^));
+ btChar: addgen(dword(pchar(fvar.dta)^));
+ {$IFNDEF PS_NOINT64}bts64:{$ENDIF} begin
+ addgen(dword(pint64(fvar.dta)^ and $ffffffff));
+ addgen(dword(pint64(fvar.dta)^ shr 32));
+ end;
+ btStaticArray: addgen(dword(fvar.dta));
+ btRecord: for j := 0 to (fvar.atype.realsize div 4)-1 do
+ addgen(pdword(fvar.dta + j*4)^);
+ btArray: addstackdword(dword(fvar.dta^)); { this is a bit weird }
+
+{ btVariant, btSet, btInterface, btClass }
+
+ else begin
+ writeln(stderr, 'Parameter type not implemented!');
+ Exit;
+ end;
+ end; { case }
+ end; { else }
+ end; { for }
+
+ if not assigned(res)
+ then begin
+ armasmcall(rint, rfloat, address, st, stindex, rtINT); { ignore return }
+ end
+ else begin
+ case res.atype.basetype of
+ { add result types here }
+ btString: pstring(res.dta)^ := pstring(armasmcall(rint, rfloat, address, st, stindex, rtINT))^;
+ btU8, btS8: pbyte(res.dta)^ := byte(pdword(armasmcall(rint, rfloat, address, st, stindex, rtINT))^);
+ btU16, btS16: pword(res.dta)^ := word(pdword(armasmcall(rint, rfloat, address, st, stindex, rtINT))^);
+ btU32, btS32: pdword(res.dta)^ := pdword(armasmcall(rint, rfloat, address, st, stindex, rtINT))^;
+ btSingle: psingle(res.dta)^ := pdouble(armasmcall(rint, rfloat, address, st, stindex, rtFLOAT))^;
+ btDouble{, btExtended}: pdouble(res.dta)^ := pdouble(armasmcall(rint, rfloat, address, st, stindex, rtFLOAT))^;
+ btPChar: ppchar(res.dta)^ := pchar(pdword(armasmcall(rint, rfloat, address, st, stindex, rtINT))^);
+ btChar: pchar(res.dta)^ := char(pdword(armasmcall(rint, rfloat, address, st, stindex, rtINT))^);
+ btStaticArray, btRecord: armasmcall(rint, rfloat, address, st, stindex, rtINT);
+ btArray: res.dta := armasmcall(rint, rfloat, address, st, stindex, rtINT);
+
+ else begin
+ writeln(stderr, 'Result type not implemented!');
+ exit;
+ end; { else }
+ end; { case }
+ end;
+
+ { cook dynamic arrays - fpc stores size-1 at @array-4 }
+ for i := 0 to Params.Count-1 do begin
+ fvar := Params[i];
+ if (fvar.aType.BaseType = btArray)
+ then inc(pdword(pointer(fvar.dta^)-4)^);
+ end;
+
+ Result := True;
+end;
diff --git a/Units/PascalScript/eDefines.inc b/Units/PascalScript/eDefines.inc
new file mode 100644
index 0000000..e98de3a
--- /dev/null
+++ b/Units/PascalScript/eDefines.inc
@@ -0,0 +1,493 @@
+{----------------------------------------------------------------------------}
+{file: eDefines.inc }
+{type: Delphi include file }
+{ }
+{compiler: Borland Pascal 7, }
+{ Delphi 1-7, 2005-2007 for Win32 }
+{ Kylix 1-3, }
+{ C++Builder 1-6, 2006-2007 }
+{ Free Pascal Compiler 2.x }
+{ }
+{platforms: DOS, DPMI, Win16, Win32, Win64, Linux, Mac OS X }
+{ }
+{author: mh@elitedev.com }
+{ }
+{contents: Defines that can be flexibily used to determine the exact }
+{ compiler version used. }
+{ }
+{(c)opyright elitedevelopments software. all rights reserved. }
+{ http://www.elitedev.com }
+{ }
+{ Third Party component developers are encouraged to use the set of defines }
+{ established in this file, rather then their own system, for checking their }
+{ component libraries agains different versions of Delphi and C++Builder. }
+{ }
+{ This file may be distributed freely with both free and commercial source }
+{ libraries, but you are asked to please leave this comment in place, and }
+{ to return any improvements you make to this file to the maintainer that }
+{ is noted above. }
+{----------------------------------------------------------------------------}
+
+{----------------------------------------------------------------------------}
+{ Compiler and OS version defines: }
+{ }
+{ exact compiler versions: }
+{ }
+{ BP7 Borland Pascal 7.0 }
+{ DELPHI1 Delphi 1.0 (any Delphi) }
+{ DELPHI2 Delphi 2.0 }
+{ DELPHI3 Delphi 3.0 }
+{ DELPHI4 Delphi 4.0 }
+{ DELPHI5 Delphi 5.0 }
+{ DELPHI6 Delphi 6.0 }
+{ DELPHI7 Delphi 7.0 }
+{ DELPHI9 Delphi 2005 }
+{ DELPHI2005 Delphi 2005 }
+{ DELPHI2006 Delphi 2006 }
+{ DELPHI2007 Delphi 2007 }
+{ KYLIX1 Kylix 1.0 }
+{ KYLIX2 Kylix 2.0 }
+{ KYLIX3 Kylix 3.0 }
+{ CBUILDER1 C++Builder 1.0 }
+{ CBUILDER3 C++Builder 3.0 }
+{ CBUILDER4 C++Builder 4.0 }
+{ CBUILDER5 C++Builder 5.0 }
+{ }
+{ }
+{ minimum compiler versions: }
+{ }
+{ DELPHI1UP Delphi 1.0 and above (any Delphi) }
+{ DELPHI2UP Delphi 2.0 and above }
+{ DELPHI3UP Delphi 3.0 and above }
+{ DELPHI4UP Delphi 4.0 and above }
+{ DELPHI5UP Delphi 5.0 and above }
+{ DELPHI6UP Delphi 6.0 and above }
+{ DELPHI7UP Delphi 7.0 and above }
+{ DELPHI9UP Delphi 9.0 (2005) and above }
+{ DELPHI10UP Delphi 10.0 (2006) and above }
+{ DELPHI11UP Delphi 11.0 (2007) and above }
+{ DELPHI2005UP Delphi 2005 and above }
+{ DELPHI2006UP Delphi 2006 and above }
+{ DELPHI2007UP Delphi 2007 and above }
+{ KYLIX1UP Kylix 1.0 and above (any Kylix) }
+{ KYLIX2UP Kylix 2.0 and above (any Kylix) }
+{ KYLIX3UP Kylix 3.0 and above (any Kylix) }
+{ CBUILDER1UP C++Builder 1.0 and above or Delphi 2 and above }
+{ CBUILDER3UP C++Builder 3.0 and above or Delphi 3.0 and above }
+{ CBUILDER4UP C++Builder 4.0 and above or Delphi 4.0 and above }
+{ CBUILDER5UP C++Builder 5.0 and above or Delphi 5.0 and above }
+{ CBUILDER6UP C++Builder 5.0 and above or Delphi 5.0 and above }
+{ }
+{ }
+{ compiler types: }
+{ }
+{ BP Borland Pascal (not Delphi or C++Builder) }
+{ DELPHI any Delphi version (but not C++Builder or Kylix) }
+{ KYLIX any Kylix version (not Delphi or C++Builder for Windows) }
+{ CBUILDER any C++Builder for Windows (Pascal) }
+{ }
+{ }
+{ target platforms compiler types: }
+{ }
+{ DELPHI_16BIT 16bit Delphi (but not C++Builder!) }
+{ DELPHI_32BIT 32bit Delphi (but not C++Builder) }
+{ KYLIX_32BIT 32bit Kylix (but not C++Builder) }
+{ CBUILDER_32BIT 32bit C++Builer's Pascal (but not Delphi) }
+{ }
+{ }
+{ target cpu types }
+{ }
+{ CPU16 16bit Delphi or Borland Pascal }
+{ CPU32 32bit Delphi or Free Pascal }
+{ CPU64 64bit Free Pascal }
+{ }
+{ target platforms }
+{ }
+{ DOS any DOS (plain and DPMI) }
+{ REALMODE 16bit realmode DOS }
+{ PROTECTEDMODE 16bit DPMI DOS }
+{ }
+{ MSWINDOWS any Windows platform }
+{ WIN16 16bit Windows }
+{ WIN32 32bit Windows }
+{ WIN64 64bit Windows }
+{ DOTNET .NET }
+{ }
+{ LINUX any Linux platform }
+{ LINUX32 32bit Linux }
+{ LINUX64 64bit Linux }
+{ }
+{ DARWIN Any Mac OS X }
+{ DARWIN32 32bit Mac OS X }
+{ DARWIN64 64bit Mac OS X }
+{----------------------------------------------------------------------------}
+
+{ defines for Borland Pascal 7.0 }
+{$IFDEF VER70}
+ {$DEFINE BP}
+ {$DEFINE BP7}
+ {$DEFINE 16BIT}
+ {$DEFINE CPU16}
+
+ { defines for BP7 DOS real mode }
+ {$IFDEF MSDOS}
+ {$DEFINE DOS}
+ {$DEFINE REALMODE}
+ {$ENDIF}
+
+ { defines for BP7 DOS protected mode }
+ {$IFDEF DPMI}
+ {$DEFINE DOS}
+ {$DEFINE PROTECTEDMODE}
+ {$ENDIF}
+
+ { defines for BP7 Windows }
+ {$IFDEF WINDOWS}
+ {$DEFINE MSWINDOWS}
+ {$DEFINE WIN16}
+ {$ENDIF}
+{$ENDIF}
+
+{ defines for Delphi 1.0 thru 7.0 }
+{$IFDEF MSWINDOWS}
+
+ { defines for Delphi 1.0 }
+ {$IFDEF VER80}
+ {$DEFINE DELPHI}
+ {$DEFINE DELPHI1}
+ {$DEFINE DELPHI1UP}
+ {$DEFINE DELPHI_16BIT}
+ {$DEFINE WIN16}
+ {$DEFINE 16BIT}
+ {$DEFINE CPU16}
+ {$ENDIF}
+
+ { defines for Delphi 2.0 }
+ {$IFDEF VER90}
+ {$DEFINE DELPHI}
+ {$DEFINE DELPHI2}
+ {$DEFINE DELPHI1UP}
+ {$DEFINE DELPHI2UP}
+ {$ENDIF}
+
+ { defines for C++Builder 1.0 }
+ {$IFDEF VER93}
+ {$DEFINE DELPHI1UP}
+ {$DEFINE DELPHI2UP}
+ {$DEFINE CBUILDER}
+ {$DEFINE CBUILDER1}
+ {$DEFINE CBUILDER1UP}
+ {$ENDIF}
+
+ { defines for Delphi 3.0 }
+ {$IFDEF VER100}
+ {$DEFINE DELPHI}
+ {$DEFINE DELPHI3}
+ {$DEFINE DELPHI1UP}
+ {$DEFINE DELPHI2UP}
+ {$DEFINE DELPHI3UP}
+ {$ENDIF}
+
+ { defines for C++Builder 3.0 }
+ {$IFDEF VER110}
+ {$DEFINE DELPHI1UP}
+ {$DEFINE DELPHI2UP}
+ {$DEFINE DELPHI3UP}
+ {$DEFINE CBUILDER}
+ {$DEFINE CBUILDER3}
+ {$DEFINE CBUILDER1UP}
+ {$DEFINE CBUILDER3UP}
+ {$ENDIF}
+
+ { defines for Delphi 4.0 }
+ {$IFDEF VER120}
+ {$DEFINE DELPHI}
+ {$DEFINE DELPHI4}
+ {$DEFINE DELPHI1UP}
+ {$DEFINE DELPHI2UP}
+ {$DEFINE DELPHI3UP}
+ {$DEFINE DELPHI4UP}
+ {$ENDIF}
+
+ { defines for C++Builder 4.0 }
+ {$IFDEF VER125}
+ {$DEFINE DELPHI1UP}
+ {$DEFINE DELPHI2UP}
+ {$DEFINE DELPHI3UP}
+ {$DEFINE DELPHI4UP}
+ {$DEFINE CBUILDER}
+ {$DEFINE CBUILDER4}
+ {$DEFINE CBUILDER1UP}
+ {$DEFINE CBUILDER3UP}
+ {$DEFINE CBUILDER4UP}
+ {$ENDIF}
+ { defines for Delphi 5.0 }
+ {$IFDEF VER130}
+ {$DEFINE DELPHI}
+ {$DEFINE DELPHI5}
+ {$DEFINE DELPHI1UP}
+ {$DEFINE DELPHI2UP}
+ {$DEFINE DELPHI3UP}
+ {$DEFINE DELPHI4UP}
+ {$DEFINE DELPHI5UP}
+ {$ENDIF}
+
+ { defines for C++Builder 5.0 }
+ {$IFDEF VER135}
+ {$DEFINE DELPHI1UP}
+ {$DEFINE DELPHI2UP}
+ {$DEFINE DELPHI3UP}
+ {$DEFINE DELPHI4UP}
+ {$DEFINE DELPHI5UP}
+ {$DEFINE CBUILDER}
+ {$DEFINE CBUILDER5}
+ {$DEFINE CBUILDER1UP}
+ {$DEFINE CBUILDER3UP}
+ {$DEFINE CBUILDER4UP}
+ {$DEFINE CBUILDER5UP}
+ {$ENDIF}
+
+ { defines for Delphi 6.0 }
+ {$IFDEF VER140}
+ {$DEFINE VER140UP}
+ {$DEFINE DELPHI}
+ {$DEFINE DELPHI6}
+ {$DEFINE DELPHI1UP}
+ {$DEFINE DELPHI2UP}
+ {$DEFINE DELPHI3UP}
+ {$DEFINE DELPHI4UP}
+ {$DEFINE DELPHI5UP}
+ {$DEFINE DELPHI6UP}
+ {$ENDIF}
+
+ { defines for Delphi 7.0 }
+ {$IFDEF VER150}
+ {$DEFINE VER140UP}
+ {$DEFINE DELPHI}
+ {$DEFINE DELPHI7}
+ {$DEFINE DELPHI1UP}
+ {$DEFINE DELPHI2UP}
+ {$DEFINE DELPHI3UP}
+ {$DEFINE DELPHI4UP}
+ {$DEFINE DELPHI5UP}
+ {$DEFINE DELPHI6UP}
+ {$DEFINE DELPHI7UP}
+ {$ENDIF}
+
+ { defines for Delphi 2005 }
+ {$IFDEF VER170}
+ {$DEFINE VER140UP}
+ {$DEFINE DELPHI}
+ {$DEFINE DELPHI9}
+ {$DEFINE DELPHI2005}
+ {$DEFINE DELPHI1UP}
+ {$DEFINE DELPHI2UP}
+ {$DEFINE DELPHI3UP}
+ {$DEFINE DELPHI4UP}
+ {$DEFINE DELPHI5UP}
+ {$DEFINE DELPHI6UP}
+ {$DEFINE DELPHI7UP}
+ {$DEFINE DELPHI9UP}
+ {$DEFINE DELPHI2005UP}
+ {$DEFINE BDS}
+ {$DEFINE BDS3}
+ {$DEFINE BDS3UP}
+ {$ENDIF}
+
+ { defines for Delphi 2006 }
+ {$IFDEF VER180}
+ {$DEFINE VER140UP}
+ {$DEFINE DELPHI}
+ {$DEFINE DELPHI10}
+ {$DEFINE DELPHI10A}
+ {$DEFINE DELPHI2006}
+ {$DEFINE DELPHI1UP}
+ {$DEFINE DELPHI2UP}
+ {$DEFINE DELPHI3UP}
+ {$DEFINE DELPHI4UP}
+ {$DEFINE DELPHI5UP}
+ {$DEFINE DELPHI6UP}
+ {$DEFINE DELPHI7UP}
+ {$DEFINE DELPHI9UP}
+ {$DEFINE DELPHI10UP}
+ {$DEFINE DELPHI2005UP}
+ {$DEFINE DELPHI2006UP}
+ {$DEFINE BDS}
+ {$DEFINE BDS4}
+ {$DEFINE BDS3UP}
+ {$DEFINE BDS4UP}
+ {$ENDIF}
+
+ { defines for Delphi 2007 }
+ {$IFDEF VER185}
+ {$UNDEF DELPHI10A} // declared in VER180
+ {$UNDEF DELPHI2006} // declared in VER180
+ {$UNDEF BDS4} // declared in VER180
+
+ {$DEFINE DELPHI10B}
+ {$DEFINE DELPHI10BUP}
+ {$DEFINE DELPHI11}
+ {$DEFINE DELPHI11UP}
+ {$DEFINE DELPHI2007}
+ {$DEFINE DELPHI2007UP}
+ {$DEFINE BDS5}
+ {$DEFINE BDS5UP}
+ {$ENDIF}
+
+ { defines for Delphi 2009 }
+ {$IFDEF VER200}
+ {$DEFINE VER140UP}
+ {$DEFINE DELPHI}
+
+ {$DEFINE DELPHI12}
+ {$DEFINE DELPHI1UP}
+ {$DEFINE DELPHI2UP}
+ {$DEFINE DELPHI3UP}
+ {$DEFINE DELPHI4UP}
+ {$DEFINE DELPHI5UP}
+ {$DEFINE DELPHI6UP}
+ {$DEFINE DELPHI7UP}
+ {$DEFINE DELPHI9UP}
+ {$DEFINE DELPHI10UP}
+ {$DEFINE DELPHI11UP}
+ {$DEFINE DELPHI12UP}
+
+ {$DEFINE DELPHI2009}
+ {$DEFINE DELPHI2005UP}
+ {$DEFINE DELPHI2006UP}
+ {$DEFINE DELPHI2007UP}
+ {$DEFINE DELPHI2009UP}
+
+ {$DEFINE BDS}
+ {$DEFINE BDS6}
+ {$DEFINE BDS3UP}
+ {$DEFINE BDS4UP}
+ {$DEFINE BDS5UP}
+ {$DEFINE BDS6UP}
+ {$ENDIF}
+
+ { defines for Delphi 2010 }
+ {$IFDEF VER210}
+ {$DEFINE VER140UP}
+ {$DEFINE DELPHI}
+
+ {$DEFINE DELPHI14}
+ {$DEFINE DELPHI1UP}
+ {$DEFINE DELPHI2UP}
+ {$DEFINE DELPHI3UP}
+ {$DEFINE DELPHI4UP}
+ {$DEFINE DELPHI5UP}
+ {$DEFINE DELPHI6UP}
+ {$DEFINE DELPHI7UP}
+ {$DEFINE DELPHI9UP}
+ {$DEFINE DELPHI10UP}
+ {$DEFINE DELPHI11UP}
+ {$DEFINE DELPHI12UP}
+ {$DEFINE DELPHI14UP}
+
+ {$DEFINE DELPHI2010}
+ {$DEFINE DELPHI2005UP}
+ {$DEFINE DELPHI2006UP}
+ {$DEFINE DELPHI2007UP}
+ {$DEFINE DELPHI2009UP}
+ {$DEFINE DELPHI2010UP}
+
+ {$DEFINE BDS}
+ {$DEFINE BDS7}
+ {$DEFINE BDS3UP}
+ {$DEFINE BDS4UP}
+ {$DEFINE BDS5UP}
+ {$DEFINE BDS6UP}
+ {$DEFINE BDS7UP}
+ {$ENDIF}
+
+
+ {$IFDEF WIN32}
+ {$DEFINE MSWINDOWS} //not automatically defined for Delphi 2 thru 5
+ {$DEFINE 32BIT}
+ {$DEFINE CPU32}
+ {$ENDIF}
+
+{$ENDIF MSWINDOWS}
+
+{ defines for "Delphi for .NET" }
+{$IFDEF CLR}
+ {$DEFINE DOTNET}
+{$ENDIF}
+
+{$IFDEF DELPHI}
+ {$IFDEF DELPHI2UP}
+ {$DEFINE DELPHI_32BIT}
+ {$ENDIF}
+{$ENDIF}
+
+{$IFDEF CBUILDER}
+ {$DEFINE CBUILDER_32BIT}
+{$ENDIF}
+
+{$IFNDEF FPC}
+
+ { Kylix 1.0 thru 3.0 }
+ {$IFDEF LINUX}
+
+ {$DEFINE VER140UP}
+
+ { Any Kylix }
+ {$DEFINE 32BIT}
+ {$DEFINE LINUX32}
+ {$DEFINE KYLIX_32BIT}
+ {$DEFINE KYLIX}
+ {$DEFINE KYLIX1UP}
+
+ {$IFDEF CONDITIONALEXPRESSIONS}
+ {$IF Declared(CompilerVersion)}
+
+ { Kylix 2.0 }
+ {$IF Declared(RTLVersion) and (RTLVersion = 14.1)}
+ {$DEFINE KYLIX2}
+ {$DEFINE KYLIX1UP}
+ {$DEFINE KYLIX2UP}
+ {$IFEND}
+
+ { Kylix 3.0 - Delphi portion }
+ {$IF Declared(RTLVersion) and (RTLVersion = 14.5)}
+ {$DEFINE KYLIX3}
+ {$DEFINE KYLIX1UP}
+ {$DEFINE KYLIX2UP}
+ {$DEFINE KYLIX3UP}
+ {$IFEND}
+
+ { Kylix 1.0 }
+ {$ELSE}
+ {$DEFINE KYLIX1}
+ {$IFEND}
+ {$ENDIF CONDITIONALEXPRESSIONS}
+
+ {$ENDIF LINUX}
+{$ENDIF}
+
+{ CPU }
+
+{$IFDEF FPC}
+ {$IFDEF MSWINDOWS}
+ {$IFDEF CPU64}
+ {$DEFINE WIN64}
+ {$ENDIF}
+ {$ENDIF}
+ {$IFDEF LINUX}
+ {$IFDEF CPU32}
+ {$DEFINE LINUX32}
+ {$ENDIF}
+ {$IFDEF CPU64}
+ {$DEFINE LINUX64}
+ {$ENDIF}
+ {$ENDIF}
+ {$IFDEF DARWIN}
+ {$IFDEF CPU32}
+ {$DEFINE DARWIN32}
+ {$ENDIF}
+ {$IFDEF CPU64}
+ {$DEFINE DARWIN64}
+ {$ENDIF}
+ {$ENDIF}
+{$ENDIF}
\ No newline at end of file
diff --git a/Units/PascalScript/pascalscript.pas b/Units/PascalScript/pascalscript.pas
new file mode 100644
index 0000000..d5bf447
--- /dev/null
+++ b/Units/PascalScript/pascalscript.pas
@@ -0,0 +1,29 @@
+{ This file was automatically created by Lazarus. Do not edit!
+This source is only used to compile and install the package.
+ }
+
+unit PascalScript;
+
+interface
+
+uses
+ uPSRuntime, PascalScript_Core_Reg, uPSC_buttons, uPSC_classes, uPSC_controls,
+ uPSC_dateutils, uPSC_DB, uPSC_dll, uPSC_extctrls, uPSC_forms,
+ uPSC_graphics, uPSC_menus, uPSC_std, uPSC_stdctrls, uPSCompiler,
+ uPSComponent, uPSComponent_Controls, uPSComponent_DB, uPSComponent_Default,
+ uPSComponent_Forms, uPSComponent_StdCtrls, uPSComponentExt, uPSDebugger,
+ uPSDisassembly, uPSPreProcessor, uPSR_buttons, uPSR_classes, uPSR_controls,
+ uPSR_dateutils, uPSR_DB, uPSR_dll, uPSR_extctrls, uPSR_forms,
+ uPSR_graphics, uPSR_menus, uPSR_std, uPSR_stdctrls, uPSUtils,
+ LazarusPackageIntf;
+
+implementation
+
+procedure Register;
+begin
+ RegisterUnit('PascalScript_Core_Reg', @PascalScript_Core_Reg.Register);
+end;
+
+initialization
+ RegisterPackage('PascalScript', @Register);
+end.
diff --git a/Units/PascalScript/powerpc.inc b/Units/PascalScript/powerpc.inc
new file mode 100644
index 0000000..ec0c779
--- /dev/null
+++ b/Units/PascalScript/powerpc.inc
@@ -0,0 +1,343 @@
+{ implementation of the powerpc osx abi for function calls in pascal script
+ Copyright (c) 2007 by Henry Vermaak (henry.vermaak@gmail.com) }
+
+{$ifndef darwin}
+ {$fatal This code is Darwin specific at the moment!}
+{$endif}
+
+{$ifndef cpu32}
+ {$fatal This code is 32bit specific at the moment!}
+{$endif}
+
+const
+ rtINT = 0;
+ rtINT64 = 1;
+ rtFLOAT = 2;
+
+type
+ Trint = array[1..8] of dword;
+ Trfloat = array[1..13] of double;
+
+{$goto on}
+{ define labels }
+label
+ rfloat_loop,
+ stack_loop,
+ load_regs,
+ int_result,
+ int64_result,
+ float_result,
+ asmcall_end;
+
+{ call a function from a pointer }
+{ resulttype: 0 = int, 1 = int64, 2 = float }
+function ppcasmcall(rint: Trint; rfloat: Trfloat; proc, stack: pointer; stacksize, resulttype: integer): pointer; assembler; nostackframe;
+asm
+ mflr r0
+ stw r0, 8(r1)
+
+ { save non-volatile register/s - make sure the stack size is sufficient! }
+ stw r31, -4(r1) { stacksize }
+
+ stwu r1, -240(r1) { create stack }
+
+ { get all the params into the stack }
+ stw r3, 48(r1) { rint }
+ stw r4, 52(r1) { rfloat }
+ stw r5, 56(r1) { proc }
+ stw r6, 60(r1) { stack }
+ stw r7, 64(r1) { stacksize }
+ stw r8, 68(r1) { resulttype }
+ { result is stored in 72(r1) and 76(r1) (if returning int64) }
+
+ { write rint array into stack }
+ lwz r2, 48(r1) { rint }
+ lfd f0, 0(r2)
+ stfd f0, 80(r1) { rint[1], rint[2] }
+ lfd f0, 8(r2)
+ stfd f0, 88(r1) { rint[3], rint[4] }
+ lfd f0, 16(r2)
+ stfd f0, 96(r1) { rint[5], rint[6] }
+ lfd f0, 24(r2)
+ stfd f0, 104(r1) { rint[7], rint[8] }
+
+ { write rfloat array into stack }
+ lwz r2, 52(r1) { rfloat }
+ addi r4, r1, 112 { rfloat[1] from here upwards (8 bytes apart) }
+ subi r2, r2, 8 { src }
+ subi r4, r4, 8 { dest }
+ li r3, 13 { counter }
+
+rfloat_loop:
+ subic. r3, r3, 1 { dec counter }
+ lfdu f0, 8(r2) { load rfloat[x] + update }
+ stfdu f0, 8(r4) { store rfloat[x] + update }
+ bne cr0, rfloat_loop
+
+ { create new stack }
+ mflr r0
+ stw r0, 8(r1)
+ mr r12, r1 { remember previous stack to fill in regs later }
+
+ lwz r31, 64(r12) { load stacksize into r31 }
+ neg r3, r31 { negate }
+ stwux r1, r1, r3 { create new stack }
+
+ { build up the stack here }
+ mr r3, r31 { counter }
+ subic. r3, r3, 24 { don't write first 24 }
+ blt cr0, load_regs { don't fill in stack if there is none }
+
+ lwz r2, 60(r12) { pointer to stack }
+ addi r2, r2, 24 { start of params }
+ subi r2, r2, 1 { src }
+
+ addi r4, r1, 24 { start of params }
+ subi r4, r4, 1 { dest }
+
+stack_loop:
+ subic. r3, r3, 1 { dec counter }
+ lbzu r5, 1(r2) { load stack + update }
+ stbu r5, 1(r4) { store stack + update }
+ bne cr0, stack_loop
+
+load_regs: { now load the registers from the previous stack in r12 }
+ lwz r3, 80(r12)
+ lwz r4, 84(r12)
+ lwz r5, 88(r12)
+ lwz r6, 92(r12)
+ lwz r7, 96(r12)
+ lwz r8, 100(r12)
+ lwz r9, 104(r12)
+ lwz r10, 108(r12)
+
+ lfd f1, 112(r12)
+ lfd f2, 120(r12)
+ lfd f3, 128(r12)
+ lfd f4, 136(r12)
+ lfd f5, 144(r12)
+ lfd f6, 152(r12)
+ lfd f7, 160(r12)
+ lfd f8, 168(r12)
+ lfd f9, 176(r12)
+ lfd f10, 184(r12)
+ lfd f11, 192(r12)
+ lfd f12, 200(r12)
+ lfd f13, 208(r12)
+
+ { now call this function }
+ lwz r2, 56(r12) { proc }
+ mtctr r2 { move to ctr }
+ bctrl { branch and link to ctr }
+
+ { restore stack - use stacksize in r31 }
+ add r1, r1, r31
+ lwz r0, 8(r1)
+ mtlr r0
+
+ { check resulttype and put appropriate pointer into r3 }
+ lwz r2, 68(r1) { resulttype }
+ cmpwi cr0, r2, 0 { int result? }
+ beq cr0, int_result { branch if equal }
+
+ cmpwi cr0, r2, 1 { single result? }
+ beq cr0, int64_result { branch if equal }
+
+
+float_result: { the result is a double}
+ stfd f1, 72(r1) { write f1 to result on stack }
+ b asmcall_end
+
+
+int64_result: { the result is a single }
+ stw r3, 72(r1) { write high dword to result on stack }
+ stw r4, 76(r1) { write low dword to result on stack }
+ b asmcall_end
+
+
+int_result: { the result is dword }
+ stw r3, 72(r1) { write r3 to result on stack }
+
+
+asmcall_end: { epilogue }
+ addi r3, r1, 72 { pointer to result on the stack }
+ addi r1, r1, 240 { restore stack }
+
+ { restore non-volatile register/s }
+ lwz r31, -4(r1)
+
+ lwz r0, 8(r1)
+ mtlr r0
+ blr
+end;
+
+function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean;
+var
+ rint: Trint; { registers r3 to r10 }
+ rfloat: Trfloat; { registers f1 to f13 }
+ st: packed array of byte; { stack }
+ i, j, rindex, findex, stindex: integer;
+ fvar: PPSVariantIFC;
+ IsConstructor: Boolean;
+ { add a dword to stack }
+ procedure addstackdword(value: dword);
+ begin
+ setlength(st, stindex+4);
+ pdword(@st[stindex])^ := value;
+ inc(stindex, 4);
+ end;
+
+ { add a float to stack }
+ procedure addstackfloat(value: pointer; size: integer);
+ begin
+ setlength(st, stindex + (size * 4));
+ if size = 1
+ then psingle(@st[stindex])^ := single(value^)
+ else pdouble(@st[stindex])^ := double(value^);
+ inc(stindex, size*4);
+ end;
+
+ { add to the general registers or overflow to stack }
+ procedure addgen(value: dword);
+ begin
+ if rindex <= 8
+ then begin
+ rint[rindex] := value;
+ inc(rindex);
+ addstackdword(value);
+ end
+ else begin
+ addstackdword(value);
+ end;
+ end;
+ { add to the float registers or overflow to stack }
+ { size = 1 for single, 2 for double }
+ procedure addfloat(value: pointer; size: integer);
+ begin
+ if findex <= 13
+ then begin
+ if size = 1
+ then rfloat[findex] := single(value^)
+ else rfloat[findex] := double(value^);
+ inc(findex);
+ inc(rindex, size);
+ addstackfloat(value, size);
+ end
+ else begin
+ addstackfloat(value, size);
+ end;
+ end;
+
+begin
+ if (Integer(CallingConv) and 64) <> 0 then begin
+ IsConstructor := true;
+ CAllingConv := TPSCallingConvention(Integer(CallingConv) and not 64);
+ end else IsConstructor := false;
+
+ rindex := 1;
+ findex := 1;
+ stindex := 24;
+ setlength(st, stindex);
+ Result := False;
+
+ { the pointer of the result needs to be passed first in the case of some result types }
+ if assigned(res)
+ then begin
+ case res.atype.basetype of
+ btStaticArray, btRecord: addgen(dword(res.dta));
+ end;
+ end;
+
+ { process all parameters }
+ for i := 0 to Params.Count-1 do begin
+ if Params[i] = nil
+ then Exit;
+ fvar := Params[i];
+
+ { cook dynamic arrays - fpc stores size-1 at @array-4 }
+ if (fvar.aType.BaseType = btArray)
+ then dec(pdword(pointer(fvar.dta^)-4)^);
+
+ if fvar.varparam
+ then begin { var param }
+ case fvar.aType.BaseType of
+ { add var params here }
+ btArray, btVariant, btSet, btStaticArray, btRecord, btInterface, btClass, {$IFNDEF PS_NOWIDESTRING} btWideString, btWideChar, {$ENDIF}
+ btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency
+ {$IFNDEF PS_NOINT64}, bts64{$ENDIF}: addgen(dword(fvar.dta)); { TODO: test all }
+ else begin
+ writeln(stderr, 'Parameter type not recognised!');
+ Exit;
+ end;
+ end; { case }
+ end else begin { not a var param }
+ case fvar.aType.BaseType of
+// btArray, btVariant, btSet, btStaticArray, btRecord, btInterface, btClass, {$IFNDEF PS_NOWIDESTRING} btWideString, btWideChar, {$ENDIF}
+// btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency
+// {$IFNDEF PS_NOINT64}, bts64{$ENDIF}: writeln('normal param');
+
+ { add normal params here }
+ btString: addgen(dword(pstring(fvar.dta)^));
+ btU8, btS8: addgen(dword(pbyte(fvar.dta)^));
+ btU16, BtS16: addgen(dword(pword(fvar.dta)^));
+ btU32, btS32: addgen(dword(pdword(fvar.dta)^));
+ btSingle: addfloat(fvar.dta, 1);
+ btDouble, btExtended: addfloat(fvar.dta, 2);
+ btPChar: addgen(dword(ppchar(fvar.dta)^));
+ btChar: addgen(dword(pchar(fvar.dta)^));
+ {$IFNDEF PS_NOINT64}bts64:{$ENDIF} begin
+ addgen(dword(pint64(fvar.dta)^ shr 32));
+ addgen(dword(pint64(fvar.dta)^ and $ffffffff));
+ end;
+ btStaticArray: addgen(dword(fvar.dta));
+ btRecord: for j := 0 to (fvar.atype.realsize div 4)-1 do
+ addgen(pdword(fvar.dta + j*4)^);
+ btArray: addgen(dword(fvar.dta^));
+
+ { TODO add and test }
+{ btVariant, btSet, btInterface, btClass }
+
+ else begin
+ writeln(stderr, 'Parameter type not implemented!');
+ Exit;
+ end;
+ end; { case }
+ end; { else }
+ end; { for }
+
+ if not assigned(res)
+ then begin
+ ppcasmcall(rint, rfloat, address, st, stindex, rtINT); { ignore return }
+ end
+ else begin
+ case res.atype.basetype of
+ { add result types here }
+ btString: pstring(res.dta)^ := pstring(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^;
+ btU8, btS8: pbyte(res.dta)^ := byte(pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^);
+ btU16, btS16: pword(res.dta)^ := word(pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^);
+ btU32, btS32: pdword(res.dta)^ := pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^;
+ btSingle: psingle(res.dta)^ := pdouble(ppcasmcall(rint, rfloat, address, st, stindex, rtFLOAT))^;
+ btDouble, btExtended: pdouble(res.dta)^ := pdouble(ppcasmcall(rint, rfloat, address, st, stindex, rtFLOAT))^;
+ btPChar: ppchar(res.dta)^ := pchar(pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^);
+ btChar: pchar(res.dta)^ := char(pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^);
+ btStaticArray, btRecord: ppcasmcall(rint, rfloat, address, st, stindex, rtINT);
+ btArray: res.dta := ppcasmcall(rint, rfloat, address, st, stindex, rtINT);
+
+ { TODO add and test }
+
+ else begin
+ writeln(stderr, 'Result type not implemented!');
+ exit;
+ end; { else }
+ end; { case }
+ end;
+
+ { cook dynamic arrays - fpc stores size-1 at @array-4 }
+ for i := 0 to Params.Count-1 do begin
+ fvar := Params[i];
+ if (fvar.aType.BaseType = btArray)
+ then inc(pdword(pointer(fvar.dta^)-4)^);
+ end;
+
+ Result := True;
+end;
diff --git a/Units/PascalScript/uPSC_DB.pas b/Units/PascalScript/uPSC_DB.pas
new file mode 100644
index 0000000..3a0cc81
--- /dev/null
+++ b/Units/PascalScript/uPSC_DB.pas
@@ -0,0 +1,892 @@
+{ Compiletime DB support }
+Unit uPSC_DB;
+{
+This file has been generated by UnitParser v0.4, written by M. Knight.
+Source Code from Carlo Kok has been used to implement various sections of
+UnitParser. Components of ifps3 are used in the construction of UnitParser,
+code implementing the class wrapper is taken from Carlo Kok''s conv unility
+
+Licence :
+This software is provided 'as-is', without any expressed or implied
+warranty. In no event will the author be held liable for any damages
+arising from the use of this software.
+Permission is granted to anyone to use this software for any kind of
+application, and to alter it and redistribute it freely, subject to
+the following restrictions:
+1. The origin of this software must not be misrepresented, you must
+ not claim that you wrote the original software.
+2. Altered source versions must be plainly marked as such, and must
+ not be misrepresented as being the original software.
+3. You may not create a library that uses this library as a main part
+ of the program and sell that library.
+4. You must have a visible line in your programs aboutbox or
+ documentation that it is made using Innerfuse Script and where
+ Innerfuse Pascal Script can be found.
+5. This notice may not be removed or altered from any source
+ distribution.
+
+If you have any questions concerning this license write to Carlo Kok:
+ ck@carlo-kok.com or try the newsserver:
+ news://news.carlo-kok.com/
+}
+{$I PascalScript.inc}
+Interface
+uses
+ uPSCompiler;
+
+procedure SIRegisterTDATASET(CL: TPSPascalCompiler);
+procedure SIRegisterTPARAMS(CL: TPSPascalCompiler);
+procedure SIRegisterTPARAM(CL: TPSPascalCompiler);
+procedure SIRegisterTGUIDFIELD(CL: TPSPascalCompiler);
+procedure SIRegisterTVARIANTFIELD(CL: TPSPascalCompiler);
+procedure SIRegisterTREFERENCEFIELD(CL: TPSPascalCompiler);
+procedure SIRegisterTDATASETFIELD(CL: TPSPascalCompiler);
+procedure SIRegisterTARRAYFIELD(CL: TPSPascalCompiler);
+procedure SIRegisterTADTFIELD(CL: TPSPascalCompiler);
+procedure SIRegisterTOBJECTFIELD(CL: TPSPascalCompiler);
+procedure SIRegisterTGRAPHICFIELD(CL: TPSPascalCompiler);
+procedure SIRegisterTMEMOFIELD(CL: TPSPascalCompiler);
+procedure SIRegisterTBLOBFIELD(CL: TPSPascalCompiler);
+{$IFDEF DELPHI6UP}
+procedure SIRegisterTFMTBCDFIELD(CL: TPSPascalCompiler);
+{$ENDIF}
+procedure SIRegisterTBCDFIELD(CL: TPSPascalCompiler);
+procedure SIRegisterTVARBYTESFIELD(CL: TPSPascalCompiler);
+procedure SIRegisterTBYTESFIELD(CL: TPSPascalCompiler);
+procedure SIRegisterTBINARYFIELD(CL: TPSPascalCompiler);
+procedure SIRegisterTTIMEFIELD(CL: TPSPascalCompiler);
+procedure SIRegisterTDATEFIELD(CL: TPSPascalCompiler);
+procedure SIRegisterTDATETIMEFIELD(CL: TPSPascalCompiler);
+procedure SIRegisterTBOOLEANFIELD(CL: TPSPascalCompiler);
+procedure SIRegisterTCURRENCYFIELD(CL: TPSPascalCompiler);
+procedure SIRegisterTFLOATFIELD(CL: TPSPascalCompiler);
+procedure SIRegisterTAUTOINCFIELD(CL: TPSPascalCompiler);
+procedure SIRegisterTWORDFIELD(CL: TPSPascalCompiler);
+procedure SIRegisterTLARGEINTFIELD(CL: TPSPascalCompiler);
+procedure SIRegisterTSMALLINTFIELD(CL: TPSPascalCompiler);
+procedure SIRegisterTINTEGERFIELD(CL: TPSPascalCompiler);
+procedure SIRegisterTNUMERICFIELD(CL: TPSPascalCompiler);
+procedure SIRegisterTWIDESTRINGFIELD(CL: TPSPascalCompiler);
+procedure SIRegisterTSTRINGFIELD(CL: TPSPascalCompiler);
+procedure SIRegisterTFIELD(CL: TPSPascalCompiler);
+procedure SIRegisterTLOOKUPLIST(CL: TPSPascalCompiler);
+procedure SIRegisterTFIELDS(CL: TPSPascalCompiler);
+procedure SIRegisterTFIELDLIST(CL: TPSPascalCompiler);
+procedure SIRegisterTFIELDDEFLIST(CL: TPSPascalCompiler);
+procedure SIRegisterTFLATLIST(CL: TPSPascalCompiler);
+procedure SIRegisterTINDEXDEFS(CL: TPSPascalCompiler);
+procedure SIRegisterTINDEXDEF(CL: TPSPascalCompiler);
+procedure SIRegisterTFIELDDEFS(CL: TPSPascalCompiler);
+procedure SIRegisterTFIELDDEF(CL: TPSPascalCompiler);
+procedure SIRegisterTDEFCOLLECTION(CL: TPSPascalCompiler);
+procedure SIRegisterTNAMEDITEM(CL: TPSPascalCompiler);
+procedure SIRegister_DB(Cl: TPSPascalCompiler);
+
+implementation
+Uses Sysutils;
+
+Function RegClassS(cl : TPSPascalCompiler;Const InheritsFrom,Classname : String) : TPSCompileTimeClass;
+begin
+Result := cl.FindClass(Classname);
+if Result = nil then
+ Result := cl.AddClassN(cl.FindClass(InheritsFrom),Classname)
+else
+ Result.ClassInheritsFrom := cl.FindClass(InheritsFrom);
+end;
+
+procedure SIRegisterTDATASET(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TCOMPONENT','TDATASET') do
+ begin
+ RegisterMethod('Function ACTIVEBUFFER : PCHAR');
+ RegisterMethod('Procedure APPEND');
+ RegisterMethod('Procedure APPENDRECORD( const VALUES : array of const)');
+// RegisterMethod('Function BOOKMARKVALID( BOOKMARK : TBOOKMARK) : BOOLEAN');
+ RegisterMethod('Procedure CANCEL');
+ RegisterMethod('Procedure CHECKBROWSEMODE');
+ RegisterMethod('Procedure CLEARFIELDS');
+ RegisterMethod('Procedure CLOSE');
+ RegisterMethod('Function CONTROLSDISABLED : BOOLEAN');
+// RegisterMethod('Function COMPAREBOOKMARKS( BOOKMARK1, BOOKMARK2 : TBOOKMARK) : INTEGER');
+ RegisterMethod('Function CREATEBLOBSTREAM( FIELD : TFIELD; MODE : TBLOBSTREAMMODE) : TSTREAM');
+ RegisterMethod('Procedure CURSORPOSCHANGED');
+ RegisterMethod('Procedure DELETE');
+ RegisterMethod('Procedure DISABLECONTROLS');
+ RegisterMethod('Procedure EDIT');
+ RegisterMethod('Procedure ENABLECONTROLS');
+{$IFDEF DELPHI2006UP}
+ RegisterMethod('Function FIELDBYNAME( const FIELDNAME : WIDESTRING) : TFIELD');
+ RegisterMethod('Function FINDFIELD( const FIELDNAME : WideString) : TFIELD');
+{$ELSE}
+ RegisterMethod('Function FIELDBYNAME( const FIELDNAME : STRING) : TFIELD');
+ RegisterMethod('Function FINDFIELD( const FIELDNAME : STRING) : TFIELD');
+{$ENDIF}
+ RegisterMethod('Function FINDFIRST : BOOLEAN');
+ RegisterMethod('Function FINDLAST : BOOLEAN');
+ RegisterMethod('Function FINDNEXT : BOOLEAN');
+ RegisterMethod('Function FINDPRIOR : BOOLEAN');
+ RegisterMethod('Procedure FIRST');
+// RegisterMethod('Procedure FREEBOOKMARK( BOOKMARK : TBOOKMARK)');
+// RegisterMethod('Function GETBOOKMARK : TBOOKMARK');
+ RegisterMethod('Function GETCURRENTRECORD( BUFFER : PCHAR) : BOOLEAN');
+// RegisterMethod('Procedure GETDETAILDATASETS( LIST : TLIST)');
+// RegisterMethod('Procedure GETFIELDLIST( LIST : TLIST; const FIELDNAMES : STRING)');
+// RegisterMethod('Procedure GETDETAILLINKFIELDS( MASTERFIELDS, DETAILFIELDS : TLIST)');
+// RegisterMethod('Function GETBLOBFIELDDATA( FIELDNO : INTEGER; var BUFFER : TBLOBBYTEDATA) : INTEGER');
+ RegisterMethod('Procedure GETFIELDNAMES( LIST : TSTRINGS)');
+// RegisterMethod('Procedure GOTOBOOKMARK( BOOKMARK : TBOOKMARK)');
+ RegisterMethod('Procedure INSERT');
+ RegisterMethod('Procedure INSERTRECORD( const VALUES : array of const)');
+ RegisterMethod('Function ISEMPTY : BOOLEAN');
+ RegisterMethod('Function ISLINKEDTO( DATASOURCE : TDATASOURCE) : BOOLEAN');
+ RegisterMethod('Function ISSEQUENCED : BOOLEAN');
+ RegisterMethod('Procedure LAST');
+ RegisterMethod('Function LOCATE( const KEYFIELDS : String; const KEYVALUES : VARIANT; OPTIONS : TLOCATEOPTIONS) : BOOLEAN');
+ RegisterMethod('Function LOOKUP( const KEYFIELDS : String; const KEYVALUES : VARIANT; const RESULTFIELDS : String) : VARIANT');
+ RegisterMethod('Function MOVEBY( DISTANCE : INTEGER) : INTEGER');
+ RegisterMethod('Procedure NEXT');
+ RegisterMethod('Procedure OPEN');
+ RegisterMethod('Procedure POST');
+ RegisterMethod('Procedure PRIOR');
+ RegisterMethod('Procedure REFRESH');
+// RegisterMethod('Procedure RESYNC( MODE : TRESYNCMODE)');
+ RegisterMethod('Procedure SETFIELDS( const VALUES : array of const)');
+ RegisterMethod('Function TRANSLATE( SRC, DEST : PCHAR; TOOEM : BOOLEAN) : INTEGER');
+ RegisterMethod('Procedure UPDATECURSORPOS');
+ RegisterMethod('Procedure UPDATERECORD');
+ RegisterMethod('Function UPDATESTATUS : TUPDATESTATUS');
+ RegisterProperty('AGGFIELDS', 'TFIELDS', iptr);
+ RegisterProperty('BOF', 'BOOLEAN', iptr);
+// RegisterProperty('BOOKMARK', 'TBOOKMARKSTR', iptrw);
+ RegisterProperty('CANMODIFY', 'BOOLEAN', iptr);
+ RegisterProperty('DATASETFIELD', 'TDATASETFIELD', iptrw);
+ RegisterProperty('DATASOURCE', 'TDATASOURCE', iptr);
+ RegisterProperty('DEFAULTFIELDS', 'BOOLEAN', iptr);
+ RegisterProperty('DESIGNER', 'TDATASETDESIGNER', iptr);
+ RegisterProperty('EOF', 'BOOLEAN', iptr);
+ RegisterProperty('BLOCKREADSIZE', 'INTEGER', iptrw);
+ RegisterProperty('FIELDCOUNT', 'INTEGER', iptr);
+ RegisterProperty('FIELDDEFS', 'TFIELDDEFS', iptrw);
+ RegisterProperty('FIELDDEFLIST', 'TFIELDDEFLIST', iptr);
+ RegisterProperty('FIELDS', 'TFIELDS', iptr);
+ RegisterProperty('FIELDLIST', 'TFIELDLIST', iptr);
+ RegisterProperty('FIELDVALUES', 'VARIANT String', iptrw);
+ RegisterProperty('FOUND', 'BOOLEAN', iptr);
+{$IFDEF DELPHI6UP}
+ RegisterProperty('ISUNIDIRECTIONAL', 'BOOLEAN', iptr);
+{$ENDIF}
+ RegisterProperty('MODIFIED', 'BOOLEAN', iptr);
+ RegisterProperty('OBJECTVIEW', 'BOOLEAN', iptrw);
+ RegisterProperty('RECORDCOUNT', 'INTEGER', iptr);
+ RegisterProperty('RECNO', 'INTEGER', iptrw);
+ RegisterProperty('RECORDSIZE', 'WORD', iptr);
+ RegisterProperty('SPARSEARRAYS', 'BOOLEAN', iptrw);
+ RegisterProperty('STATE', 'TDATASETSTATE', iptr);
+ RegisterProperty('FILTER', 'String', iptrw);
+ RegisterProperty('FILTERED', 'BOOLEAN', iptrw);
+ RegisterProperty('FILTEROPTIONS', 'TFILTEROPTIONS', iptrw);
+ RegisterProperty('ACTIVE', 'BOOLEAN', iptrw);
+ RegisterProperty('AUTOCALCFIELDS', 'BOOLEAN', iptrw);
+ RegisterProperty('BEFOREOPEN', 'TDATASETNOTIFYEVENT', iptrw);
+ RegisterProperty('AFTEROPEN', 'TDATASETNOTIFYEVENT', iptrw);
+ RegisterProperty('BEFORECLOSE', 'TDATASETNOTIFYEVENT', iptrw);
+ RegisterProperty('AFTERCLOSE', 'TDATASETNOTIFYEVENT', iptrw);
+ RegisterProperty('BEFOREINSERT', 'TDATASETNOTIFYEVENT', iptrw);
+ RegisterProperty('AFTERINSERT', 'TDATASETNOTIFYEVENT', iptrw);
+ RegisterProperty('BEFOREEDIT', 'TDATASETNOTIFYEVENT', iptrw);
+ RegisterProperty('AFTEREDIT', 'TDATASETNOTIFYEVENT', iptrw);
+ RegisterProperty('BEFOREPOST', 'TDATASETNOTIFYEVENT', iptrw);
+ RegisterProperty('AFTERPOST', 'TDATASETNOTIFYEVENT', iptrw);
+ RegisterProperty('BEFORECANCEL', 'TDATASETNOTIFYEVENT', iptrw);
+ RegisterProperty('AFTERCANCEL', 'TDATASETNOTIFYEVENT', iptrw);
+ RegisterProperty('BEFOREDELETE', 'TDATASETNOTIFYEVENT', iptrw);
+ RegisterProperty('AFTERDELETE', 'TDATASETNOTIFYEVENT', iptrw);
+ RegisterProperty('BEFORESCROLL', 'TDATASETNOTIFYEVENT', iptrw);
+ RegisterProperty('AFTERSCROLL', 'TDATASETNOTIFYEVENT', iptrw);
+ RegisterProperty('BEFOREREFRESH', 'TDATASETNOTIFYEVENT', iptrw);
+ RegisterProperty('AFTERREFRESH', 'TDATASETNOTIFYEVENT', iptrw);
+ RegisterProperty('ONCALCFIELDS', 'TDATASETNOTIFYEVENT', iptrw);
+ RegisterProperty('ONDELETEERROR', 'TDATASETERROREVENT', iptrw);
+ RegisterProperty('ONEDITERROR', 'TDATASETERROREVENT', iptrw);
+ RegisterProperty('ONFILTERRECORD', 'TFILTERRECORDEVENT', iptrw);
+ RegisterProperty('ONNEWRECORD', 'TDATASETNOTIFYEVENT', iptrw);
+ RegisterProperty('ONPOSTERROR', 'TDATASETERROREVENT', iptrw);
+ end;
+end;
+
+procedure SIRegisterTPARAMS(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TCOLLECTION','TPARAMS') do
+ begin
+ RegisterMethod('Procedure ASSIGNVALUES( VALUE : TPARAMS)');
+ RegisterMethod('Procedure ADDPARAM( VALUE : TPARAM)');
+ RegisterMethod('Procedure REMOVEPARAM( VALUE : TPARAM)');
+ RegisterMethod('Function CREATEPARAM( FLDTYPE : TFIELDTYPE; const PARAMNAME : String; PARAMTYPE : TPARAMTYPE) : TPARAM');
+// RegisterMethod('Procedure GETPARAMLIST( LIST : TLIST; const PARAMNAMES : STRING)');
+ RegisterMethod('Function ISEQUAL( VALUE : TPARAMS) : BOOLEAN');
+ RegisterMethod('Function PARSESQL( SQL : String; DOCREATE : BOOLEAN) : String');
+ RegisterMethod('Function PARAMBYNAME( const VALUE : String) : TPARAM');
+ RegisterMethod('Function FINDPARAM( const VALUE : String) : TPARAM');
+ RegisterProperty('ITEMS', 'TPARAM INTEGER', iptrw);
+ RegisterProperty('PARAMVALUES', 'VARIANT String', iptrw);
+ end;
+end;
+
+procedure SIRegisterTPARAM(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TCOLLECTIONITEM','TPARAM') do
+ begin
+ RegisterMethod('Procedure ASSIGNFIELD( FIELD : TFIELD)');
+ RegisterMethod('Procedure ASSIGNFIELDVALUE( FIELD : TFIELD; const VALUE : VARIANT)');
+ RegisterMethod('Procedure CLEAR');
+// RegisterMethod('Procedure GETDATA( BUFFER : POINTER)');
+ RegisterMethod('Function GETDATASIZE : INTEGER');
+ RegisterMethod('Procedure LOADFROMFILE( const FILENAME : String; BLOBTYPE : TBLOBTYPE)');
+ RegisterMethod('Procedure LOADFROMSTREAM( STREAM : TSTREAM; BLOBTYPE : TBLOBTYPE)');
+// RegisterMethod('Procedure SETBLOBDATA( BUFFER : POINTER; SIZE : INTEGER)');
+// RegisterMethod('Procedure SETDATA( BUFFER : POINTER)');
+{$IFDEF DELPHI6UP}
+ RegisterProperty('ASBCD', 'CURRENCY', iptrw);
+{$ENDIF}
+{$IFDEF DELPHI6UP}
+ RegisterProperty('ASFMTBCD', 'TBCD', iptrw);
+{$ENDIF}
+ RegisterProperty('ASBLOB', 'TBLOBDATA', iptrw);
+ RegisterProperty('ASBOOLEAN', 'BOOLEAN', iptrw);
+ RegisterProperty('ASCURRENCY', 'CURRENCY', iptrw);
+ RegisterProperty('ASDATE', 'TDATETIME', iptrw);
+ RegisterProperty('ASDATETIME', 'TDATETIME', iptrw);
+ RegisterProperty('ASFLOAT', 'DOUBLE', iptrw);
+ RegisterProperty('ASINTEGER', 'LONGINT', iptrw);
+ RegisterProperty('ASSMALLINT', 'LONGINT', iptrw);
+ RegisterProperty('ASMEMO', 'String', iptrw);
+ RegisterProperty('ASSTRING', 'String', iptrw);
+ RegisterProperty('ASTIME', 'TDATETIME', iptrw);
+ RegisterProperty('ASWORD', 'LONGINT', iptrw);
+ RegisterProperty('BOUND', 'BOOLEAN', iptrw);
+ RegisterProperty('ISNULL', 'BOOLEAN', iptr);
+ RegisterProperty('NATIVESTR', 'String', iptrw);
+ RegisterProperty('TEXT', 'String', iptrw);
+ RegisterProperty('DATATYPE', 'TFIELDTYPE', iptrw);
+{$IFDEF DELPHI6UP}
+ RegisterProperty('PRECISION', 'INTEGER', iptrw);
+ RegisterProperty('NUMERICSCALE', 'INTEGER', iptrw);
+ RegisterProperty('SIZE', 'INTEGER', iptrw);
+{$ENDIF}
+ RegisterProperty('NAME', 'String', iptrw);
+ RegisterProperty('PARAMTYPE', 'TPARAMTYPE', iptrw);
+ RegisterProperty('VALUE', 'VARIANT', iptrw);
+ end;
+end;
+
+procedure SIRegisterTGUIDFIELD(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TFIELD','TGUIDFIELD') do
+ begin
+ end;
+end;
+
+procedure SIRegisterTVARIANTFIELD(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TFIELD','TVARIANTFIELD') do
+ begin
+ end;
+end;
+
+procedure SIRegisterTREFERENCEFIELD(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TDATASETFIELD','TREFERENCEFIELD') do
+ begin
+ RegisterProperty('REFERENCETABLENAME', 'String', iptrw);
+ end;
+end;
+
+procedure SIRegisterTDATASETFIELD(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TOBJECTFIELD','TDATASETFIELD') do
+ begin
+ RegisterProperty('NESTEDDATASET', 'TDATASET', iptr);
+ RegisterProperty('INCLUDEOBJECTFIELD', 'BOOLEAN', iptrw);
+ end;
+end;
+
+procedure SIRegisterTARRAYFIELD(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TOBJECTFIELD','TARRAYFIELD') do
+ begin
+ end;
+end;
+
+procedure SIRegisterTADTFIELD(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TOBJECTFIELD','TADTFIELD') do
+ begin
+ end;
+end;
+
+procedure SIRegisterTOBJECTFIELD(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TFIELD','TOBJECTFIELD') do
+ begin
+ RegisterProperty('FIELDCOUNT', 'INTEGER', iptr);
+ RegisterProperty('FIELDS', 'TFIELDS', iptr);
+ RegisterProperty('FIELDVALUES', 'VARIANT INTEGER', iptrw);
+ RegisterProperty('UNNAMED', 'BOOLEAN', iptr);
+ RegisterProperty('OBJECTTYPE', 'String', iptrw);
+ end;
+end;
+
+procedure SIRegisterTGRAPHICFIELD(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TBLOBFIELD','TGRAPHICFIELD') do
+ begin
+ end;
+end;
+
+procedure SIRegisterTMEMOFIELD(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TBLOBFIELD','TMEMOFIELD') do
+ begin
+ end;
+end;
+
+procedure SIRegisterTBLOBFIELD(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TFIELD','TBLOBFIELD') do
+ begin
+ RegisterMethod('Procedure LOADFROMFILE( const FILENAME : String)');
+ RegisterMethod('Procedure LOADFROMSTREAM( STREAM : TSTREAM)');
+ RegisterMethod('Procedure SAVETOFILE( const FILENAME : String)');
+ RegisterMethod('Procedure SAVETOSTREAM( STREAM : TSTREAM)');
+ RegisterProperty('BLOBSIZE', 'INTEGER', iptr);
+ RegisterProperty('MODIFIED', 'BOOLEAN', iptrw);
+ RegisterProperty('VALUE', 'String', iptrw);
+ RegisterProperty('TRANSLITERATE', 'BOOLEAN', iptrw);
+ RegisterProperty('BLOBTYPE', 'TBLOBTYPE', iptrw);
+{$IFDEF DELPHI6UP}
+ RegisterProperty('GRAPHICHEADER', 'BOOLEAN', iptrw);
+{$ENDIF}
+ end;
+end;
+
+{$IFDEF DELPHI6UP}
+procedure SIRegisterTFMTBCDFIELD(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TNUMERICFIELD','TFMTBCDFIELD') do
+ begin
+ RegisterProperty('VALUE', 'TBCD', iptrw);
+ RegisterProperty('CURRENCY', 'BOOLEAN', iptrw);
+ RegisterProperty('MAXVALUE', 'String', iptrw);
+ RegisterProperty('MINVALUE', 'String', iptrw);
+ RegisterProperty('PRECISION', 'INTEGER', iptrw);
+ end;
+end;
+{$ENDIF}
+
+procedure SIRegisterTBCDFIELD(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TNUMERICFIELD','TBCDFIELD') do
+ begin
+ RegisterProperty('VALUE', 'CURRENCY', iptrw);
+ RegisterProperty('CURRENCY', 'BOOLEAN', iptrw);
+ RegisterProperty('MAXVALUE', 'CURRENCY', iptrw);
+ RegisterProperty('MINVALUE', 'CURRENCY', iptrw);
+ RegisterProperty('PRECISION', 'INTEGER', iptrw);
+ end;
+end;
+
+procedure SIRegisterTVARBYTESFIELD(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TBYTESFIELD','TVARBYTESFIELD') do
+ begin
+ end;
+end;
+
+procedure SIRegisterTBYTESFIELD(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TBINARYFIELD','TBYTESFIELD') do
+ begin
+ end;
+end;
+
+procedure SIRegisterTBINARYFIELD(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TFIELD','TBINARYFIELD') do
+ begin
+ end;
+end;
+
+procedure SIRegisterTTIMEFIELD(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TDATETIMEFIELD','TTIMEFIELD') do
+ begin
+ end;
+end;
+
+procedure SIRegisterTDATEFIELD(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TDATETIMEFIELD','TDATEFIELD') do
+ begin
+ end;
+end;
+
+procedure SIRegisterTDATETIMEFIELD(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TFIELD','TDATETIMEFIELD') do
+ begin
+ RegisterProperty('VALUE', 'TDATETIME', iptrw);
+ RegisterProperty('DISPLAYFORMAT', 'String', iptrw);
+ end;
+end;
+
+procedure SIRegisterTBOOLEANFIELD(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TFIELD','TBOOLEANFIELD') do
+ begin
+ RegisterProperty('VALUE', 'BOOLEAN', iptrw);
+ RegisterProperty('DISPLAYVALUES', 'String', iptrw);
+ end;
+end;
+
+procedure SIRegisterTCURRENCYFIELD(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TFLOATFIELD','TCURRENCYFIELD') do
+ begin
+ end;
+end;
+
+procedure SIRegisterTFLOATFIELD(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TNUMERICFIELD','TFLOATFIELD') do
+ begin
+ RegisterProperty('VALUE', 'DOUBLE', iptrw);
+ RegisterProperty('CURRENCY', 'BOOLEAN', iptrw);
+ RegisterProperty('MAXVALUE', 'DOUBLE', iptrw);
+ RegisterProperty('MINVALUE', 'DOUBLE', iptrw);
+ RegisterProperty('PRECISION', 'INTEGER', iptrw);
+ end;
+end;
+
+procedure SIRegisterTAUTOINCFIELD(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TINTEGERFIELD','TAUTOINCFIELD') do
+ begin
+ end;
+end;
+
+procedure SIRegisterTWORDFIELD(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TINTEGERFIELD','TWORDFIELD') do
+ begin
+ end;
+end;
+
+procedure SIRegisterTLARGEINTFIELD(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TNUMERICFIELD','TLARGEINTFIELD') do
+ begin
+ RegisterProperty('ASLARGEINT', 'LARGEINT', iptrw);
+ RegisterProperty('VALUE', 'LARGEINT', iptrw);
+ RegisterProperty('MAXVALUE', 'LARGEINT', iptrw);
+ RegisterProperty('MINVALUE', 'LARGEINT', iptrw);
+ end;
+end;
+
+procedure SIRegisterTSMALLINTFIELD(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TINTEGERFIELD','TSMALLINTFIELD') do
+ begin
+ end;
+end;
+
+procedure SIRegisterTINTEGERFIELD(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TNUMERICFIELD','TINTEGERFIELD') do
+ begin
+ RegisterProperty('VALUE', 'LONGINT', iptrw);
+ RegisterProperty('MAXVALUE', 'LONGINT', iptrw);
+ RegisterProperty('MINVALUE', 'LONGINT', iptrw);
+ end;
+end;
+
+procedure SIRegisterTNUMERICFIELD(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TFIELD','TNUMERICFIELD') do
+ begin
+ RegisterProperty('DISPLAYFORMAT', 'String', iptrw);
+ RegisterProperty('EDITFORMAT', 'String', iptrw);
+ end;
+end;
+
+procedure SIRegisterTWIDESTRINGFIELD(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TSTRINGFIELD','TWIDESTRINGFIELD') do
+ begin
+ RegisterProperty('VALUE', 'WIDESTRING', iptrw);
+ end;
+end;
+
+procedure SIRegisterTSTRINGFIELD(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TFIELD','TSTRINGFIELD') do
+ begin
+ RegisterProperty('VALUE', 'String', iptrw);
+ RegisterProperty('FIXEDCHAR', 'BOOLEAN', iptrw);
+ RegisterProperty('TRANSLITERATE', 'BOOLEAN', iptrw);
+ end;
+end;
+
+procedure SIRegisterTFIELD(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TCOMPONENT','TFIELD') do
+ begin
+//RegisterMethod('Procedure ASSIGNVALUE( const VALUE : TVARREC)');
+ RegisterMethod('Procedure CLEAR');
+ RegisterMethod('Procedure FOCUSCONTROL');
+// RegisterMethod('Function GETDATA( BUFFER : POINTER; NATIVEFORMAT : BOOLEAN) : BOOLEAN');
+ RegisterMethod('Function ISVALIDCHAR( INPUTCHAR : CHAR) : BOOLEAN');
+ RegisterMethod('Procedure REFRESHLOOKUPLIST');
+// RegisterMethod('Procedure SETDATA( BUFFER : POINTER; NATIVEFORMAT : BOOLEAN)');
+ RegisterMethod('Procedure SETFIELDTYPE( VALUE : TFIELDTYPE)');
+// RegisterMethod('Procedure VALIDATE( BUFFER : POINTER)');
+{$IFDEF DELPHI6UP}
+ RegisterProperty('ASBCD', 'TBCD', iptrw);
+{$ENDIF}
+ RegisterProperty('ASBOOLEAN', 'BOOLEAN', iptrw);
+ RegisterProperty('ASCURRENCY', 'CURRENCY', iptrw);
+ RegisterProperty('ASDATETIME', 'TDATETIME', iptrw);
+ RegisterProperty('ASFLOAT', 'DOUBLE', iptrw);
+ RegisterProperty('ASINTEGER', 'LONGINT', iptrw);
+ RegisterProperty('ASSTRING', 'String', iptrw);
+ RegisterProperty('ASVARIANT', 'VARIANT', iptrw);
+ RegisterProperty('ATTRIBUTESET', 'String', iptrw);
+ RegisterProperty('CALCULATED', 'BOOLEAN', iptrw);
+ RegisterProperty('CANMODIFY', 'BOOLEAN', iptr);
+ RegisterProperty('CURVALUE', 'VARIANT', iptr);
+ RegisterProperty('DATASET', 'TDATASET', iptrw);
+ RegisterProperty('DATASIZE', 'INTEGER', iptr);
+ RegisterProperty('DATATYPE', 'TFIELDTYPE', iptr);
+ RegisterProperty('DISPLAYNAME', 'String', iptr);
+ RegisterProperty('DISPLAYTEXT', 'String', iptr);
+ RegisterProperty('EDITMASK', 'TEDITMASK', iptrw);
+ RegisterProperty('EDITMASKPTR', 'TEDITMASK', iptr);
+ RegisterProperty('EDITMASK', 'String', iptrw);
+ RegisterProperty('EDITMASKPTR', 'String', iptr);
+ RegisterProperty('FIELDNO', 'INTEGER', iptr);
+ RegisterProperty('FULLNAME', 'String', iptr);
+ RegisterProperty('ISINDEXFIELD', 'BOOLEAN', iptr);
+ RegisterProperty('ISNULL', 'BOOLEAN', iptr);
+ RegisterProperty('LOOKUP', 'BOOLEAN', iptrw);
+ RegisterProperty('LOOKUPLIST', 'TLOOKUPLIST', iptr);
+ RegisterProperty('NEWVALUE', 'VARIANT', iptrw);
+ RegisterProperty('OFFSET', 'INTEGER', iptr);
+ RegisterProperty('OLDVALUE', 'VARIANT', iptr);
+ RegisterProperty('PARENTFIELD', 'TOBJECTFIELD', iptrw);
+ RegisterProperty('SIZE', 'INTEGER', iptrw);
+ RegisterProperty('TEXT', 'String', iptrw);
+ RegisterProperty('VALIDCHARS', 'TFIELDCHARS', iptrw);
+ RegisterProperty('VALUE', 'VARIANT', iptrw);
+ RegisterProperty('ALIGNMENT', 'TALIGNMENT', iptrw);
+ RegisterProperty('AUTOGENERATEVALUE', 'TAUTOREFRESHFLAG', iptrw);
+ RegisterProperty('CUSTOMCONSTRAINT', 'String', iptrw);
+ RegisterProperty('CONSTRAINTERRORMESSAGE', 'String', iptrw);
+ RegisterProperty('DEFAULTEXPRESSION', 'String', iptrw);
+ RegisterProperty('DISPLAYLABEL', 'String', iptrw);
+ RegisterProperty('DISPLAYWIDTH', 'INTEGER', iptrw);
+ RegisterProperty('FIELDKIND', 'TFIELDKIND', iptrw);
+ RegisterProperty('FIELDNAME', 'String', iptrw);
+ RegisterProperty('HASCONSTRAINTS', 'BOOLEAN', iptr);
+ RegisterProperty('INDEX', 'INTEGER', iptrw);
+ RegisterProperty('IMPORTEDCONSTRAINT', 'String', iptrw);
+ RegisterProperty('LOOKUPDATASET', 'TDATASET', iptrw);
+ RegisterProperty('LOOKUPKEYFIELDS', 'String', iptrw);
+ RegisterProperty('LOOKUPRESULTFIELD', 'String', iptrw);
+ RegisterProperty('KEYFIELDS', 'String', iptrw);
+ RegisterProperty('LOOKUPCACHE', 'BOOLEAN', iptrw);
+ RegisterProperty('ORIGIN', 'String', iptrw);
+ RegisterProperty('PROVIDERFLAGS', 'TPROVIDERFLAGS', iptrw);
+ RegisterProperty('READONLY', 'BOOLEAN', iptrw);
+ RegisterProperty('REQUIRED', 'BOOLEAN', iptrw);
+ RegisterProperty('VISIBLE', 'BOOLEAN', iptrw);
+ RegisterProperty('ONCHANGE', 'TFIELDNOTIFYEVENT', iptrw);
+ RegisterProperty('ONGETTEXT', 'TFIELDGETTEXTEVENT', iptrw);
+ RegisterProperty('ONSETTEXT', 'TFIELDSETTEXTEVENT', iptrw);
+ RegisterProperty('ONVALIDATE', 'TFIELDNOTIFYEVENT', iptrw);
+ end;
+end;
+
+procedure SIRegisterTLOOKUPLIST(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TOBJECT','TLOOKUPLIST') do
+ begin
+ RegisterMethod('Constructor CREATE');
+ RegisterMethod('Procedure ADD( const AKEY, AVALUE : VARIANT)');
+ RegisterMethod('Procedure CLEAR');
+ RegisterMethod('Function VALUEOFKEY( const AKEY : VARIANT) : VARIANT');
+ end;
+end;
+
+procedure SIRegisterTFIELDS(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TOBJECT','TFIELDS') do
+ begin
+ RegisterMethod('Constructor CREATE( ADATASET : TDATASET)');
+ RegisterMethod('Procedure ADD( FIELD : TFIELD)');
+ RegisterMethod('Procedure CHECKFIELDNAME( const FIELDNAME : String)');
+ RegisterMethod('Procedure CHECKFIELDNAMES( const FIELDNAMES : String)');
+ RegisterMethod('Procedure CLEAR');
+ RegisterMethod('Function FINDFIELD( const FIELDNAME : String) : TFIELD');
+ RegisterMethod('Function FIELDBYNAME( const FIELDNAME : String) : TFIELD');
+ RegisterMethod('Function FIELDBYNUMBER( FIELDNO : INTEGER) : TFIELD');
+ RegisterMethod('Procedure GETFIELDNAMES( LIST : TSTRINGS)');
+ RegisterMethod('Function INDEXOF( FIELD : TFIELD) : INTEGER');
+ RegisterMethod('Procedure REMOVE( FIELD : TFIELD)');
+ RegisterProperty('COUNT', 'INTEGER', iptr);
+ RegisterProperty('DATASET', 'TDATASET', iptr);
+ RegisterProperty('FIELDS', 'TFIELD INTEGER', iptrw);
+ end;
+end;
+
+procedure SIRegisterTFIELDLIST(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TFLATLIST','TFIELDLIST') do
+ begin
+ RegisterMethod('Function FIELDBYNAME( const NAME : String) : TFIELD');
+ RegisterMethod('Function FIND( const NAME : String) : TFIELD');
+ RegisterProperty('FIELDS', 'TFIELD INTEGER', iptr);
+ end;
+end;
+
+procedure SIRegisterTFIELDDEFLIST(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TFLATLIST','TFIELDDEFLIST') do
+ begin
+ RegisterMethod('Function FIELDBYNAME( const NAME : String) : TFIELDDEF');
+ RegisterMethod('Function FIND( const NAME : String) : TFIELDDEF');
+ RegisterProperty('FIELDDEFS', 'TFIELDDEF INTEGER', iptr);
+ end;
+end;
+
+procedure SIRegisterTFLATLIST(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TSTRINGLIST','TFLATLIST') do
+ begin
+ RegisterMethod('Constructor CREATE( ADATASET : TDATASET)');
+ RegisterMethod('Procedure UPDATE');
+ RegisterProperty('DATASET', 'TDATASET', iptr);
+ end;
+end;
+
+procedure SIRegisterTINDEXDEFS(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TDEFCOLLECTION','TINDEXDEFS') do
+ begin
+ RegisterMethod('Constructor CREATE( ADATASET : TDATASET)');
+ RegisterMethod('Function ADDINDEXDEF : TINDEXDEF');
+ RegisterMethod('Function FIND( const NAME : String) : TINDEXDEF');
+ RegisterMethod('Procedure UPDATE');
+ RegisterMethod('Function FINDINDEXFORFIELDS( const FIELDS : String) : TINDEXDEF');
+ RegisterMethod('Function GETINDEXFORFIELDS( const FIELDS : String; CASEINSENSITIVE : BOOLEAN) : TINDEXDEF');
+ RegisterMethod('Procedure ADD( const NAME, FIELDS : String; OPTIONS : TINDEXOPTIONS)');
+ RegisterProperty('ITEMS', 'TINDEXDEF INTEGER', iptrw);
+ end;
+end;
+
+procedure SIRegisterTINDEXDEF(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TNAMEDITEM','TINDEXDEF') do
+ begin
+ RegisterMethod('Constructor CREATE( OWNER : TINDEXDEFS; const NAME, FIELDS : String; OPTIONS : TINDEXOPTIONS)');
+ RegisterProperty('FIELDEXPRESSION', 'String', iptr);
+ RegisterProperty('CASEINSFIELDS', 'String', iptrw);
+ RegisterProperty('DESCFIELDS', 'String', iptrw);
+ RegisterProperty('EXPRESSION', 'String', iptrw);
+ RegisterProperty('FIELDS', 'String', iptrw);
+ RegisterProperty('OPTIONS', 'TINDEXOPTIONS', iptrw);
+ RegisterProperty('SOURCE', 'String', iptrw);
+ RegisterProperty('GROUPINGLEVEL', 'INTEGER', iptrw);
+ end;
+end;
+
+procedure SIRegisterTFIELDDEFS(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TDEFCOLLECTION','TFIELDDEFS') do
+ begin
+ RegisterMethod('Constructor CREATE( AOWNER : TPERSISTENT)');
+ RegisterMethod('Function ADDFIELDDEF : TFIELDDEF');
+ RegisterMethod('Function FIND( const NAME : String) : TFIELDDEF');
+ RegisterMethod('Procedure UPDATE');
+ RegisterMethod('Procedure ADD( const NAME : String; DATATYPE : TFIELDTYPE; SIZE : INTEGER; REQUIRED : BOOLEAN)');
+ RegisterProperty('HIDDENFIELDS', 'BOOLEAN', iptrw);
+ RegisterProperty('ITEMS', 'TFIELDDEF INTEGER', iptrw);
+ RegisterProperty('PARENTDEF', 'TFIELDDEF', iptr);
+ end;
+end;
+
+procedure SIRegisterTFIELDDEF(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TNAMEDITEM','TFIELDDEF') do
+ begin
+// RegisterMethod('Constructor CREATE( OWNER : TFIELDDEFS; const NAME : STRING; DATATYPE : TFIELDTYPE; SIZE : INTEGER; REQUIRED : BOOLEAN; FIELDNO : INTEGER)');
+ RegisterMethod('Function ADDCHILD : TFIELDDEF');
+ RegisterMethod('Function CREATEFIELD( OWNER : TCOMPONENT; PARENTFIELD : TOBJECTFIELD; const FIELDNAME : String; CREATECHILDREN : BOOLEAN) : TFIELD');
+ RegisterMethod('Function HASCHILDDEFS : BOOLEAN');
+ RegisterProperty('FIELDCLASS', 'TFIELDCLASS', iptr);
+ RegisterProperty('FIELDNO', 'INTEGER', iptrw);
+ RegisterProperty('INTERNALCALCFIELD', 'BOOLEAN', iptrw);
+ RegisterProperty('PARENTDEF', 'TFIELDDEF', iptr);
+ RegisterProperty('REQUIRED', 'BOOLEAN', iptrw);
+ RegisterProperty('ATTRIBUTES', 'TFIELDATTRIBUTES', iptrw);
+ RegisterProperty('CHILDDEFS', 'TFIELDDEFS', iptrw);
+ RegisterProperty('DATATYPE', 'TFIELDTYPE', iptrw);
+ RegisterProperty('PRECISION', 'INTEGER', iptrw);
+ RegisterProperty('SIZE', 'INTEGER', iptrw);
+ end;
+end;
+
+procedure SIRegisterTDEFCOLLECTION(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TOWNEDCOLLECTION','TDEFCOLLECTION') do
+ begin
+// RegisterMethod('Constructor CREATE( ADATASET : TDATASET; AOWNER : TPERSISTENT; ACLASS : TCOLLECTIONITEMCLASS)');
+ RegisterMethod('Function FIND( const ANAME : String) : TNAMEDITEM');
+ RegisterMethod('Procedure GETITEMNAMES( LIST : TSTRINGS)');
+ RegisterMethod('Function INDEXOF( const ANAME : String) : INTEGER');
+ RegisterProperty('DATASET', 'TDATASET', iptr);
+ RegisterProperty('UPDATED', 'BOOLEAN', iptrw);
+ end;
+end;
+
+procedure SIRegisterTNAMEDITEM(CL: TPSPascalCompiler);
+Begin
+With RegClassS(cl,'TCOLLECTIONITEM','TNAMEDITEM') do
+ begin
+ RegisterProperty('NAME', 'String', iptrw);
+ end;
+end;
+
+procedure SIRegister_DB(Cl: TPSPascalCompiler);
+Begin
+cl.AddTypeS('TFieldType', '(ftUnknown, ftString, ftSmallint, ftInteger, ftWord, ftBoolean, ftFloat, ftCurrency, ftBCD, ftDate, ftTime, ftDateTime,'+
+ 'ftBytes, ftVarBytes, ftAutoInc, ftBlob, ftMemo, ftGraphic, ftFmtMemo, ftParadoxOle, ftDBaseOle, ftTypedBinary, ftCursor, ftFixedChar, ftWideString,'+
+ 'ftLargeint, ftADT, ftArray, ftReference, ftDataSet, ftOraBlob, ftOraClob, ftVariant, ftInterface, ftIDispatch, ftGuid, ftTimeStamp, ftFMTBcd)');
+
+ CL.AddTypeS('TDataSetState', '(dsInactive, dsBrowse, dsEdit, dsInsert, dsSetKey, dsCalcFields, dsFilter, dsNewValue, dsOldValue, dsCurValue, dsBlockRead, dsInternalCalc, dsOpening)');
+
+cl.addTypeS('TLocateOption','(loCaseInsensitive, loPartialKey)');
+cl.addtypes('TLocateOptions','set of TLocateOption');
+cl.addtypes('TUpdateStatus','(usUnmodified, usModified, usInserted, usDeleted)');
+cl.addtypes('TUpdateStatusSet', 'set of TUpdateStatus');
+
+ cl.addTypeS('TPARAMTYPE', 'BYTE');
+RegClassS(cl,'TComponent','TDATASET');
+RegClassS(cl,'TComponent','TFIELD');
+RegClassS(cl,'TComponent','TFIELDDEFS');
+RegClassS(cl,'TComponent','TINDEXDEFS');
+RegClassS(cl, 'TComponent', 'TObjectField');
+RegClassS(cl, 'TComponent', 'TDataLink');
+RegClassS(cl, 'TComponent', 'TDataSource');
+RegClassS(cl, 'TComponent', 'TParam');
+
+SIRegisterTNAMEDITEM(Cl);
+Cl.addTypeS('TDEFUPDATEMETHOD', 'Procedure');
+SIRegisterTDEFCOLLECTION(Cl);
+cl.AddConstantN('FAHIDDENCOL','LONGINT').Value.tu32 := 1;
+cl.AddConstantN('FAREADONLY','LONGINT').Value.tu32 := 2;
+cl.AddConstantN('FAREQUIRED','LONGINT').Value.tu32 := 4;
+cl.AddConstantN('FALINK','LONGINT').Value.tu32 := 8;
+cl.AddConstantN('FAUNNAMED','LONGINT').Value.tu32 := 16;
+cl.AddConstantN('FAFIXED','LONGINT').Value.tu32 := 32;
+cl.addTypeS('TFIELDATTRIBUTES', 'BYTE');
+SIRegisterTFIELDDEF(Cl);
+SIRegisterTFIELDDEFS(Cl);
+cl.AddConstantN('IXPRIMARY','LONGINT').Value.tu32 := 1;
+cl.AddConstantN('IXUNIQUE','LONGINT').Value.tu32 := 2;
+cl.AddConstantN('IXDESCENDING','LONGINT').Value.tu32 := 4;
+cl.AddConstantN('IXCASEINSENSITIVE','LONGINT').Value.tu32 := 8;
+cl.AddConstantN('IXEXPRESSION','LONGINT').Value.tu32 := 16;
+cl.AddConstantN('IXNONMAINTAINED','LONGINT').Value.tu32 := 32;
+cl.addTypeS('TINDEXOPTIONS', 'BYTE');
+SIRegisterTINDEXDEF(Cl);
+SIRegisterTINDEXDEFS(Cl);
+SIRegisterTFLATLIST(Cl);
+SIRegisterTFIELDDEFLIST(Cl);
+SIRegisterTFIELDLIST(Cl);
+cl.AddConstantN('FKDATA','LONGINT').Value.tu32 := 1;
+cl.AddConstantN('FKCALCULATED','LONGINT').Value.tu32 := 2;
+cl.AddConstantN('FKLOOKUP','LONGINT').Value.tu32 := 4;
+cl.AddConstantN('FKINTERNALCALC','LONGINT').Value.tu32 := 8;
+cl.AddConstantN('FKAGGREGATE','LONGINT').Value.tu32 := 16;
+cl.addTypeS('TFIELDKINDS', 'BYTE');
+SIRegisterTFIELDS(Cl);
+cl.AddConstantN('PFINUPDATE','LONGINT').Value.tu32 := 1;
+cl.AddConstantN('PFINWHERE','LONGINT').Value.tu32 := 2;
+cl.AddConstantN('PFINKEY','LONGINT').Value.tu32 := 4;
+cl.AddConstantN('PFHIDDEN','LONGINT').Value.tu32 :=8;
+cl.addTypeS('TPROVIDERFLAGS', 'BYTE');
+cl.addTypeS('TFIELDNOTIFYEVENT', 'Procedure ( SENDER : TFIELD)');
+cl.addTypeS('TFIELDGETTEXTEVENT', 'Procedure ( SENDER : TFIELD; var TEXT : S'
+ +'TRING; DISPLAYTEXT : BOOLEAN)');
+cl.addTypeS('TFIELDSETTEXTEVENT', 'Procedure ( SENDER : TFIELD; const TEXT :'
+ +' String)');
+cl.addTypeS('TAUTOREFRESHFLAG', '( ARNONE, ARAUTOINC, ARDEFAULT )');
+SIRegisterTLOOKUPLIST(Cl);
+SIRegisterTFIELD(Cl);
+SIRegisterTSTRINGFIELD(Cl);
+SIRegisterTWIDESTRINGFIELD(Cl);
+SIRegisterTNUMERICFIELD(Cl);
+SIRegisterTINTEGERFIELD(Cl);
+SIRegisterTSMALLINTFIELD(Cl);
+cl.addTypeS('LARGEINT', 'INT64');
+SIRegisterTLARGEINTFIELD(Cl);
+SIRegisterTWORDFIELD(Cl);
+SIRegisterTAUTOINCFIELD(Cl);
+SIRegisterTFLOATFIELD(Cl);
+SIRegisterTCURRENCYFIELD(Cl);
+SIRegisterTBOOLEANFIELD(Cl);
+SIRegisterTDATETIMEFIELD(Cl);
+SIRegisterTDATEFIELD(Cl);
+SIRegisterTTIMEFIELD(Cl);
+SIRegisterTBINARYFIELD(Cl);
+SIRegisterTBYTESFIELD(Cl);
+SIRegisterTVARBYTESFIELD(Cl);
+SIRegisterTBCDFIELD(Cl);
+{$IFDEF DELPHI6UP}
+SIRegisterTFMTBCDFIELD(Cl);
+{$ENDIF}
+cl.addTypeS('TBLOBTYPE', 'BYTE');
+SIRegisterTBLOBFIELD(Cl);
+SIRegisterTMEMOFIELD(Cl);
+SIRegisterTGRAPHICFIELD(Cl);
+SIRegisterTOBJECTFIELD(Cl);
+SIRegisterTADTFIELD(Cl);
+SIRegisterTARRAYFIELD(Cl);
+SIRegisterTDATASETFIELD(Cl);
+SIRegisterTREFERENCEFIELD(Cl);
+SIRegisterTVARIANTFIELD(Cl);
+SIRegisterTGUIDFIELD(Cl);
+cl.addTypeS('TBLOBDATA', 'STRING');
+cl.AddConstantN('PTUNKNOWN','LONGINT').Value.tu32 := 1;
+cl.AddConstantN('PTINPUT','LONGINT').Value.tu32 := 2;
+cl.AddConstantN('PTOUTPUT','LONGINT').Value.tu32 := 4;
+cl.AddConstantN('PTINPUTOUTPUT','LONGINT').Value.tu32 := 8;
+cl.AddConstantN('PTRESULT','LONGINT').Value.tu32 := 16;
+RegClassS(cl,'TObject','TPARAMS');
+SIRegisterTPARAM(Cl);
+SIRegisterTPARAMS(Cl);
+cl.addTypeS('TDATAACTION', '( DAFAIL, DAABORT, DARETRY )');
+cl.addTypeS('TBLOBSTREAMMODE', '( BMREAD, BMWRITE, BMREADWRITE )');
+cl.addTypeS('TDATAOPERATION', 'Procedure');
+cl.addTypeS('TDATASETNOTIFYEVENT', 'Procedure ( DATASET : TDATASET)');
+cl.addTypeS('TDATASETERROREVENT', 'Procedure ( DATASET : TDATASET; E : TObject'
+ +'; var ACTION : TDATAACTION)');
+cl.addTypeS('TFILTERRECORDEVENT', 'Procedure ( DATASET : TDATASET; var ACCEP'
+ +'T : BOOLEAN)');
+SIRegisterTDATASET(Cl);
+end;
+
+{$IFDEF USEIMPORTER}
+initialization
+CIImporter.AddCallBack(@SIRegister_DB,PT_ClassImport);
+{$ENDIF}
+end.
diff --git a/Units/PascalScript/uPSC_buttons.pas b/Units/PascalScript/uPSC_buttons.pas
new file mode 100644
index 0000000..52c0873
--- /dev/null
+++ b/Units/PascalScript/uPSC_buttons.pas
@@ -0,0 +1,87 @@
+{ Compiletime Buttons support }
+unit uPSC_buttons;
+{$I PascalScript.inc}
+interface
+uses
+ uPSCompiler, uPSUtils;
+
+{
+ Will register files from:
+ Buttons
+
+ Requires
+ STD, classes, controls and graphics and StdCtrls
+}
+procedure SIRegister_Buttons_TypesAndConsts(Cl: TPSPascalCompiler);
+
+procedure SIRegisterTSPEEDBUTTON(Cl: TPSPascalCompiler);
+procedure SIRegisterTBITBTN(Cl: TPSPascalCompiler);
+
+procedure SIRegister_Buttons(Cl: TPSPascalCompiler);
+
+implementation
+
+procedure SIRegisterTSPEEDBUTTON(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TGRAPHICCONTROL'), 'TSPEEDBUTTON') do
+ begin
+ RegisterProperty('ALLOWALLUP', 'BOOLEAN', iptrw);
+ RegisterProperty('GROUPINDEX', 'INTEGER', iptrw);
+ RegisterProperty('DOWN', 'BOOLEAN', iptrw);
+ RegisterProperty('CAPTION', 'String', iptrw);
+ RegisterProperty('FONT', 'TFont', iptrw);
+ RegisterProperty('GLYPH', 'TBITMAP', iptrw);
+ RegisterProperty('LAYOUT', 'TBUTTONLAYOUT', iptrw);
+ RegisterProperty('MARGIN', 'INTEGER', iptrw);
+ RegisterProperty('NUMGLYPHS', 'BYTE', iptrw);
+ RegisterProperty('PARENTFONT', 'Boolean', iptrw);
+ RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
+ RegisterProperty('SPACING', 'INTEGER', iptrw);
+ RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw);
+ RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw);
+ RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw);
+ end;
+end;
+
+procedure SIRegisterTBITBTN(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TBUTTON'), 'TBITBTN') do
+ begin
+ RegisterProperty('GLYPH', 'TBITMAP', iptrw);
+ RegisterProperty('KIND', 'TBITBTNKIND', iptrw);
+ RegisterProperty('LAYOUT', 'TBUTTONLAYOUT', iptrw);
+ RegisterProperty('MARGIN', 'INTEGER', iptrw);
+ RegisterProperty('NUMGLYPHS', 'BYTE', iptrw);
+ RegisterProperty('STYLE', 'TBUTTONSTYLE', iptrw);
+ RegisterProperty('SPACING', 'INTEGER', iptrw);
+ end;
+end;
+
+
+
+procedure SIRegister_Buttons_TypesAndConsts(Cl: TPSPascalCompiler);
+begin
+ Cl.AddTypeS('TButtonLayout', '(blGlyphLeft, blGlyphRight, blGlyphTop, blGlyphBottom)');
+ Cl.AddTypeS('TButtonState', '(bsUp, bsDisabled, bsDown, bsExclusive)');
+ Cl.AddTypeS('TButtonStyle', '(bsAutoDetect, bsWin31, bsNew)');
+ Cl.AddTypeS('TBitBtnKind', '(bkCustom, bkOK, bkCancel, bkHelp, bkYes, bkNo, bkClose, bkAbort, bkRetry, bkIgnore, bkAll)');
+
+end;
+
+procedure SIRegister_Buttons(Cl: TPSPascalCompiler);
+begin
+ SIRegister_Buttons_TypesAndConsts(cl);
+ SIRegisterTSPEEDBUTTON(cl);
+ SIRegisterTBITBTN(cl);
+end;
+
+// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl)
+
+
+end.
+
+
+
+
diff --git a/Units/PascalScript/uPSC_classes.pas b/Units/PascalScript/uPSC_classes.pas
new file mode 100644
index 0000000..ff86334
--- /dev/null
+++ b/Units/PascalScript/uPSC_classes.pas
@@ -0,0 +1,320 @@
+{ Compiletime Classes support }
+unit uPSC_classes;
+
+{$I PascalScript.inc}
+interface
+uses
+ uPSCompiler, uPSUtils;
+
+{
+ Will register files from:
+ Classes (exception TPersistent and TComponent)
+
+ Register STD first
+
+}
+
+procedure SIRegister_Classes_TypesAndConsts(Cl: TPSPascalCompiler);
+
+procedure SIRegisterTStrings(cl: TPSPascalCompiler; Streams: Boolean);
+procedure SIRegisterTStringList(cl: TPSPascalCompiler);
+{$IFNDEF PS_MINIVCL}
+procedure SIRegisterTBITS(Cl: TPSPascalCompiler);
+{$ENDIF}
+procedure SIRegisterTSTREAM(Cl: TPSPascalCompiler);
+procedure SIRegisterTHANDLESTREAM(Cl: TPSPascalCompiler);
+{$IFNDEF PS_MINIVCL}
+procedure SIRegisterTMEMORYSTREAM(Cl: TPSPascalCompiler);
+{$ENDIF}
+procedure SIRegisterTFILESTREAM(Cl: TPSPascalCompiler);
+{$IFNDEF PS_MINIVCL}
+procedure SIRegisterTCUSTOMMEMORYSTREAM(Cl: TPSPascalCompiler);
+procedure SIRegisterTRESOURCESTREAM(Cl: TPSPascalCompiler);
+procedure SIRegisterTPARSER(Cl: TPSPascalCompiler);
+procedure SIRegisterTCOLLECTIONITEM(CL: TPSPascalCompiler);
+procedure SIRegisterTCOLLECTION(CL: TPSPascalCompiler);
+{$IFDEF DELPHI3UP}
+procedure SIRegisterTOWNEDCOLLECTION(CL: TPSPascalCompiler);
+{$ENDIF}
+{$ENDIF}
+
+procedure SIRegister_Classes(Cl: TPSPascalCompiler; Streams: Boolean{$IFDEF D4PLUS}=True{$ENDIF});
+
+implementation
+
+procedure SIRegisterTStrings(cl: TPSPascalCompiler; Streams: Boolean); // requires TPersistent
+begin
+ with Cl.AddClassN(cl.FindClass('TPersistent'), 'TStrings') do
+ begin
+ IsAbstract := True;
+ RegisterMethod('function Add(S: string): Integer;');
+ RegisterMethod('procedure Append(S: string);');
+ RegisterMethod('procedure AddStrings(Strings: TStrings);');
+ RegisterMethod('procedure Clear;');
+ RegisterMethod('procedure Delete(Index: Integer);');
+ RegisterMethod('function IndexOf(const S: string): Integer; ');
+ RegisterMethod('procedure Insert(Index: Integer; S: string); ');
+ RegisterProperty('Count', 'Integer', iptR);
+ RegisterProperty('Text', 'String', iptrw);
+ RegisterProperty('CommaText', 'String', iptrw);
+ if Streams then
+ begin
+ RegisterMethod('procedure LoadFromFile(FileName: string); ');
+ RegisterMethod('procedure SaveToFile(FileName: string); ');
+ end;
+ RegisterProperty('Strings', 'String Integer', iptRW);
+ SetDefaultPropery('Strings');
+ RegisterProperty('Objects', 'TObject Integer', iptRW);
+
+ {$IFNDEF PS_MINIVCL}
+ RegisterMethod('procedure BeginUpdate;');
+ RegisterMethod('procedure EndUpdate;');
+ RegisterMethod('function Equals(Strings: TStrings): Boolean;');
+ RegisterMethod('procedure Exchange(Index1, Index2: Integer);');
+ RegisterMethod('function IndexOfName(Name: string): Integer;');
+ if Streams then
+ RegisterMethod('procedure LoadFromStream(Stream: TStream); ');
+ RegisterMethod('procedure Move(CurIndex, NewIndex: Integer); ');
+ if Streams then
+ RegisterMethod('procedure SaveToStream(Stream: TStream); ');
+ RegisterMethod('procedure SetText(Text: PChar); ');
+ RegisterProperty('Names', 'String Integer', iptr);
+ RegisterProperty('Values', 'String String', iptRW);
+ RegisterMethod('function AddObject(S:String;AObject:TObject):integer');
+ RegisterMethod('function GetText:PChar');
+ RegisterMethod('function IndexofObject(AObject:tObject):Integer');
+ RegisterMethod('procedure InsertObject(Index:Integer;S:String;AObject:TObject)');
+ {$ENDIF}
+ end;
+end;
+
+procedure SIRegisterTSTRINGLIST(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TStrings'), 'TStringList') do
+ begin
+ RegisterMethod('function Find(S:String;var Index:Integer):Boolean');
+ RegisterMethod('procedure Sort');
+ RegisterProperty('Duplicates', 'TDuplicates', iptrw);
+ RegisterProperty('Sorted', 'Boolean', iptrw);
+ RegisterProperty('OnChange', 'TNotifyEvent', iptrw);
+ RegisterProperty('OnChanging', 'TNotifyEvent', iptrw);
+ end;
+end;
+
+{$IFNDEF PS_MINIVCL}
+procedure SIRegisterTBITS(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TObject'), 'TBits') do
+ begin
+ RegisterMethod('function OpenBit:Integer');
+ RegisterProperty('Bits', 'Boolean Integer', iptrw);
+ RegisterProperty('Size', 'Integer', iptrw);
+ end;
+end;
+{$ENDIF}
+
+procedure SIRegisterTSTREAM(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TOBJECT'), 'TStream') do
+ begin
+ IsAbstract := True;
+ RegisterMethod('function Read(Buffer:String;Count:LongInt):LongInt');
+ RegisterMethod('function Write(Buffer:String;Count:LongInt):LongInt');
+ RegisterMethod('function Seek(Offset:LongInt;Origin:Word):LongInt');
+ RegisterMethod('procedure ReadBuffer(Buffer:String;Count:LongInt)');
+ RegisterMethod('procedure WriteBuffer(Buffer:String;Count:LongInt)');
+ {$IFDEF DELPHI4UP}
+ RegisterMethod('function CopyFrom(Source:TStream;Count:Int64):LongInt');
+ {$ELSE}
+ RegisterMethod('function CopyFrom(Source:TStream;Count:Integer):LongInt');
+ {$ENDIF}
+ RegisterProperty('Position', 'LongInt', iptrw);
+ RegisterProperty('Size', 'LongInt', iptrw);
+ end;
+end;
+
+procedure SIRegisterTHANDLESTREAM(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TSTREAM'), 'THandleStream') do
+ begin
+ RegisterMethod('constructor Create(AHandle:Integer)');
+ RegisterProperty('Handle', 'Integer', iptr);
+ end;
+end;
+
+{$IFNDEF PS_MINIVCL}
+procedure SIRegisterTMEMORYSTREAM(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TCUSTOMMEMORYSTREAM'), 'TMemoryStream') do
+ begin
+ RegisterMethod('procedure Clear');
+ RegisterMethod('procedure LoadFromStream(Stream:TStream)');
+ RegisterMethod('procedure LoadFromFile(FileName:String)');
+ RegisterMethod('procedure SetSize(NewSize:LongInt)');
+ end;
+end;
+{$ENDIF}
+
+procedure SIRegisterTFILESTREAM(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('THandleStream'), 'TFileStream') do
+ begin
+ RegisterMethod('constructor Create(FileName:String;Mode:Word)');
+ end;
+end;
+
+{$IFNDEF PS_MINIVCL}
+procedure SIRegisterTCUSTOMMEMORYSTREAM(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TSTREAM'), 'TCustomMemoryStream') do
+ begin
+ IsAbstract := True;
+ RegisterMethod('procedure SaveToStream(Stream:TStream)');
+ RegisterMethod('procedure SaveToFile(FileName:String)');
+ end;
+end;
+
+procedure SIRegisterTRESOURCESTREAM(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TCUSTOMMEMORYSTREAM'), 'TResourceStream') do
+ begin
+ RegisterMethod('constructor Create(Instance:THandle;ResName:String;ResType:PChar)');
+ RegisterMethod('constructor CreateFromId(Instance:THandle;ResId:Integer;ResType:PChar)');
+ end;
+end;
+
+procedure SIRegisterTPARSER(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TOBJECT'), 'TParser') do
+ begin
+ RegisterMethod('constructor Create(Stream:TStream)');
+ RegisterMethod('procedure CheckToken(t:char)');
+ RegisterMethod('procedure CheckTokenSymbol(s:string)');
+ RegisterMethod('procedure Error(Ident:Integer)');
+ RegisterMethod('procedure ErrorStr(Message:String)');
+ RegisterMethod('procedure HexToBinary(Stream:TStream)');
+ RegisterMethod('function NextToken:Char');
+ RegisterMethod('function SourcePos:LongInt');
+ RegisterMethod('function TokenComponentIdent:String');
+ RegisterMethod('function TokenFloat:Extended');
+ RegisterMethod('function TokenInt:LongInt');
+ RegisterMethod('function TokenString:String');
+ RegisterMethod('function TokenSymbolIs(S:String):Boolean');
+ RegisterProperty('SourceLine', 'Integer', iptr);
+ RegisterProperty('Token', 'Char', iptr);
+ end;
+end;
+
+procedure SIRegisterTCOLLECTIONITEM(CL: TPSPascalCompiler);
+Begin
+ if cl.FindClass('TCOLLECTION') = nil then cl.AddClassN(cl.FindClass('TPERSISTENT'), 'TCollection');
+ With cl.AddClassN(cl.FindClass('TPERSISTENT'),'TCollectionItem') do
+ begin
+ RegisterMethod('Constructor Create( Collection : TCollection)');
+ RegisterProperty('Collection', 'TCollection', iptrw);
+{$IFDEF DELPHI3UP} RegisterProperty('Id', 'Integer', iptr); {$ENDIF}
+ RegisterProperty('Index', 'Integer', iptrw);
+{$IFDEF DELPHI3UP} RegisterProperty('DisplayName', 'String', iptrw); {$ENDIF}
+ end;
+end;
+
+procedure SIRegisterTCOLLECTION(CL: TPSPascalCompiler);
+var
+ cr: TPSCompileTimeClass;
+Begin
+ cr := CL.FindClass('TCOLLECTION');
+ if cr = nil then cr := cl.AddClassN(cl.FindClass('TPERSISTENT'), 'TCollection');
+With cr do
+ begin
+// RegisterMethod('constructor Create( ItemClass : TCollectionItemClass)');
+{$IFDEF DELPHI3UP} RegisterMethod('function Owner : TPersistent'); {$ENDIF}
+ RegisterMethod('function Add : TCollectionItem');
+ RegisterMethod('procedure BeginUpdate');
+ RegisterMethod('procedure Clear');
+{$IFDEF DELPHI5UP} RegisterMethod('procedure Delete( Index : Integer)'); {$ENDIF}
+ RegisterMethod('procedure EndUpdate');
+{$IFDEF DELPHI3UP} RegisterMethod('function FindItemId( Id : Integer) : TCollectionItem'); {$ENDIF}
+{$IFDEF DELPHI3UP} RegisterMethod('function Insert( Index : Integer) : TCollectionItem'); {$ENDIF}
+ RegisterProperty('Count', 'Integer', iptr);
+{$IFDEF DELPHI3UP} RegisterProperty('ItemClass', 'TCollectionItemClass', iptr); {$ENDIF}
+ RegisterProperty('Items', 'TCollectionItem Integer', iptrw);
+ end;
+end;
+
+{$IFDEF DELPHI3UP}
+procedure SIRegisterTOWNEDCOLLECTION(CL: TPSPascalCompiler);
+Begin
+With Cl.AddClassN(cl.FindClass('TCOLLECTION'),'TOwnedCollection') do
+ begin
+// RegisterMethod('Constructor CREATE( AOWNER : TPERSISTENT; ITEMCLASS : TCOLLECTIONITEMCLASS)');
+ end;
+end;
+{$ENDIF}
+{$ENDIF}
+
+procedure SIRegister_Classes_TypesAndConsts(Cl: TPSPascalCompiler);
+begin
+ cl.AddConstantN('soFromBeginning', 'Longint').Value.ts32 := 0;
+ cl.AddConstantN('soFromCurrent', 'Longint').Value.ts32 := 1;
+ cl.AddConstantN('soFromEnd', 'Longint').Value.ts32 := 2;
+ cl.AddConstantN('toEOF', 'Char').SetString(#0);
+ cl.AddConstantN('toSymbol', 'Char').SetString(#1);
+ cl.AddConstantN('toString', 'Char').SetString(#2);
+ cl.AddConstantN('toInteger', 'Char').SetString(#3);
+ cl.AddConstantN('toFloat', 'Char').SetString(#4);
+ cl.AddConstantN('fmCreate', 'Longint').Value.ts32 := $FFFF;
+ cl.AddConstantN('fmOpenRead', 'Longint').Value.ts32 := 0;
+ cl.AddConstantN('fmOpenWrite', 'Longint').Value.ts32 := 1;
+ cl.AddConstantN('fmOpenReadWrite', 'Longint').Value.ts32 := 2;
+ cl.AddConstantN('fmShareCompat', 'Longint').Value.ts32 := 0;
+ cl.AddConstantN('fmShareExclusive', 'Longint').Value.ts32 := $10;
+ cl.AddConstantN('fmShareDenyWrite', 'Longint').Value.ts32 := $20;
+ cl.AddConstantN('fmShareDenyRead', 'Longint').Value.ts32 := $30;
+ cl.AddConstantN('fmShareDenyNone', 'Longint').Value.ts32 := $40;
+ cl.AddConstantN('SecsPerDay', 'Longint').Value.ts32 := 86400;
+ cl.AddConstantN('MSecPerDay', 'Longint').Value.ts32 := 86400000;
+ cl.AddConstantN('DateDelta', 'Longint').Value.ts32 := 693594;
+ cl.AddTypeS('TAlignment', '(taLeftJustify, taRightJustify, taCenter)');
+ cl.AddTypeS('THelpEvent', 'function (Command: Word; Data: Longint; var CallHelp: Boolean): Boolean');
+ cl.AddTypeS('TGetStrProc', 'procedure(const S: string)');
+ cl.AddTypeS('TDuplicates', '(dupIgnore, dupAccept, dupError)');
+ cl.AddTypeS('TOperation', '(opInsert, opRemove)');
+ cl.AddTypeS('THANDLE', 'Longint');
+
+ cl.AddTypeS('TNotifyEvent', 'procedure (Sender: TObject)');
+end;
+
+procedure SIRegister_Classes(Cl: TPSPascalCompiler; Streams: Boolean);
+begin
+ SIRegister_Classes_TypesAndConsts(Cl);
+ if Streams then
+ SIRegisterTSTREAM(Cl);
+ SIRegisterTStrings(cl, Streams);
+ SIRegisterTStringList(cl);
+ {$IFNDEF PS_MINIVCL}
+ SIRegisterTBITS(cl);
+ {$ENDIF}
+ if Streams then
+ begin
+ SIRegisterTHANDLESTREAM(Cl);
+ SIRegisterTFILESTREAM(Cl);
+ {$IFNDEF PS_MINIVCL}
+ SIRegisterTCUSTOMMEMORYSTREAM(Cl);
+ SIRegisterTMEMORYSTREAM(Cl);
+ SIRegisterTRESOURCESTREAM(Cl);
+ {$ENDIF}
+ end;
+ {$IFNDEF PS_MINIVCL}
+ SIRegisterTPARSER(Cl);
+ SIRegisterTCOLLECTIONITEM(Cl);
+ SIRegisterTCOLLECTION(Cl);
+ {$IFDEF DELPHI3UP}
+ SIRegisterTOWNEDCOLLECTION(Cl);
+ {$ENDIF}
+ {$ENDIF}
+end;
+
+// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl)
+
+
+end.
diff --git a/Units/PascalScript/uPSC_comobj.pas b/Units/PascalScript/uPSC_comobj.pas
new file mode 100644
index 0000000..16dd254
--- /dev/null
+++ b/Units/PascalScript/uPSC_comobj.pas
@@ -0,0 +1,28 @@
+{ compiletime ComObj support }
+unit uPSC_comobj;
+
+{$I PascalScript.inc}
+interface
+uses
+ uPSCompiler, uPSUtils;
+
+{
+
+Will register:
+
+function CreateOleObject(const ClassName: String): IDispatch;
+function GetActiveOleObject(const ClassName: String): IDispatch;
+
+}
+
+procedure SIRegister_ComObj(cl: TPSPascalCompiler);
+
+implementation
+
+procedure SIRegister_ComObj(cl: TPSPascalCompiler);
+begin
+ cl.AddDelphiFunction('function CreateOleObject(const ClassName: String): IDispatch;');
+ cl.AddDelphiFunction('function GetActiveOleObject(const ClassName: String): IDispatch;');
+end;
+
+end.
diff --git a/Units/PascalScript/uPSC_controls.pas b/Units/PascalScript/uPSC_controls.pas
new file mode 100644
index 0000000..14d734b
--- /dev/null
+++ b/Units/PascalScript/uPSC_controls.pas
@@ -0,0 +1,236 @@
+{ Compiletime Controls support }
+unit uPSC_controls;
+{$I PascalScript.inc}
+interface
+uses
+ uPSCompiler, uPSUtils;
+
+{
+ Will register files from:
+ Controls
+
+ Register the STD, Classes (at least the types&consts) and Graphics libraries first
+
+}
+
+procedure SIRegister_Controls_TypesAndConsts(Cl: TPSPascalCompiler);
+
+procedure SIRegisterTControl(Cl: TPSPascalCompiler);
+procedure SIRegisterTWinControl(Cl: TPSPascalCompiler);
+procedure SIRegisterTGraphicControl(cl: TPSPascalCompiler);
+procedure SIRegisterTCustomControl(cl: TPSPascalCompiler);
+procedure SIRegisterTDragObject(cl: TPSPascalCompiler);
+
+procedure SIRegister_Controls(Cl: TPSPascalCompiler);
+
+
+implementation
+
+procedure SIRegisterTControl(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TComponent'), 'TCONTROL') do
+ begin
+ RegisterMethod('constructor Create(AOwner: TComponent);');
+ RegisterMethod('procedure BringToFront;');
+ RegisterMethod('procedure Hide;');
+ RegisterMethod('procedure Invalidate;virtual;');
+ RegisterMethod('procedure refresh;');
+ RegisterMethod('procedure Repaint;virtual;');
+ RegisterMethod('procedure SendToBack;');
+ RegisterMethod('procedure Show;');
+ RegisterMethod('procedure Update;virtual;');
+ RegisterMethod('procedure SetBounds(x,y,w,h: Integer);virtual;');
+ RegisterProperty('Left', 'Integer', iptRW);
+ RegisterProperty('Top', 'Integer', iptRW);
+ RegisterProperty('Width', 'Integer', iptRW);
+ RegisterProperty('Height', 'Integer', iptRW);
+ RegisterProperty('Hint', 'String', iptRW);
+ RegisterProperty('Align', 'TAlign', iptRW);
+ RegisterProperty('ClientHeight', 'Longint', iptRW);
+ RegisterProperty('ClientWidth', 'Longint', iptRW);
+ RegisterProperty('ShowHint', 'Boolean', iptRW);
+ RegisterProperty('Visible', 'Boolean', iptRW);
+ RegisterProperty('ENABLED', 'BOOLEAN', iptrw);
+ RegisterProperty('CURSOR', 'TCURSOR', iptrw);
+
+ {$IFNDEF PS_MINIVCL}
+ RegisterMethod('function Dragging: Boolean;');
+ RegisterMethod('function HasParent: Boolean');
+ RegisterMethod('procedure BEGINDRAG(IMMEDIATE:BOOLEAN)');
+ RegisterMethod('function CLIENTTOSCREEN(POINT:TPOINT):TPOINT');
+ RegisterMethod('procedure ENDDRAG(DROP:BOOLEAN)');
+ {$IFNDEF CLX}
+ RegisterMethod('function GETTEXTBUF(BUFFER:PCHAR;BUFSIZE:INTEGER):INTEGER');
+ RegisterMethod('function GETTEXTLEN:INTEGER');
+ RegisterMethod('procedure SETTEXTBUF(BUFFER:PCHAR)');
+ RegisterMethod('function PERFORM(MSG:CARDINAL;WPARAM,LPARAM:LONGINT):LONGINT');
+ {$ENDIF}
+ RegisterMethod('function SCREENTOCLIENT(POINT:TPOINT):TPOINT');
+ {$ENDIF}
+ end;
+end;
+
+procedure SIRegisterTWinControl(Cl: TPSPascalCompiler); // requires TControl
+begin
+ with Cl.AddClassN(cl.FindClass('TControl'), 'TWINCONTROL') do
+ begin
+
+ with Cl.FindClass('TControl') do
+ begin
+ RegisterProperty('Parent', 'TWinControl', iptRW);
+ end;
+
+ {$IFNDEF CLX}
+ RegisterProperty('Handle', 'Longint', iptR);
+ {$ENDIF}
+ RegisterProperty('Showing', 'Boolean', iptR);
+ RegisterProperty('TabOrder', 'Integer', iptRW);
+ RegisterProperty('TabStop', 'Boolean', iptRW);
+ RegisterMethod('function CANFOCUS:BOOLEAN');
+ RegisterMethod('function FOCUSED:BOOLEAN');
+ RegisterProperty('CONTROLS', 'TCONTROL INTEGER', iptr);
+ RegisterProperty('CONTROLCOUNT', 'INTEGER', iptr);
+
+ {$IFNDEF PS_MINIVCL}
+ RegisterMethod('function HandleAllocated: Boolean;');
+ RegisterMethod('procedure HandleNeeded;');
+ RegisterMethod('procedure EnableAlign;');
+ RegisterMethod('procedure RemoveControl(AControl: TControl);');
+ RegisterMethod('procedure InsertControl(AControl: TControl);');
+ RegisterMethod('procedure Realign;');
+ RegisterMethod('procedure ScaleBy(M, D: Integer);');
+ RegisterMethod('procedure ScrollBy(DeltaX, DeltaY: Integer);');
+ RegisterMethod('procedure SetFocus; virtual;');
+ {$IFNDEF CLX}
+ RegisterMethod('procedure PAINTTO(DC:Longint;X,Y:INTEGER)');
+ {$ENDIF}
+
+ RegisterMethod('function CONTAINSCONTROL(CONTROL:TCONTROL):BOOLEAN');
+ RegisterMethod('procedure DISABLEALIGN');
+ RegisterMethod('procedure UPDATECONTROLSTATE');
+
+ RegisterProperty('BRUSH', 'TBRUSH', iptr);
+ RegisterProperty('HELPCONTEXT', 'LONGINT', iptrw);
+ {$ENDIF}
+ end;
+end;
+procedure SIRegisterTGraphicControl(cl: TPSPascalCompiler); // requires TControl
+begin
+ Cl.AddClassN(cl.FindClass('TControl'), 'TGRAPHICCONTROL');
+end;
+
+procedure SIRegisterTCustomControl(cl: TPSPascalCompiler); // requires TWinControl
+begin
+ Cl.AddClassN(cl.FindClass('TWinControl'), 'TCUSTOMCONTROL');
+end;
+
+procedure SIRegister_Controls_TypesAndConsts(Cl: TPSPascalCompiler);
+begin
+{$IFNDEF FPC}
+ Cl.addTypeS('TEShiftState','(ssShift, ssAlt, ssCtrl, ssLeft, ssRight, ssMiddle, ssDouble)');
+ {$ELSE}
+ Cl.addTypeS('TEShiftState','(ssShift, ssAlt, ssCtrl, ssLeft, ssRight, ssMiddle, ssDouble,' +
+ 'ssMeta, ssSuper, ssHyper, ssAltGr, ssCaps, ssNum,ssScroll,ssTriple,ssQuad)');
+ {$ENDIF}
+ Cl.addTypeS('TShiftState','set of TEShiftState');
+ cl.AddTypeS('TMouseButton', '(mbLeft, mbRight, mbMiddle)');
+ cl.AddTypeS('TDragMode', '(dmManual, dmAutomatic)');
+ cl.AddTypeS('TDragState', '(dsDragEnter, dsDragLeave, dsDragMove)');
+ cl.AddTypeS('TDragKind', '(dkDrag, dkDock)');
+ cl.AddTypeS('TMouseEvent', 'procedure (Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);');
+ cl.AddTypeS('TMouseMoveEvent', 'procedure(Sender: TObject; Shift: TShiftState; X, Y: Integer);');
+ cl.AddTypeS('TKeyEvent', 'procedure (Sender: TObject; var Key: Word; Shift: TShiftState);');
+ cl.AddTypeS('TKeyPressEvent', 'procedure(Sender: TObject; var Key: Char);');
+ cl.AddTypeS('TDragOverEvent', 'procedure(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean)');
+ cl.AddTypeS('TDragDropEvent', 'procedure(Sender, Source: TObject;X, Y: Integer)');
+ cl.AddTypeS('HWND', 'Longint');
+
+ cl.AddTypeS('TEndDragEvent', 'procedure(Sender, Target: TObject; X, Y: Integer)');
+
+ cl.addTypeS('TAlign', '(alNone, alTop, alBottom, alLeft, alRight, alClient)');
+
+ cl.addTypeS('TAnchorKind', '(akTop, akLeft, akRight, akBottom)');
+ cl.addTypeS('TAnchors','set of TAnchorKind');
+ cl.AddTypeS('TModalResult', 'Integer');
+ cl.AddTypeS('TCursor', 'Integer');
+ cl.AddTypeS('TPoint', 'record x,y: Longint; end;');
+
+ cl.AddConstantN('mrNone', 'Integer').Value.ts32 := 0;
+ cl.AddConstantN('mrOk', 'Integer').Value.ts32 := 1;
+ cl.AddConstantN('mrCancel', 'Integer').Value.ts32 := 2;
+ cl.AddConstantN('mrAbort', 'Integer').Value.ts32 := 3;
+ cl.AddConstantN('mrRetry', 'Integer').Value.ts32 := 4;
+ cl.AddConstantN('mrIgnore', 'Integer').Value.ts32 := 5;
+ cl.AddConstantN('mrYes', 'Integer').Value.ts32 := 6;
+ cl.AddConstantN('mrNo', 'Integer').Value.ts32 := 7;
+ cl.AddConstantN('mrAll', 'Integer').Value.ts32 := 8;
+ cl.AddConstantN('mrNoToAll', 'Integer').Value.ts32 := 9;
+ cl.AddConstantN('mrYesToAll', 'Integer').Value.ts32 := 10;
+ cl.AddConstantN('crDefault', 'Integer').Value.ts32 := 0;
+ cl.AddConstantN('crNone', 'Integer').Value.ts32 := -1;
+ cl.AddConstantN('crArrow', 'Integer').Value.ts32 := -2;
+ cl.AddConstantN('crCross', 'Integer').Value.ts32 := -3;
+ cl.AddConstantN('crIBeam', 'Integer').Value.ts32 := -4;
+ cl.AddConstantN('crSizeNESW', 'Integer').Value.ts32 := -6;
+ cl.AddConstantN('crSizeNS', 'Integer').Value.ts32 := -7;
+ cl.AddConstantN('crSizeNWSE', 'Integer').Value.ts32 := -8;
+ cl.AddConstantN('crSizeWE', 'Integer').Value.ts32 := -9;
+ cl.AddConstantN('crUpArrow', 'Integer').Value.ts32 := -10;
+ cl.AddConstantN('crHourGlass', 'Integer').Value.ts32 := -11;
+ cl.AddConstantN('crDrag', 'Integer').Value.ts32 := -12;
+ cl.AddConstantN('crNoDrop', 'Integer').Value.ts32 := -13;
+ cl.AddConstantN('crHSplit', 'Integer').Value.ts32 := -14;
+ cl.AddConstantN('crVSplit', 'Integer').Value.ts32 := -15;
+ cl.AddConstantN('crMultiDrag', 'Integer').Value.ts32 := -16;
+ cl.AddConstantN('crSQLWait', 'Integer').Value.ts32 := -17;
+ cl.AddConstantN('crNo', 'Integer').Value.ts32 := -18;
+ cl.AddConstantN('crAppStart', 'Integer').Value.ts32 := -19;
+ cl.AddConstantN('crHelp', 'Integer').Value.ts32 := -20;
+{$IFDEF DELPHI3UP}
+ cl.AddConstantN('crHandPoint', 'Integer').Value.ts32 := -21;
+{$ENDIF}
+{$IFDEF DELPHI4UP}
+ cl.AddConstantN('crSizeAll', 'Integer').Value.ts32 := -22;
+{$ENDIF}
+end;
+
+procedure SIRegisterTDragObject(cl: TPSPascalCompiler);
+begin
+ with CL.AddClassN(CL.FindClass('TObject'),'TDragObject') do
+ begin
+{$IFNDEF PS_MINIVCL}
+{$IFDEF DELPHI4UP}
+ RegisterMethod('Procedure Assign( Source : TDragObject)');
+{$ENDIF}
+{$IFNDEF FPC}
+ RegisterMethod('Function GetName : String');
+ RegisterMethod('Function Instance : Longint');
+{$ENDIF}
+ RegisterMethod('Procedure HideDragImage');
+ RegisterMethod('Procedure ShowDragImage');
+{$IFDEF DELPHI4UP}
+ RegisterProperty('Cancelling', 'Boolean', iptrw);
+ RegisterProperty('DragHandle', 'Longint', iptrw);
+ RegisterProperty('DragPos', 'TPoint', iptrw);
+ RegisterProperty('DragTargetPos', 'TPoint', iptrw);
+ RegisterProperty('MouseDeltaX', 'Double', iptr);
+ RegisterProperty('MouseDeltaY', 'Double', iptr);
+{$ENDIF}
+{$ENDIF}
+ end;
+ Cl.AddTypeS('TStartDragEvent', 'procedure (Sender: TObject; var DragObject: TDragObject)');
+end;
+
+procedure SIRegister_Controls(Cl: TPSPascalCompiler);
+begin
+ SIRegister_Controls_TypesAndConsts(cl);
+ SIRegisterTDragObject(cl);
+ SIRegisterTControl(Cl);
+ SIRegisterTWinControl(Cl);
+ SIRegisterTGraphicControl(cl);
+ SIRegisterTCustomControl(cl);
+end;
+
+// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl)
+
+end.
diff --git a/Units/PascalScript/uPSC_dateutils.pas b/Units/PascalScript/uPSC_dateutils.pas
new file mode 100644
index 0000000..f6213c7
--- /dev/null
+++ b/Units/PascalScript/uPSC_dateutils.pas
@@ -0,0 +1,34 @@
+{ Compile time Date Time library }
+unit uPSC_dateutils;
+
+interface
+uses
+ SysUtils, uPSCompiler, uPSUtils;
+
+
+procedure RegisterDateTimeLibrary_C(S: TPSPascalCompiler);
+
+implementation
+
+procedure RegisterDatetimeLibrary_C(S: TPSPascalCompiler);
+begin
+ s.AddType('TDateTime', btDouble).ExportName := True;
+ s.AddDelphiFunction('function EncodeDate(Year, Month, Day: Word): TDateTime;');
+ s.AddDelphiFunction('function EncodeTime(Hour, Min, Sec, MSec: Word): TDateTime;');
+ s.AddDelphiFunction('function TryEncodeDate(Year, Month, Day: Word; var Date: TDateTime): Boolean;');
+ s.AddDelphiFunction('function TryEncodeTime(Hour, Min, Sec, MSec: Word; var Time: TDateTime): Boolean;');
+ s.AddDelphiFunction('procedure DecodeDate(const DateTime: TDateTime; var Year, Month, Day: Word);');
+ s.AddDelphiFunction('procedure DecodeTime(const DateTime: TDateTime; var Hour, Min, Sec, MSec: Word);');
+ s.AddDelphiFunction('function DayOfWeek(const DateTime: TDateTime): Word;');
+ s.AddDelphiFunction('function Date: TDateTime;');
+ s.AddDelphiFunction('function Time: TDateTime;');
+ s.AddDelphiFunction('function Now: TDateTime;');
+ s.AddDelphiFunction('function DateTimeToUnix(D: TDateTime): Int64;');
+ s.AddDelphiFunction('function UnixToDateTime(U: Int64): TDateTime;');
+
+ s.AddDelphiFunction('function DateToStr(D: TDateTime): String;');
+ s.AddDelphiFunction('function StrToDate(const s: String): TDateTime;');
+ s.AddDelphiFunction('function FormatDateTime(const fmt: String; D: TDateTime): String;');
+end;
+
+end.
diff --git a/Units/PascalScript/uPSC_dll.pas b/Units/PascalScript/uPSC_dll.pas
new file mode 100644
index 0000000..dd5fcd6
--- /dev/null
+++ b/Units/PascalScript/uPSC_dll.pas
@@ -0,0 +1,158 @@
+{ Compiletime DLL importing support }
+unit uPSC_dll;
+
+{$I PascalScript.inc}
+interface
+{
+
+ Function FindWindow(c1, c2: PChar): Cardinal; external 'FindWindow@user32.dll stdcall';
+
+}
+uses
+ uPSCompiler, uPSUtils;
+
+
+{$IFDEF DELPHI3UP }
+resourceString
+{$ELSE }
+const
+{$ENDIF }
+
+ RPS_Invalid_External = 'Invalid External';
+ RPS_InvalidCallingConvention = 'Invalid Calling Convention';
+
+
+
+function DllExternalProc(Sender: TPSPascalCompiler; Decl: TPSParametersDecl; const OriginalName, FExternal: tbtstring): TPSRegProc;
+type
+
+ TDllCallingConvention = (clRegister
+ , clPascal
+ , ClCdecl
+ , ClStdCall
+ );
+
+var
+ DefaultCC: TDllCallingConvention;
+
+procedure RegisterDll_Compiletime(cs: TPSPascalCompiler);
+
+implementation
+
+function rpos(ch: tbtchar; const s: tbtstring): Longint;
+var
+ i: Longint;
+begin
+ for i := length(s) downto 1 do
+ if s[i] = ch then begin Result := i; exit; end;
+ result := 0;
+end;
+
+function RemoveQuotes(s: tbtstring): tbtstring;
+begin
+ result := s;
+ if result = '' then exit;
+ if Result[1] = '"' then delete(result ,1,1);
+ if (Result <> '') and (Result[Length(result)] = '"') then delete(result, length(result), 1);
+end;
+
+function DllExternalProc(Sender: TPSPascalCompiler; Decl: TPSParametersDecl; const OriginalName, FExternal: tbtstring): TPSRegProc;
+var
+ FuncName,
+ Name,
+ FuncCC, s, s2: AnsiString;
+ CC: TDllCallingConvention;
+ DelayLoad, LoadWithAlteredSearchPath: Boolean;
+
+begin
+ Name := FastUpperCase(OriginalName);
+ DelayLoad := False;
+ LoadWithAlteredSearchPath := false;
+ FuncCC := FExternal;
+
+ if (pos(tbtChar('@'), FuncCC) = 0) then
+ begin
+ Sender.MakeError('', ecCustomError, tbtString(RPS_Invalid_External));
+ Result := nil;
+ exit;
+ end;
+ FuncName := copy(FuncCC, 1, rpos('@', FuncCC)-1)+#0;
+ delete(FuncCc, 1, length(FuncName));
+ if pos(tbtchar(' '), Funccc) <> 0 then
+ begin
+ if FuncCC[1] = '"' then
+ begin
+ Delete(FuncCC, 1, 1);
+ FuncName := RemoveQuotes(copy(FuncCC, 1, pos(tbtchar('"'), FuncCC)-1))+#0+FuncName;
+ Delete(FuncCC,1, pos(tbtchar('"'), FuncCC));
+ if (FuncCC <> '') and( FuncCC[1] = ' ') then delete(FuncCC,1,1);
+ end else
+ begin
+ FuncName := copy(FuncCc, 1, pos(tbtchar(' '),FuncCC)-1)+#0+FuncName;
+ Delete(FuncCC, 1, pos(tbtchar(' '), FuncCC));
+ end;
+ if pos(tbtchar(' '), FuncCC) > 0 then
+ begin
+ s := Copy(FuncCC, pos(tbtchar(' '), Funccc)+1, MaxInt);
+ FuncCC := FastUpperCase(Copy(FuncCC, 1, pos(tbtchar(' '), FuncCC)-1));
+ Delete(FuncCC, pos(tbtchar(' '), Funccc), MaxInt);
+ repeat
+ if pos(tbtchar(' '), s) > 0 then begin
+ s2 := Copy(s, 1, pos(tbtchar(' '), s)-1);
+ delete(s, 1, pos(tbtchar(' '), s));
+ end else begin
+ s2 := s;
+ s := '';
+ end;
+ if FastUppercase(s2) = 'DELAYLOAD' then
+ DelayLoad := True
+ {$IFNDEF LINUX}
+ else
+ if FastUppercase(s2) = 'LOADWITHALTEREDSEARCHPATH' then
+ LoadWithAlteredSearchPath := True
+ {$ENDIF}
+ else
+ begin
+ Sender.MakeError('', ecCustomError, 'Invalid External');
+ Result := nil;
+ exit;
+ end;
+ until s = '';
+
+ end else
+ FuncCC := FastUpperCase(FuncCC);
+ if FuncCC = 'STDCALL' then cc := ClStdCall else
+ if FuncCC = 'CDECL' then cc := ClCdecl else
+ if FuncCC = 'REGISTER' then cc := clRegister else
+ if FuncCC = 'PASCAL' then cc := clPascal else
+ begin
+ Sender.MakeError('', ecCustomError, tbtstring(RPS_InvalidCallingConvention));
+ Result := nil;
+ exit;
+ end;
+ end else
+ begin
+ FuncName := RemoveQuotes(FuncCC)+#0+FuncName;
+ FuncCC := '';
+ cc := DefaultCC;
+ end;
+ FuncName := 'dll:'+FuncName+tbtchar(cc)+tbtchar(bytebool(DelayLoad)) +tbtchar(bytebool(LoadWithAlteredSearchPath))+ declToBits(Decl);
+ Result := TPSRegProc.Create;
+ Result.ImportDecl := FuncName;
+ Result.Decl.Assign(Decl);
+ Result.Name := Name;
+ Result.OrgName := OriginalName;
+ Result.ExportName := False;
+end;
+
+procedure RegisterDll_Compiletime(cs: TPSPascalCompiler);
+begin
+ cs.OnExternalProc := DllExternalProc;
+ cs.AddFunction('procedure UnloadDll(s: string)');
+ cs.AddFunction('function DLLGetLastError: Longint');
+end;
+
+begin
+ DefaultCc := clRegister;
+end.
+
diff --git a/Units/PascalScript/uPSC_extctrls.pas b/Units/PascalScript/uPSC_extctrls.pas
new file mode 100644
index 0000000..785b5d3
--- /dev/null
+++ b/Units/PascalScript/uPSC_extctrls.pas
@@ -0,0 +1,327 @@
+{ Compiletime Extctrls support }
+unit uPSC_extctrls;
+
+{$I PascalScript.inc}
+interface
+uses
+ uPSCompiler, uPSUtils;
+
+(*
+ Will register files from:
+ ExtCtrls
+
+Requires:
+ STD, classes, controls, graphics {$IFNDEF PS_MINIVCL}, stdctrls {$ENDIF}
+*)
+
+procedure SIRegister_ExtCtrls_TypesAndConsts(cl: TPSPascalCompiler);
+
+procedure SIRegisterTSHAPE(Cl: TPSPascalCompiler);
+procedure SIRegisterTIMAGE(Cl: TPSPascalCompiler);
+procedure SIRegisterTPAINTBOX(Cl: TPSPascalCompiler);
+procedure SIRegisterTBEVEL(Cl: TPSPascalCompiler);
+procedure SIRegisterTTIMER(Cl: TPSPascalCompiler);
+procedure SIRegisterTCUSTOMPANEL(Cl: TPSPascalCompiler);
+procedure SIRegisterTPANEL(Cl: TPSPascalCompiler);
+{$IFNDEF CLX}
+procedure SIRegisterTPAGE(Cl: TPSPascalCompiler);
+procedure SIRegisterTNOTEBOOK(Cl: TPSPascalCompiler);
+procedure SIRegisterTHEADER(Cl: TPSPascalCompiler);
+{$ENDIF}
+procedure SIRegisterTCUSTOMRADIOGROUP(Cl: TPSPascalCompiler);
+procedure SIRegisterTRADIOGROUP(Cl: TPSPascalCompiler);
+
+procedure SIRegister_ExtCtrls(cl: TPSPascalCompiler);
+
+implementation
+procedure SIRegisterTSHAPE(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TGRAPHICCONTROL'), 'TSHAPE') do
+ begin
+ RegisterProperty('BRUSH', 'TBRUSH', iptrw);
+ RegisterProperty('PEN', 'TPEN', iptrw);
+ RegisterProperty('SHAPE', 'TSHAPETYPE', iptrw);
+
+ {$IFNDEF PS_MINIVCL}
+ RegisterMethod('procedure STYLECHANGED(SENDER:TOBJECT)');
+ RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
+ RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
+ RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
+ RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
+ RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
+ RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
+ RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw);
+ RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw);
+ RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw);
+ RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
+ {$ENDIF}
+ end;
+end;
+
+procedure SIRegisterTIMAGE(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TGRAPHICCONTROL'), 'TIMAGE') do
+ begin
+ RegisterProperty('CANVAS', 'TCANVAS', iptr);
+ RegisterProperty('AUTOSIZE', 'BOOLEAN', iptrw);
+ RegisterProperty('CENTER', 'BOOLEAN', iptrw);
+ RegisterProperty('PICTURE', 'TPICTURE', iptrw);
+ RegisterProperty('STRETCH', 'BOOLEAN', iptrw);
+ RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw);
+
+ {$IFNDEF PS_MINIVCL}
+ RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
+ RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
+ RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
+ RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw);
+ RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
+ RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
+ RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
+ RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw);
+ RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw);
+ RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw);
+ RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
+ {$ENDIF}
+ end;
+end;
+
+procedure SIRegisterTPAINTBOX(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TGRAPHICCONTROL'), 'TPAINTBOX') do
+ begin
+ RegisterProperty('CANVAS', 'TCanvas', iptr);
+ RegisterProperty('COLOR', 'TColor', iptrw);
+ RegisterProperty('FONT', 'TFont', iptrw);
+ RegisterProperty('PARENTCOLOR', 'Boolean', iptrw);
+ RegisterProperty('PARENTFONT', 'Boolean', iptrw);
+ RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONPAINT', 'TNOTIFYEVENT', iptrw);
+
+ {$IFNDEF PS_MINIVCL}
+ RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
+ RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
+ RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
+ RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw);
+ RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
+ RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
+ RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
+ RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw);
+ RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw);
+ RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw);
+ RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
+ {$ENDIF}
+ end;
+end;
+
+procedure SIRegisterTBEVEL(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TGRAPHICCONTROL'), 'TBEVEL') do
+ begin
+ RegisterProperty('SHAPE', 'TBEVELSHAPE', iptrw);
+ RegisterProperty('STYLE', 'TBEVELSTYLE', iptrw);
+
+ {$IFNDEF PS_MINIVCL}
+ RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
+ {$ENDIF}
+ end;
+end;
+
+procedure SIRegisterTTIMER(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TCOMPONENT'), 'TTIMER') do
+ begin
+ RegisterProperty('ENABLED', 'BOOLEAN', iptrw);
+ RegisterProperty('INTERVAL', 'CARDINAL', iptrw);
+ RegisterProperty('ONTIMER', 'TNOTIFYEVENT', iptrw);
+ end;
+end;
+
+procedure SIRegisterTCUSTOMPANEL(Cl: TPSPascalCompiler);
+begin
+ Cl.AddClassN(cl.FindClass('TCUSTOMCONTROL'), 'TCUSTOMPANEL');
+end;
+
+procedure SIRegisterTPANEL(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TCUSTOMPANEL'), 'TPANEL') do
+ begin
+ RegisterProperty('ALIGNMENT', 'TAlignment', iptrw);
+ RegisterProperty('BEVELINNER', 'TPanelBevel', iptrw);
+ RegisterProperty('BEVELOUTER', 'TPanelBevel', iptrw);
+ RegisterProperty('BEVELWIDTH', 'TBevelWidth', iptrw);
+ RegisterProperty('BORDERWIDTH', 'TBorderWidth', iptrw);
+ RegisterProperty('BORDERSTYLE', 'TBorderStyle', iptrw);
+ RegisterProperty('CAPTION', 'String', iptrw);
+ RegisterProperty('COLOR', 'TColor', iptrw);
+ RegisterProperty('FONT', 'TFont', iptrw);
+ RegisterProperty('PARENTCOLOR', 'Boolean', iptrw);
+ RegisterProperty('PARENTFONT', 'Boolean', iptrw);
+ RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONENTER', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw);
+
+ {$IFNDEF PS_MINIVCL}
+ RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
+ RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
+ RegisterProperty('CTL3D', 'Boolean', iptrw);
+ RegisterProperty('LOCKED', 'Boolean', iptrw);
+ RegisterProperty('PARENTCTL3D', 'Boolean', iptrw);
+ RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
+ RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw);
+ RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
+ RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
+ RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
+ RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw);
+ RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw);
+ RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw);
+ RegisterProperty('ONRESIZE', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
+ {$ENDIF}
+ end;
+end;
+{$IFNDEF CLX}
+procedure SIRegisterTPAGE(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TCUSTOMCONTROL'), 'TPAGE') do
+ begin
+ RegisterProperty('CAPTION', 'String', iptrw);
+ end;
+end;
+procedure SIRegisterTNOTEBOOK(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TCUSTOMCONTROL'), 'TNOTEBOOK') do
+ begin
+ RegisterProperty('ACTIVEPAGE', 'String', iptrw);
+ RegisterProperty('COLOR', 'TColor', iptrw);
+ RegisterProperty('FONT', 'TFont', iptrw);
+ RegisterProperty('PAGEINDEX', 'INTEGER', iptrw);
+ RegisterProperty('PAGES', 'TSTRINGS', iptrw);
+ RegisterProperty('PARENTCOLOR', 'Boolean', iptrw);
+ RegisterProperty('PARENTFONT', 'Boolean', iptrw);
+ RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONENTER', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONPAGECHANGED', 'TNOTIFYEVENT', iptrw);
+
+ {$IFNDEF PS_MINIVCL}
+ RegisterProperty('CTL3D', 'Boolean', iptrw);
+ RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
+ RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
+ RegisterProperty('PARENTCTL3D', 'Boolean', iptrw);
+ RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
+ RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw);
+ RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
+ RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
+ RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
+ RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw);
+ RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw);
+ RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw);
+ RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
+ {$ENDIF}
+ end;
+end;
+
+procedure SIRegisterTHEADER(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TCUSTOMCONTROL'), 'THEADER') do
+ begin
+ RegisterProperty('SECTIONWIDTH', 'INTEGER INTEGER', iptrw);
+ RegisterProperty('ALLOWRESIZE', 'BOOLEAN', iptrw);
+ RegisterProperty('BORDERSTYLE', 'TBORDERSTYLE', iptrw);
+ RegisterProperty('FONT', 'TFont', iptrw);
+ RegisterProperty('PARENTFONT', 'Boolean', iptrw);
+ RegisterProperty('SECTIONS', 'TSTRINGS', iptrw);
+ RegisterProperty('ONSIZING', 'TSECTIONEVENT', iptrw);
+ RegisterProperty('ONSIZED', 'TSECTIONEVENT', iptrw);
+
+ {$IFNDEF PS_MINIVCL}
+ RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
+ RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw);
+ {$ENDIF}
+ end;
+end;
+{$ENDIF}
+
+procedure SIRegisterTCUSTOMRADIOGROUP(Cl: TPSPascalCompiler);
+begin
+ Cl.AddClassN(cl.FindClass('TCUSTOMGROUPBOX'), 'TCUSTOMRADIOGROUP');
+end;
+
+procedure SIRegisterTRADIOGROUP(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TCUSTOMRADIOGROUP'), 'TRADIOGROUP') do
+ begin
+ RegisterProperty('CAPTION', 'String', iptrw);
+ RegisterProperty('COLOR', 'TColor', iptrw);
+ RegisterProperty('COLUMNS', 'Integer', iptrw);
+ RegisterProperty('FONT', 'TFont', iptrw);
+ RegisterProperty('ITEMINDEX', 'Integer', iptrw);
+ RegisterProperty('ITEMS', 'TStrings', iptrw);
+ RegisterProperty('PARENTCOLOR', 'Boolean', iptrw);
+ RegisterProperty('PARENTFONT', 'Boolean', iptrw);
+ RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONENTER', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw);
+
+ {$IFNDEF PS_MINIVCL}
+ RegisterProperty('CTL3D', 'Boolean', iptrw);
+ RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
+ RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
+ RegisterProperty('PARENTCTL3D', 'Boolean', iptrw);
+ RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
+ RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw);
+ RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
+ RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
+ RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
+ RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
+ {$ENDIF}
+ end;
+end;
+
+procedure SIRegister_ExtCtrls_TypesAndConsts(cl: TPSPascalCompiler);
+begin
+ cl.AddTypeS('TShapeType', '(stRectangle, stSquare, stRoundRect, stRoundSquare, stEllipse, stCircle)');
+ cl.AddTypeS('TBevelStyle', '(bsLowered, bsRaised)');
+ cl.AddTypeS('TBevelShape', '(bsBox, bsFrame, bsTopLine, bsBottomLine, bsLeftLine, bsRightLine,bsSpacer)');
+ cl.AddTypeS('TPanelBevel', '(bvNone, bvLowered, bvRaised,bvSpace)');
+ cl.AddTypeS('TBevelWidth', 'Longint');
+ cl.AddTypeS('TBorderWidth', 'Longint');
+ cl.AddTypeS('TSectionEvent', 'procedure(Sender: TObject; ASection, AWidth: Integer)');
+end;
+
+procedure SIRegister_ExtCtrls(cl: TPSPascalCompiler);
+begin
+ SIRegister_ExtCtrls_TypesAndConsts(cl);
+
+ {$IFNDEF PS_MINIVCL}
+ SIRegisterTSHAPE(Cl);
+ SIRegisterTIMAGE(Cl);
+ SIRegisterTPAINTBOX(Cl);
+ {$ENDIF}
+ SIRegisterTBEVEL(Cl);
+ {$IFNDEF PS_MINIVCL}
+ SIRegisterTTIMER(Cl);
+ {$ENDIF}
+ SIRegisterTCUSTOMPANEL(Cl);
+ SIRegisterTPANEL(Cl);
+ {$IFNDEF PS_MINIVCL}
+ {$IFNDEF CLX}
+ SIRegisterTPAGE(Cl);
+ SIRegisterTNOTEBOOK(Cl);
+ SIRegisterTHEADER(Cl);
+ {$ENDIF}
+ SIRegisterTCUSTOMRADIOGROUP(Cl);
+ SIRegisterTRADIOGROUP(Cl);
+ {$ENDIF}
+end;
+
+end.
+
+
+
+
+
diff --git a/Units/PascalScript/uPSC_forms.pas b/Units/PascalScript/uPSC_forms.pas
new file mode 100644
index 0000000..7969094
--- /dev/null
+++ b/Units/PascalScript/uPSC_forms.pas
@@ -0,0 +1,271 @@
+{ Compiletime Forms support }
+unit uPSC_forms;
+{$I PascalScript.inc}
+
+interface
+uses
+ uPSCompiler, uPSUtils;
+
+procedure SIRegister_Forms_TypesAndConsts(Cl: TPSPascalCompiler);
+
+
+procedure SIRegisterTCONTROLSCROLLBAR(Cl: TPSPascalCompiler);
+procedure SIRegisterTSCROLLINGWINCONTROL(Cl: TPSPascalCompiler);
+procedure SIRegisterTSCROLLBOX(Cl: TPSPascalCompiler);
+procedure SIRegisterTFORM(Cl: TPSPascalCompiler);
+procedure SIRegisterTAPPLICATION(Cl: TPSPascalCompiler);
+
+procedure SIRegister_Forms(Cl: TPSPascalCompiler);
+
+implementation
+
+procedure SIRegisterTCONTROLSCROLLBAR(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TPERSISTENT'), 'TCONTROLSCROLLBAR') do
+ begin
+ RegisterProperty('KIND', 'TSCROLLBARKIND', iptr);
+ RegisterProperty('SCROLLPOS', 'INTEGER', iptr);
+ RegisterProperty('MARGIN', 'WORD', iptrw);
+ RegisterProperty('INCREMENT', 'TSCROLLBARINC', iptrw);
+ RegisterProperty('RANGE', 'INTEGER', iptrw);
+ RegisterProperty('POSITION', 'INTEGER', iptrw);
+ RegisterProperty('TRACKING', 'BOOLEAN', iptrw);
+ RegisterProperty('VISIBLE', 'BOOLEAN', iptrw);
+ end;
+end;
+
+procedure SIRegisterTSCROLLINGWINCONTROL(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TWINCONTROL'), 'TSCROLLINGWINCONTROL') do
+ begin
+ RegisterMethod('procedure SCROLLINVIEW(ACONTROL:TCONTROL)');
+ RegisterProperty('HORZSCROLLBAR', 'TCONTROLSCROLLBAR', iptrw);
+ RegisterProperty('VERTSCROLLBAR', 'TCONTROLSCROLLBAR', iptrw);
+ end;
+end;
+
+procedure SIRegisterTSCROLLBOX(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TSCROLLINGWINCONTROL'), 'TSCROLLBOX') do
+ begin
+ RegisterProperty('BORDERSTYLE', 'TBORDERSTYLE', iptrw);
+ RegisterProperty('COLOR', 'TCOLOR', iptrw);
+ RegisterProperty('FONT', 'TFONT', iptrw);
+ RegisterProperty('AUTOSCROLL', 'BOOLEAN', iptrw);
+ RegisterProperty('PARENTCOLOR', 'BOOLEAN', iptrw);
+ RegisterProperty('PARENTFONT', 'BOOLEAN', iptrw);
+ RegisterProperty('ONCLICK', 'TNOTIFYEVENT', iptrw);
+ RegisterProperty('ONDBLCLICK', 'TNOTIFYEVENT', iptrw);
+ RegisterProperty('ONENTER', 'TNOTIFYEVENT', iptrw);
+ RegisterProperty('ONEXIT', 'TNOTIFYEVENT', iptrw);
+
+ {$IFNDEF PS_MINIVCL}
+ RegisterProperty('ONRESIZE', 'TNOTIFYEVENT', iptrw);
+ RegisterProperty('DRAGCURSOR', 'TCURSOR', iptrw);
+ RegisterProperty('DRAGMODE', 'TDRAGMODE', iptrw);
+ RegisterProperty('PARENTSHOWHINT', 'BOOLEAN', iptrw);
+ RegisterProperty('POPUPMENU', 'TPOPUPMENU', iptrw);
+ RegisterProperty('CTL3D', 'BOOLEAN', iptrw);
+ RegisterProperty('PARENTCTL3D', 'BOOLEAN', iptrw);
+ RegisterProperty('ONDRAGDROP', 'TDRAGDROPEVENT', iptrw);
+ RegisterProperty('ONDRAGOVER', 'TDRAGOVEREVENT', iptrw);
+ RegisterProperty('ONENDDRAG', 'TENDDRAGEVENT', iptrw);
+ RegisterProperty('ONMOUSEDOWN', 'TMOUSEEVENT', iptrw);
+ RegisterProperty('ONMOUSEMOVE', 'TMOUSEMOVEEVENT', iptrw);
+ RegisterProperty('ONMOUSEUP', 'TMOUSEEVENT', iptrw);
+ {$ENDIF}
+ end;
+end;
+
+procedure SIRegisterTFORM(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TSCROLLINGWINCONTROL'), 'TFORM') do
+ begin
+ {$IFDEF DELPHI4UP}
+ RegisterMethod('constructor CREATENEW(AOWNER:TCOMPONENT; Dummy: Integer)');
+ {$ELSE}
+ RegisterMethod('constructor CREATENEW(AOWNER:TCOMPONENT)');
+ {$ENDIF}
+ RegisterMethod('procedure CLOSE');
+ RegisterMethod('procedure HIDE');
+ RegisterMethod('procedure SHOW');
+ RegisterMethod('function SHOWMODAL:INTEGER');
+ RegisterMethod('procedure RELEASE');
+ RegisterProperty('ACTIVE', 'BOOLEAN', iptr);
+ RegisterProperty('ACTIVECONTROL', 'TWINCONTROL', iptrw);
+ RegisterProperty('BORDERICONS', 'TBorderIcons', iptrw);
+ RegisterProperty('BORDERSTYLE', 'TFORMBORDERSTYLE', iptrw);
+ RegisterProperty('CAPTION', 'NativeString', iptrw);
+ RegisterProperty('AUTOSCROLL', 'BOOLEAN', iptrw);
+ RegisterProperty('COLOR', 'TCOLOR', iptrw);
+ RegisterProperty('FONT', 'TFONT', iptrw);
+ RegisterProperty('FORMSTYLE', 'TFORMSTYLE', iptrw);
+ RegisterProperty('KEYPREVIEW', 'BOOLEAN', iptrw);
+ RegisterProperty('POSITION', 'TPOSITION', iptrw);
+ RegisterProperty('ONACTIVATE', 'TNOTIFYEVENT', iptrw);
+ RegisterProperty('ONCLICK', 'TNOTIFYEVENT', iptrw);
+ RegisterProperty('ONDBLCLICK', 'TNOTIFYEVENT', iptrw);
+ RegisterProperty('ONCLOSE', 'TCLOSEEVENT', iptrw);
+ RegisterProperty('ONCLOSEQUERY', 'TCLOSEQUERYEVENT', iptrw);
+ RegisterProperty('ONCREATE', 'TNOTIFYEVENT', iptrw);
+ RegisterProperty('ONDESTROY', 'TNOTIFYEVENT', iptrw);
+ RegisterProperty('ONDEACTIVATE', 'TNOTIFYEVENT', iptrw);
+ RegisterProperty('ONHIDE', 'TNOTIFYEVENT', iptrw);
+ RegisterProperty('ONKEYDOWN', 'TKEYEVENT', iptrw);
+ RegisterProperty('ONKEYPRESS', 'TKEYPRESSEVENT', iptrw);
+ RegisterProperty('ONKEYUP', 'TKEYEVENT', iptrw);
+ RegisterProperty('ONRESIZE', 'TNOTIFYEVENT', iptrw);
+ RegisterProperty('ONSHOW', 'TNOTIFYEVENT', iptrw);
+
+
+ {$IFNDEF PS_MINIVCL}
+ {$IFNDEF CLX}
+ RegisterMethod('procedure ARRANGEICONS');
+// RegisterMethod('function GETFORMIMAGE:TBITMAP');
+ RegisterMethod('procedure PRINT');
+ RegisterMethod('procedure SENDCANCELMODE(SENDER:TCONTROL)');
+ RegisterProperty('ACTIVEOLECONTROL', 'TWINCONTROL', iptrw);
+ RegisterProperty('OLEFORMOBJECT', 'TOLEFORMOBJECT', iptrw);
+ RegisterProperty('CLIENTHANDLE', 'LONGINT', iptr);
+ RegisterProperty('TILEMODE', 'TTILEMODE', iptrw);
+ {$ENDIF}
+ RegisterMethod('procedure CASCADE');
+ RegisterMethod('function CLOSEQUERY:BOOLEAN');
+ RegisterMethod('procedure DEFOCUSCONTROL(CONTROL:TWINCONTROL;REMOVING:BOOLEAN)');
+ RegisterMethod('procedure FOCUSCONTROL(CONTROL:TWINCONTROL)');
+ RegisterMethod('procedure NEXT');
+ RegisterMethod('procedure PREVIOUS');
+ RegisterMethod('function SETFOCUSEDCONTROL(CONTROL:TWINCONTROL):BOOLEAN');
+ RegisterMethod('procedure TILE');
+ RegisterProperty('ACTIVEMDICHILD', 'TFORM', iptr);
+ RegisterProperty('CANVAS', 'TCANVAS', iptr);
+ RegisterProperty('DROPTARGET', 'BOOLEAN', iptrw);
+ RegisterProperty('MODALRESULT', 'Longint', iptrw);
+ RegisterProperty('MDICHILDCOUNT', 'INTEGER', iptr);
+ RegisterProperty('MDICHILDREN', 'TFORM INTEGER', iptr);
+ RegisterProperty('ICON', 'TICON', iptrw);
+ RegisterProperty('MENU', 'TMAINMENU', iptrw);
+ RegisterProperty('OBJECTMENUITEM', 'TMENUITEM', iptrw);
+ RegisterProperty('PIXELSPERINCH', 'INTEGER', iptrw);
+ RegisterProperty('PRINTSCALE', 'TPRINTSCALE', iptrw);
+ RegisterProperty('SCALED', 'BOOLEAN', iptrw);
+ RegisterProperty('WINDOWSTATE', 'TWINDOWSTATE', iptrw);
+ RegisterProperty('WINDOWMENU', 'TMENUITEM', iptrw);
+ RegisterProperty('CTL3D', 'BOOLEAN', iptrw);
+ RegisterProperty('POPUPMENU', 'TPOPUPMENU', iptrw);
+ RegisterProperty('ONDRAGDROP', 'TDRAGDROPEVENT', iptrw);
+ RegisterProperty('ONDRAGOVER', 'TDRAGOVEREVENT', iptrw);
+ RegisterProperty('ONMOUSEDOWN', 'TMOUSEEVENT', iptrw);
+ RegisterProperty('ONMOUSEMOVE', 'TMOUSEMOVEEVENT', iptrw);
+ RegisterProperty('ONMOUSEUP', 'TMOUSEEVENT', iptrw);
+ RegisterProperty('ONPAINT', 'TNOTIFYEVENT', iptrw);
+ {$ENDIF}
+ end;
+end;
+
+procedure SIRegisterTAPPLICATION(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TCOMPONENT'), 'TAPPLICATION') do
+ begin
+ RegisterMethod('procedure BRINGTOFRONT');
+{$IFDEF PS_PANSICHAR}
+ RegisterMethod('function MESSAGEBOX(TEXT,CAPTION:PANSICHAR;FLAGS:WORD):INTEGER');
+{$ELSE}
+ RegisterMethod('function MESSAGEBOX(TEXT,CAPTION:PCHAR;FLAGS:WORD):INTEGER');
+{$ENDIF}
+ RegisterMethod('procedure MINIMIZE');
+ RegisterMethod('procedure PROCESSMESSAGES');
+ RegisterMethod('procedure RESTORE');
+ RegisterMethod('procedure TERMINATE');
+ RegisterProperty('ACTIVE', 'BOOLEAN', iptr);
+ RegisterProperty('EXENAME', 'NativeString', iptr);
+ {$IFNDEF CLX}
+ RegisterProperty('HANDLE', 'LONGINT', iptrw);
+ RegisterProperty('UPDATEFORMATSETTINGS', 'BOOLEAN', iptrw);
+ {$ENDIF}
+ RegisterProperty('HINT', 'NativeString', iptrw);
+ RegisterProperty('MAINFORM', 'TFORM', iptr);
+ RegisterProperty('SHOWHINT', 'BOOLEAN', iptrw);
+ RegisterProperty('SHOWMAINFORM', 'BOOLEAN', iptrw);
+ RegisterProperty('TERMINATED', 'BOOLEAN', iptr);
+ RegisterProperty('TITLE', 'NativeString', iptrw);
+ RegisterProperty('ONACTIVATE', 'TNOTIFYEVENT', iptrw);
+ RegisterProperty('ONDEACTIVATE', 'TNOTIFYEVENT', iptrw);
+ RegisterProperty('ONIDLE', 'TIDLEEVENT', iptrw);
+ RegisterProperty('ONHINT', 'TNOTIFYEVENT', iptrw);
+ RegisterProperty('ONMINIMIZE', 'TNOTIFYEVENT', iptrw);
+ RegisterProperty('ONRESTORE', 'TNOTIFYEVENT', iptrw);
+
+ {$IFNDEF PS_MINIVCL}
+ RegisterMethod('procedure CONTROLDESTROYED(CONTROL:TCONTROL)');
+ RegisterMethod('procedure CANCELHINT');
+ RegisterMethod('procedure HANDLEEXCEPTION(SENDER:TOBJECT)');
+ RegisterMethod('procedure HANDLEMESSAGE');
+ RegisterMethod('procedure HIDEHINT');
+// RegisterMethod('procedure HINTMOUSEMESSAGE(CONTROL:TCONTROL;var MESSAGE:TMESSAGE)');
+ RegisterMethod('procedure INITIALIZE');
+ RegisterMethod('procedure NORMALIZETOPMOSTS');
+ RegisterMethod('procedure RESTORETOPMOSTS');
+ RegisterMethod('procedure RUN');
+// RegisterMethod('procedure SHOWEXCEPTION(E:EXCEPTION)');
+ {$IFNDEF CLX}
+ RegisterMethod('function HELPCOMMAND(COMMAND:INTEGER;DATA:LONGINT):BOOLEAN');
+ RegisterMethod('function HELPCONTEXT(CONTEXT:THELPCONTEXT):BOOLEAN');
+ RegisterMethod('function HELPJUMP(JUMPID:NativeString):BOOLEAN');
+ RegisterProperty('DIALOGHANDLE', 'LONGINT', iptrw);
+ RegisterMethod('procedure CREATEHANDLE');
+// RegisterMethod('procedure HOOKMAINWINDOW(HOOK:TWINDOWHOOK)');
+// RegisterMethod('procedure UNHOOKMAINWINDOW(HOOK:TWINDOWHOOK)');
+ {$ENDIF}
+ RegisterProperty('HELPFILE', 'NativeString', iptrw);
+ RegisterProperty('HINTCOLOR', 'TCOLOR', iptrw);
+ RegisterProperty('HINTPAUSE', 'INTEGER', iptrw);
+ RegisterProperty('HINTSHORTPAUSE', 'INTEGER', iptrw);
+ RegisterProperty('HINTHIDEPAUSE', 'INTEGER', iptrw);
+ RegisterProperty('ICON', 'TICON', iptrw);
+ RegisterProperty('ONHELP', 'THELPEVENT', iptrw);
+ {$ENDIF}
+ end;
+end;
+
+procedure SIRegister_Forms_TypesAndConsts(Cl: TPSPascalCompiler);
+begin
+ Cl.AddTypeS('TIdleEvent', 'procedure (Sender: TObject; var Done: Boolean)');
+ cl.AddTypeS('TScrollBarKind', '(sbHorizontal, sbVertical)');
+ cl.AddTypeS('TScrollBarInc', 'SmallInt');
+ cl.AddTypeS('TFormBorderStyle', '(bsNone, bsSingle, bsSizeable, bsDialog, bsToolWindow, bsSizeToolWin)');
+ cl.AddTypeS('TBorderStyle', 'TFormBorderStyle');
+ cl.AddTypeS('TWindowState', '(wsNormal, wsMinimized, wsMaximized)');
+ cl.AddTypeS('TFormStyle', '(fsNormal, fsMDIChild, fsMDIForm, fsStayOnTop)');
+ cl.AddTypeS('TPosition', '(poDesigned, poDefault, poDefaultPosOnly, poDefaultSizeOnly, poScreenCenter, poDesktopCenter, poMainFormCenter, poOwnerFormCenter)');
+ cl.AddTypeS('TPrintScale', '(poNone, poProportional, poPrintToFit)');
+ cl.AddTypeS('TCloseAction', '(caNone, caHide, caFree, caMinimize)');
+ cl.AddTypeS('TCloseEvent' ,'procedure(Sender: TObject; var Action: TCloseAction)');
+ cl.AddTypeS('TCloseQueryEvent' ,'procedure(Sender: TObject; var CanClose: Boolean)');
+ cl.AddTypeS('TBorderIcon' ,'(biSystemMenu, biMinimize, biMaximize, biHelp)');
+ cl.AddTypeS('TBorderIcons', 'set of TBorderIcon');
+ cl.AddTypeS('THELPCONTEXT', 'Longint');
+end;
+
+procedure SIRegister_Forms(Cl: TPSPascalCompiler);
+begin
+ SIRegister_Forms_TypesAndConsts(cl);
+
+ {$IFNDEF PS_MINIVCL}
+ SIRegisterTCONTROLSCROLLBAR(cl);
+ {$ENDIF}
+ SIRegisterTScrollingWinControl(cl);
+ {$IFNDEF PS_MINIVCL}
+ SIRegisterTSCROLLBOX(cl);
+ {$ENDIF}
+ SIRegisterTForm(Cl);
+ {$IFNDEF PS_MINIVCL}
+ SIRegisterTApplication(Cl);
+ {$ENDIF}
+end;
+
+// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl)
+
+
+end.
+
diff --git a/Units/PascalScript/uPSC_graphics.pas b/Units/PascalScript/uPSC_graphics.pas
new file mode 100644
index 0000000..e96bbe2
--- /dev/null
+++ b/Units/PascalScript/uPSC_graphics.pas
@@ -0,0 +1,275 @@
+{ Compiletime Graphics support }
+unit uPSC_graphics;
+
+{$I PascalScript.inc}
+interface
+uses
+ uPSCompiler, uPSUtils;
+
+
+
+procedure SIRegister_Graphics_TypesAndConsts(Cl: TPSPascalCompiler);
+procedure SIRegisterTGRAPHICSOBJECT(Cl: TPSPascalCompiler);
+procedure SIRegisterTFont(Cl: TPSPascalCompiler);
+procedure SIRegisterTPEN(Cl: TPSPascalCompiler);
+procedure SIRegisterTBRUSH(Cl: TPSPascalCompiler);
+procedure SIRegisterTCanvas(cl: TPSPascalCompiler);
+procedure SIRegisterTGraphic(CL: TPSPascalCompiler);
+procedure SIRegisterTBitmap(CL: TPSPascalCompiler; Streams: Boolean);
+
+procedure SIRegister_Graphics(Cl: TPSPascalCompiler; Streams: Boolean);
+
+implementation
+{$IFNDEF PS_NOGRAPHCONST}
+uses
+ {$IFDEF CLX}QGraphics{$ELSE}Graphics{$ENDIF};
+{$ELSE}
+{$IFNDEF CLX}
+{$IFNDEF FPC}
+uses
+ Windows;
+{$ENDIF}
+{$ENDIF}
+{$ENDIF}
+
+procedure SIRegisterTGRAPHICSOBJECT(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TPERSISTENT'), 'TGRAPHICSOBJECT') do
+ begin
+ RegisterProperty('ONCHANGE', 'TNOTIFYEVENT', iptrw);
+ end;
+end;
+
+procedure SIRegisterTFont(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TGraphicsObject'), 'TFONT') do
+ begin
+ RegisterMethod('constructor Create;');
+{$IFNDEF CLX}
+ RegisterProperty('Handle', 'Integer', iptRW);
+{$ENDIF}
+ RegisterProperty('Color', 'TColor', iptRW);
+ RegisterProperty('Height', 'Integer', iptRW);
+ RegisterProperty('Name', 'String', iptRW);
+ RegisterProperty('Pitch', 'Byte', iptRW);
+ RegisterProperty('Size', 'Integer', iptRW);
+ RegisterProperty('PixelsPerInch', 'Integer', iptRW);
+ RegisterProperty('Style', 'TFontStyles', iptrw);
+ end;
+end;
+
+procedure SIRegisterTCanvas(cl: TPSPascalCompiler); // requires TPersistent
+begin
+ with Cl.AddClassN(cl.FindClass('TPersistent'), 'TCANVAS') do
+ begin
+ RegisterMethod('procedure Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);');
+ RegisterMethod('procedure Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);');
+// RegisterMethod('procedure Draw(X, Y: Integer; Graphic: TGraphic);');
+ RegisterMethod('procedure Ellipse(X1, Y1, X2, Y2: Integer);');
+ RegisterMethod('procedure FillRect(const Rect: TRect);');
+{$IFNDEF CLX}
+ RegisterMethod('procedure FloodFill(X, Y: Integer; Color: TColor; FillStyle: Byte);');
+{$ENDIF}
+ RegisterMethod('procedure LineTo(X, Y: Integer);');
+ RegisterMethod('procedure MoveTo(X, Y: Integer);');
+ RegisterMethod('procedure Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);');
+ RegisterMethod('procedure Rectangle(X1, Y1, X2, Y2: Integer);');
+ RegisterMethod('procedure Refresh;');
+ RegisterMethod('procedure RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer);');
+ RegisterMethod('function TextHeight(Text: String): Integer;');
+ RegisterMethod('procedure TextOut(X, Y: Integer; Text: String);');
+ RegisterMethod('function TextWidth(Text: String): Integer;');
+{$IFNDEF CLX}
+ RegisterProperty('Handle', 'Integer', iptRw);
+{$ENDIF}
+ RegisterProperty('Pixels', 'Integer Integer Integer', iptRW);
+ RegisterProperty('Brush', 'TBrush', iptR);
+ RegisterProperty('CopyMode', 'Byte', iptRw);
+ RegisterProperty('Font', 'TFont', iptR);
+ RegisterProperty('Pen', 'TPen', iptR);
+ end;
+end;
+
+procedure SIRegisterTPEN(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TGRAPHICSOBJECT'), 'TPEN') do
+ begin
+ RegisterMethod('constructor CREATE');
+ RegisterProperty('COLOR', 'TCOLOR', iptrw);
+ RegisterProperty('MODE', 'TPENMODE', iptrw);
+ RegisterProperty('STYLE', 'TPENSTYLE', iptrw);
+ RegisterProperty('WIDTH', 'INTEGER', iptrw);
+ end;
+end;
+
+procedure SIRegisterTBRUSH(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TGRAPHICSOBJECT'), 'TBRUSH') do
+ begin
+ RegisterMethod('constructor CREATE');
+ RegisterProperty('COLOR', 'TCOLOR', iptrw);
+ RegisterProperty('STYLE', 'TBRUSHSTYLE', iptrw);
+ end;
+end;
+
+procedure SIRegister_Graphics_TypesAndConsts(Cl: TPSPascalCompiler);
+{$IFDEF PS_NOGRAPHCONST}
+const
+ clSystemColor = {$IFDEF DELPHI7UP} $FF000000 {$ELSE} $80000000 {$ENDIF};
+{$ENDIF}
+begin
+{$IFNDEF PS_NOGRAPHCONST}
+ cl.AddConstantN('clScrollBar', 'Integer').Value.ts32 := clScrollBar;
+ cl.AddConstantN('clBackground', 'Integer').Value.ts32 := clBackground;
+ cl.AddConstantN('clActiveCaption', 'Integer').Value.ts32 := clActiveCaption;
+ cl.AddConstantN('clInactiveCaption', 'Integer').Value.ts32 := clInactiveCaption;
+ cl.AddConstantN('clMenu', 'Integer').Value.ts32 := clMenu;
+ cl.AddConstantN('clWindow', 'Integer').Value.ts32 := clWindow;
+ cl.AddConstantN('clWindowFrame', 'Integer').Value.ts32 := clWindowFrame;
+ cl.AddConstantN('clMenuText', 'Integer').Value.ts32 := clMenuText;
+ cl.AddConstantN('clWindowText', 'Integer').Value.ts32 := clWindowText;
+ cl.AddConstantN('clCaptionText', 'Integer').Value.ts32 := clCaptionText;
+ cl.AddConstantN('clActiveBorder', 'Integer').Value.ts32 := clActiveBorder;
+ cl.AddConstantN('clInactiveBorder', 'Integer').Value.ts32 := clInactiveCaption;
+ cl.AddConstantN('clAppWorkSpace', 'Integer').Value.ts32 := clAppWorkSpace;
+ cl.AddConstantN('clHighlight', 'Integer').Value.ts32 := clHighlight;
+ cl.AddConstantN('clHighlightText', 'Integer').Value.ts32 := clHighlightText;
+ cl.AddConstantN('clBtnFace', 'Integer').Value.ts32 := clBtnFace;
+ cl.AddConstantN('clBtnShadow', 'Integer').Value.ts32 := clBtnShadow;
+ cl.AddConstantN('clGrayText', 'Integer').Value.ts32 := clGrayText;
+ cl.AddConstantN('clBtnText', 'Integer').Value.ts32 := clBtnText;
+ cl.AddConstantN('clInactiveCaptionText', 'Integer').Value.ts32 := clInactiveCaptionText;
+ cl.AddConstantN('clBtnHighlight', 'Integer').Value.ts32 := clBtnHighlight;
+ cl.AddConstantN('cl3DDkShadow', 'Integer').Value.ts32 := cl3DDkShadow;
+ cl.AddConstantN('cl3DLight', 'Integer').Value.ts32 := cl3DLight;
+ cl.AddConstantN('clInfoText', 'Integer').Value.ts32 := clInfoText;
+ cl.AddConstantN('clInfoBk', 'Integer').Value.ts32 := clInfoBk;
+{$ELSE}
+{$IFNDEF CLX} // These are VCL-only; CLX uses different constant values
+ cl.AddConstantN('clScrollBar', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_SCROLLBAR);
+ cl.AddConstantN('clBackground', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_BACKGROUND);
+ cl.AddConstantN('clActiveCaption', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_ACTIVECAPTION);
+ cl.AddConstantN('clInactiveCaption', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_INACTIVECAPTION);
+ cl.AddConstantN('clMenu', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_MENU);
+ cl.AddConstantN('clWindow', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_WINDOW);
+ cl.AddConstantN('clWindowFrame', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_WINDOWFRAME);
+ cl.AddConstantN('clMenuText', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_MENUTEXT);
+ cl.AddConstantN('clWindowText', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_WINDOWTEXT);
+ cl.AddConstantN('clCaptionText', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_CAPTIONTEXT);
+ cl.AddConstantN('clActiveBorder', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_ACTIVEBORDER);
+ cl.AddConstantN('clInactiveBorder', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_INACTIVEBORDER);
+ cl.AddConstantN('clAppWorkSpace', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_APPWORKSPACE);
+ cl.AddConstantN('clHighlight', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_HIGHLIGHT);
+ cl.AddConstantN('clHighlightText', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_HIGHLIGHTTEXT);
+ cl.AddConstantN('clBtnFace', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_BTNFACE);
+ cl.AddConstantN('clBtnShadow', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_BTNSHADOW);
+ cl.AddConstantN('clGrayText', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_GRAYTEXT);
+ cl.AddConstantN('clBtnText', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_BTNTEXT);
+ cl.AddConstantN('clInactiveCaptionText', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_INACTIVECAPTIONTEXT);
+ cl.AddConstantN('clBtnHighlight', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_BTNHIGHLIGHT);
+ cl.AddConstantN('cl3DDkShadow', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_3DDKSHADOW);
+ cl.AddConstantN('cl3DLight', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_3DLIGHT);
+ cl.AddConstantN('clInfoText', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_INFOTEXT);
+ cl.AddConstantN('clInfoBk', 'Integer').Value.ts32 := Integer(clSystemColor or COLOR_INFOBK);
+{$ENDIF}
+{$ENDIF}
+ cl.AddConstantN('clBlack', 'Integer').Value.ts32 := $000000;
+ cl.AddConstantN('clMaroon', 'Integer').Value.ts32 := $000080;
+ cl.AddConstantN('clGreen', 'Integer').Value.ts32 := $008000;
+ cl.AddConstantN('clOlive', 'Integer').Value.ts32 := $008080;
+ cl.AddConstantN('clNavy', 'Integer').Value.ts32 := $800000;
+ cl.AddConstantN('clPurple', 'Integer').Value.ts32 := $800080;
+ cl.AddConstantN('clTeal', 'Integer').Value.ts32 := $808000;
+ cl.AddConstantN('clGray', 'Integer').Value.ts32 := $808080;
+ cl.AddConstantN('clSilver', 'Integer').Value.ts32 := $C0C0C0;
+ cl.AddConstantN('clRed', 'Integer').Value.ts32 := $0000FF;
+ cl.AddConstantN('clLime', 'Integer').Value.ts32 := $00FF00;
+ cl.AddConstantN('clYellow', 'Integer').Value.ts32 := $00FFFF;
+ cl.AddConstantN('clBlue', 'Integer').Value.ts32 := $FF0000;
+ cl.AddConstantN('clFuchsia', 'Integer').Value.ts32 := $FF00FF;
+ cl.AddConstantN('clAqua', 'Integer').Value.ts32 := $FFFF00;
+ cl.AddConstantN('clLtGray', 'Integer').Value.ts32 := $C0C0C0;
+ cl.AddConstantN('clDkGray', 'Integer').Value.ts32 := $808080;
+ cl.AddConstantN('clWhite', 'Integer').Value.ts32 := $FFFFFF;
+ cl.AddConstantN('clNone', 'Integer').Value.ts32 := $1FFFFFFF;
+ cl.AddConstantN('clDefault', 'Integer').Value.ts32 := $20000000;
+
+ Cl.addTypeS('TFONTSTYLE', '(FSBOLD, FSITALIC, FSUNDERLINE, FSSTRIKEOUT)');
+ Cl.addTypeS('TFONTSTYLES', 'set of TFONTSTYLE');
+
+ cl.AddTypeS('TFontPitch', '(fpDefault, fpVariable, fpFixed)');
+ cl.AddTypeS('TPenStyle', '(psSolid, psDash, psDot, psDashDot, psDashDotDot, psClear, psInsideFrame)');
+ cl.AddTypeS('TPenMode', '(pmBlack, pmWhite, pmNop, pmNot, pmCopy, pmNotCopy, pmMergePenNot, pmMaskPenNot, pmMergeNotPen, pmMaskNotPen, pmMerge, pmNotMerge, pmMask, pmNotMask, pmXor, pmNotXor)');
+ cl.AddTypeS('TBrushStyle', '(bsSolid, bsClear, bsHorizontal, bsVertical, bsFDiagonal, bsBDiagonal, bsCross, bsDiagCross)');
+ cl.addTypeS('TColor', 'integer');
+
+{$IFNDEF CLX}
+ cl.addTypeS('HBITMAP', 'Integer');
+ cl.addTypeS('HPALETTE', 'Integer');
+{$ENDIF}
+end;
+
+procedure SIRegisterTGraphic(CL: TPSPascalCompiler);
+begin
+ with CL.AddClassN(CL.FindClass('TPersistent'),'TGraphic') do
+ begin
+ RegisterMethod('constructor Create');
+ RegisterMethod('Procedure LoadFromFile( const Filename : String)');
+ RegisterMethod('Procedure SaveToFile( const Filename : String)');
+ RegisterProperty('Empty', 'Boolean', iptr);
+ RegisterProperty('Height', 'Integer', iptrw);
+ RegisterProperty('Modified', 'Boolean', iptrw);
+ RegisterProperty('Width', 'Integer', iptrw);
+ RegisterProperty('OnChange', 'TNotifyEvent', iptrw);
+ end;
+end;
+
+procedure SIRegisterTBitmap(CL: TPSPascalCompiler; Streams: Boolean);
+begin
+ with CL.AddClassN(CL.FindClass('TGraphic'),'TBitmap') do
+ begin
+ if Streams then begin
+ RegisterMethod('Procedure LoadFromStream( Stream : TStream)');
+ RegisterMethod('Procedure SaveToStream( Stream : TStream)');
+ end;
+ RegisterProperty('Canvas', 'TCanvas', iptr);
+{$IFNDEF CLX}
+ RegisterProperty('Handle', 'HBITMAP', iptrw);
+{$ENDIF}
+
+ {$IFNDEF IFPS_MINIVCL}
+ RegisterMethod('Procedure Dormant');
+ RegisterMethod('Procedure FreeImage');
+{$IFNDEF CLX}
+ RegisterMethod('Procedure LoadFromClipboardFormat( AFormat : Word; AData : THandle; APalette : HPALETTE)');
+{$ENDIF}
+ RegisterMethod('Procedure LoadFromResourceName( Instance : THandle; const ResName : String)');
+ RegisterMethod('Procedure LoadFromResourceID( Instance : THandle; ResID : Integer)');
+{$IFNDEF CLX}
+ RegisterMethod('Function ReleaseHandle : HBITMAP');
+ RegisterMethod('Function ReleasePalette : HPALETTE');
+ RegisterMethod('Procedure SaveToClipboardFormat( var Format : Word; var Data : THandle; var APalette : HPALETTE)');
+ RegisterProperty('Monochrome', 'Boolean', iptrw);
+ RegisterProperty('Palette', 'HPALETTE', iptrw);
+ RegisterProperty('IgnorePalette', 'Boolean', iptrw);
+{$ENDIF}
+ RegisterProperty('TransparentColor', 'TColor', iptr);
+ {$ENDIF}
+ end;
+end;
+
+procedure SIRegister_Graphics(Cl: TPSPascalCompiler; Streams: Boolean);
+begin
+ SIRegister_Graphics_TypesAndConsts(Cl);
+ SIRegisterTGRAPHICSOBJECT(Cl);
+ SIRegisterTFont(Cl);
+ SIRegisterTPEN(cl);
+ SIRegisterTBRUSH(cl);
+ SIRegisterTCanvas(cl);
+ SIRegisterTGraphic(Cl);
+ SIRegisterTBitmap(Cl, Streams);
+end;
+
+// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl)
+
+End.
diff --git a/Units/PascalScript/uPSC_menus.pas b/Units/PascalScript/uPSC_menus.pas
new file mode 100644
index 0000000..698f16b
--- /dev/null
+++ b/Units/PascalScript/uPSC_menus.pas
@@ -0,0 +1,214 @@
+{ Menus Import Unit }
+Unit uPSC_menus;
+{$I PascalScript.inc}
+Interface
+Uses uPSCompiler;
+
+procedure SIRegisterTMENUITEMSTACK(CL: TPSPascalCompiler);
+procedure SIRegisterTPOPUPLIST(CL: TPSPascalCompiler);
+procedure SIRegisterTPOPUPMENU(CL: TPSPascalCompiler);
+procedure SIRegisterTMAINMENU(CL: TPSPascalCompiler);
+procedure SIRegisterTMENU(CL: TPSPascalCompiler);
+procedure SIRegisterTMENUITEM(CL: TPSPascalCompiler);
+procedure SIRegister_Menus(Cl: TPSPascalCompiler);
+
+implementation
+
+procedure SIRegisterTMENUITEMSTACK(CL: TPSPascalCompiler);
+begin
+ With cl.AddClassN(Cl.FindClass('TSTACK'),'TMENUITEMSTACK') do
+ begin
+ RegisterMethod('Procedure CLEARITEM( AITEM : TMENUITEM)');
+ end;
+end;
+
+procedure SIRegisterTPOPUPLIST(CL: TPSPascalCompiler);
+begin
+ With cl.AddClassN(Cl.FindClass('TLIST'),'TPOPUPLIST') do
+ begin
+ RegisterProperty('WINDOW', 'HWND', iptr);
+ RegisterMethod('Procedure ADD( POPUP : TPOPUPMENU)');
+ RegisterMethod('Procedure REMOVE( POPUP : TPOPUPMENU)');
+ end;
+end;
+
+procedure SIRegisterTPOPUPMENU(CL: TPSPascalCompiler);
+var
+ cc: TPSCompileTimeClass;
+begin
+ With cl.AddClassN(Cl.FindClass('TMENU'),'TPOPUPMENU') do
+ begin
+ cc := Cl.FindClass('TLabel');
+ if cc <> nil then
+ RegisterProperty('POPUPMENU', 'TPOPUPMENU', iptRW);
+ with Cl.FindClass('TForm') do
+ begin
+ RegisterProperty('POPUPMENU', 'TPOPUPMENU', iptRW);
+ end;
+ RegisterMethod('Constructor CREATE( AOWNER : TCOMPONENT)');
+ RegisterMethod('Procedure POPUP( X, Y : INTEGER)');
+ RegisterProperty('POPUPCOMPONENT', 'TCOMPONENT', iptrw);
+ RegisterProperty('ALIGNMENT', 'TPOPUPALIGNMENT', iptrw);
+ RegisterProperty('AUTOPOPUP', 'BOOLEAN', iptrw);
+ RegisterProperty('HELPCONTEXT', 'THELPCONTEXT', iptrw);
+ RegisterProperty('MENUANIMATION', 'TMENUANIMATION', iptrw);
+ RegisterProperty('TRACKBUTTON', 'TTRACKBUTTON', iptrw);
+ RegisterProperty('ONPOPUP', 'TNOTIFYEVENT', iptrw);
+ end;
+end;
+
+procedure SIRegisterTMAINMENU(CL: TPSPascalCompiler);
+begin
+ With cl.AddClassN(Cl.FindClass('TMENU'),'TMAINMENU') do
+ begin
+ RegisterMethod('Procedure MERGE( MENU : TMAINMENU)');
+ RegisterMethod('Procedure UNMERGE( MENU : TMAINMENU)');
+ RegisterMethod('Procedure POPULATEOLE2MENU( SHAREDMENU : HMENU; GROUPS : array of INTEGER; var WIDTHS : array of LONGINT)');
+ RegisterMethod('Procedure GETOLE2ACCELERATORTABLE( var ACCELTABLE : HACCEL; var ACCELCOUNT : INTEGER; GROUPS : array of INTEGER)');
+ RegisterMethod('Procedure SETOLE2MENUHANDLE( HANDLE : HMENU)');
+ RegisterProperty('AUTOMERGE', 'BOOLEAN', iptrw);
+ end;
+end;
+
+procedure SIRegisterTMENU(CL: TPSPascalCompiler);
+begin
+ With cl.AddClassN(Cl.FindClass('TCOMPONENT'),'TMENU') do
+ begin
+ RegisterMethod('Constructor CREATE( AOWNER : TCOMPONENT)');
+ RegisterMethod('Function DISPATCHCOMMAND( ACOMMAND : WORD) : BOOLEAN');
+ RegisterMethod('Function DISPATCHPOPUP( AHANDLE : HMENU) : BOOLEAN');
+ RegisterMethod('Function FINDITEM( VALUE : INTEGER; KIND : TFINDITEMKIND) : TMENUITEM');
+ RegisterMethod('Function GETHELPCONTEXT( VALUE : INTEGER; BYCOMMAND : BOOLEAN) : THELPCONTEXT');
+ RegisterProperty('IMAGES', 'TCUSTOMIMAGELIST', iptrw);
+ RegisterMethod('Function ISRIGHTTOLEFT : BOOLEAN');
+ RegisterMethod('Procedure PARENTBIDIMODECHANGED( ACONTROL : TOBJECT)');
+ RegisterMethod('Procedure PROCESSMENUCHAR( var MESSAGE : TWMMENUCHAR)');
+ RegisterProperty('AUTOHOTKEYS', 'TMENUAUTOFLAG', iptrw);
+ RegisterProperty('AUTOLINEREDUCTION', 'TMENUAUTOFLAG', iptrw);
+ RegisterProperty('BIDIMODE', 'TBIDIMODE', iptrw);
+ RegisterProperty('HANDLE', 'HMENU', iptr);
+ RegisterProperty('OWNERDRAW', 'BOOLEAN', iptrw);
+ RegisterProperty('PARENTBIDIMODE', 'BOOLEAN', iptrw);
+ RegisterProperty('WINDOWHANDLE', 'HWND', iptrw);
+ RegisterProperty('ITEMS', 'TMENUITEM', iptr);
+ end;
+end;
+
+procedure SIRegisterTMENUITEM(CL: TPSPascalCompiler);
+begin
+ With cl.AddClassN(Cl.FindClass('TCOMPONENT'),'TMENUITEM') do
+ begin
+ RegisterMethod('Constructor CREATE( AOWNER : TCOMPONENT)');
+ RegisterMethod('Procedure INITIATEACTION');
+ RegisterMethod('Procedure INSERT( INDEX : INTEGER; ITEM : TMENUITEM)');
+ RegisterMethod('Procedure DELETE( INDEX : INTEGER)');
+ RegisterMethod('Procedure CLEAR');
+ RegisterMethod('Procedure CLICK');
+ RegisterMethod('Function FIND( ACAPTION : String) : TMENUITEM');
+ RegisterMethod('Function INDEXOF( ITEM : TMENUITEM) : INTEGER');
+ RegisterMethod('Function ISLINE : BOOLEAN');
+ RegisterMethod('Function GETIMAGELIST : TCUSTOMIMAGELIST');
+ RegisterMethod('Function GETPARENTCOMPONENT : TCOMPONENT');
+ RegisterMethod('Function GETPARENTMENU : TMENU');
+ RegisterMethod('Function HASPARENT : BOOLEAN');
+ RegisterMethod('Function NEWTOPLINE : INTEGER');
+ RegisterMethod('Function NEWBOTTOMLINE : INTEGER');
+ RegisterMethod('Function INSERTNEWLINEBEFORE( AITEM : TMENUITEM) : INTEGER');
+ RegisterMethod('Function INSERTNEWLINEAFTER( AITEM : TMENUITEM) : INTEGER');
+ RegisterMethod('Procedure ADD( ITEM : TMENUITEM)');
+ RegisterMethod('Procedure REMOVE( ITEM : TMENUITEM)');
+ RegisterMethod('Function RETHINKHOTKEYS : BOOLEAN');
+ RegisterMethod('Function RETHINKLINES : BOOLEAN');
+ RegisterProperty('COMMAND', 'WORD', iptr);
+ RegisterProperty('HANDLE', 'HMENU', iptr);
+ RegisterProperty('COUNT', 'INTEGER', iptr);
+ RegisterProperty('ITEMS', 'TMENUITEM INTEGER', iptr);
+ RegisterProperty('MENUINDEX', 'INTEGER', iptrw);
+ RegisterProperty('PARENT', 'TMENUITEM', iptr);
+ {$IFDEF DELPHI5UP}
+ RegisterProperty('ACTION', 'TBASICACTION', iptrw);
+ {$ENDIF}
+ RegisterProperty('AUTOHOTKEYS', 'TMENUITEMAUTOFLAG', iptrw);
+ RegisterProperty('AUTOLINEREDUCTION', 'TMENUITEMAUTOFLAG', iptrw);
+ RegisterProperty('BITMAP', 'TBITMAP', iptrw);
+ RegisterProperty('CAPTION', 'String', iptrw);
+ RegisterProperty('CHECKED', 'BOOLEAN', iptrw);
+ RegisterProperty('SUBMENUIMAGES', 'TCUSTOMIMAGELIST', iptrw);
+ RegisterProperty('DEFAULT', 'BOOLEAN', iptrw);
+ RegisterProperty('ENABLED', 'BOOLEAN', iptrw);
+ RegisterProperty('GROUPINDEX', 'BYTE', iptrw);
+ RegisterProperty('HELPCONTEXT', 'THELPCONTEXT', iptrw);
+ RegisterProperty('HINT', 'String', iptrw);
+ RegisterProperty('IMAGEINDEX', 'TIMAGEINDEX', iptrw);
+ RegisterProperty('RADIOITEM', 'BOOLEAN', iptrw);
+ RegisterProperty('SHORTCUT', 'TSHORTCUT', iptrw);
+ RegisterProperty('VISIBLE', 'BOOLEAN', iptrw);
+ RegisterProperty('ONCLICK', 'TNOTIFYEVENT', iptrw);
+ {$IFNDEF FPC} RegisterProperty('ONDRAWITEM', 'TMENUDRAWITEMEVENT', iptrw);
+ RegisterProperty('ONADVANCEDDRAWITEM', 'TADVANCEDMENUDRAWITEMEVENT', iptrw);
+ RegisterProperty('ONMEASUREITEM', 'TMENUMEASUREITEMEVENT', iptrw);{$ENDIF}
+ end;
+end;
+
+procedure SIRegister_Menus(Cl: TPSPascalCompiler);
+begin
+ Cl.AddTypeS('HMenu', 'Cardinal');
+ Cl.AddTypeS('HACCEL', 'Cardinal');
+
+ cl.addClassN(cl.FindClass('EXCEPTION'),'EMENUERROR');
+ Cl.addTypeS('TMENUBREAK', '( MBNONE, MBBREAK, MBBARBREAK )');
+{$IFNDEF FPC}
+ Cl.addTypeS('TMENUDRAWITEMEVENT', 'Procedure ( SENDER : TOBJECT; ACANVAS : TC'
+ +'ANVAS; ARECT : TRECT; SELECTED : BOOLEAN)');
+ Cl.addTypeS('TADVANCEDMENUDRAWITEMEVENT', 'Procedure ( SENDER : TOBJECT; ACAN'
+ +'VAS : TCANVAS; ARECT : TRECT; STATE : TOWNERDRAWSTATE)');
+ Cl.addTypeS('TMENUMEASUREITEMEVENT', 'Procedure ( SENDER : TOBJECT; ACANVAS :'
+ +' TCANVAS; var WIDTH, HEIGHT : INTEGER)');
+{$ENDIF}
+ Cl.addTypeS('TMENUITEMAUTOFLAG', '( MAAUTOMATIC, MAMANUAL, MAPARENT )');
+ Cl.AddTypeS('TMenuAutoFlag', 'TMENUITEMAUTOFLAG');
+ Cl.addTypeS('TSHORTCUT', 'WORD');
+ cl.addClassN(cl.FindClass('TACTIONLINK'),'TMENUACTIONLINK');
+ SIRegisterTMENUITEM(Cl);
+ Cl.addTypeS('TMENUCHANGEEVENT', 'Procedure ( SENDER : TOBJECT; SOURCE : TMENU'
+ +'ITEM; REBUILD : BOOLEAN)');
+ Cl.addTypeS('TFINDITEMKIND', '( FKCOMMAND, FKHANDLE, FKSHORTCUT )');
+ SIRegisterTMENU(Cl);
+ SIRegisterTMAINMENU(Cl);
+ Cl.addTypeS('TPOPUPALIGNMENT', '( PALEFT, PARIGHT, PACENTER )');
+ Cl.addTypeS('TTRACKBUTTON', '( TBRIGHTBUTTON, TBLEFTBUTTON )');
+ Cl.addTypeS('TMENUANIMATIONS', '( MALEFTTORIGHT, MARIGHTTOLEFT, MATOPTOBOTTOM'
+ +', MABOTTOMTOTOP, MANONE )');
+ Cl.addTypeS('TMENUANIMATION', 'set of TMENUANIMATIONS');
+ SIRegisterTPOPUPMENU(Cl);
+ SIRegisterTPOPUPLIST(Cl);
+ SIRegisterTMENUITEMSTACK(Cl);
+ Cl.addTypeS('TCMENUITEM', 'TMENUITEM');
+{$IFNDEF FPC}
+//TODO: it should work,but somehow TShiftState is not defined
+ Cl.AddDelphiFunction('Function SHORTCUT( KEY : WORD; SHIFT : TSHIFTSTATE) : T'
+ +'SHORTCUT');
+ Cl.AddDelphiFunction('Procedure SHORTCUTTOKEY( SHORTCUT : TSHORTCUT; var KEY '
+ +': WORD; var SHIFT : TSHIFTSTATE)');
+{$ENDIF}
+ Cl.AddDelphiFunction('Function SHORTCUTTOTEXT( SHORTCUT : TSHORTCUT) : String'
+ +'');
+ Cl.AddDelphiFunction('Function TEXTTOSHORTCUT( TEXT : String) : TSHORTCUT');
+ Cl.AddDelphiFunction('Function NEWMENU( OWNER : TCOMPONENT; const ANAME : STR'
+ +'ING; ITEMS : array of TMenuItem) : TMAINMENU');
+ Cl.AddDelphiFunction('Function NEWPOPUPMENU( OWNER : TCOMPONENT; const ANAME '
+ +': String; ALIGNMENT : TPOPUPALIGNMENT; AUTOPOPUP : BOOLEAN; const ITEMS : array of '
+ +'TCMENUITEM) : TPOPUPMENU');
+ Cl.AddDelphiFunction('Function NEWSUBMENU( const ACAPTION : String; HCTX : WO'
+ +'RD; const ANAME : String; ITEMS : array of TMenuItem; AENABLED : BOOLEAN) : TMENUITEM');
+ Cl.AddDelphiFunction('Function NEWITEM( const ACAPTION : String; ASHORTCUT : '
+ +'TSHORTCUT; ACHECKED, AENABLED : BOOLEAN; AONCLICK : TNOTIFYEVENT; HCTX : W'
+ +'ORD; const ANAME : String) : TMENUITEM');
+ Cl.AddDelphiFunction('Function NEWLINE : TMENUITEM');
+{$IFNDEF FPC}
+ Cl.AddDelphiFunction('Procedure DRAWMENUITEM( MENUITEM : TMENUITEM; ACANVAS :'
+ +' TCANVAS; ARECT : TRECT; STATE : TOWNERDRAWSTATE)');
+{$ENDIF}
+end;
+
+end.
diff --git a/Units/PascalScript/uPSC_std.pas b/Units/PascalScript/uPSC_std.pas
new file mode 100644
index 0000000..460ba64
--- /dev/null
+++ b/Units/PascalScript/uPSC_std.pas
@@ -0,0 +1,87 @@
+{ Compiletime TObject, TPersistent and TComponent definitions }
+unit uPSC_std;
+{$I PascalScript.inc}
+interface
+uses
+ uPSCompiler, uPSUtils;
+
+{
+ Will register files from:
+ System
+ Classes (Only TComponent and TPersistent)
+
+}
+
+procedure SIRegister_Std_TypesAndConsts(Cl: TPSPascalCompiler);
+procedure SIRegisterTObject(CL: TPSPascalCompiler);
+procedure SIRegisterTPersistent(Cl: TPSPascalCompiler);
+procedure SIRegisterTComponent(Cl: TPSPascalCompiler);
+
+procedure SIRegister_Std(Cl: TPSPascalCompiler);
+
+implementation
+
+procedure SIRegisterTObject(CL: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(nil, 'TObject') do
+ begin
+ RegisterMethod('constructor Create');
+ RegisterMethod('procedure Free');
+ end;
+end;
+
+procedure SIRegisterTPersistent(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TObject'), 'TPersistent') do
+ begin
+ RegisterMethod('procedure Assign(Source: TPersistent)');
+ end;
+end;
+
+procedure SIRegisterTComponent(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TPersistent'), 'TComponent') do
+ begin
+ RegisterMethod('function FindComponent(AName: String): TComponent;');
+ RegisterMethod('constructor Create(AOwner: TComponent); virtual;');
+
+ RegisterProperty('Owner', 'TComponent', iptRW);
+ RegisterMethod('procedure DestroyComponents');
+ RegisterMethod('procedure Destroying');
+ RegisterMethod('procedure FreeNotification(AComponent:TComponent)');
+ RegisterMethod('procedure InsertComponent(AComponent:TComponent)');
+ RegisterMethod('procedure RemoveComponent(AComponent:TComponent)');
+ RegisterProperty('Components', 'TComponent Integer', iptr);
+ RegisterProperty('ComponentCount', 'Integer', iptr);
+ RegisterProperty('ComponentIndex', 'Integer', iptrw);
+ RegisterProperty('ComponentState', 'Byte', iptr);
+ RegisterProperty('Designinfo', 'LongInt', iptrw);
+ RegisterProperty('Name', 'String', iptrw);
+ RegisterProperty('Tag', 'LongInt', iptrw);
+ end;
+end;
+
+
+
+
+procedure SIRegister_Std_TypesAndConsts(Cl: TPSPascalCompiler);
+begin
+ Cl.AddTypeS('TComponentStateE', '(csLoading, csReading, csWriting, csDestroying, csDesigning, csAncestor, csUpdating, csFixups, csFreeNotification, csInline, csDesignInstance)');
+ cl.AddTypeS('TComponentState', 'set of TComponentStateE');
+ Cl.AddTypeS('TRect', 'record Left, Top, Right, Bottom: Integer; end;');
+end;
+
+procedure SIRegister_Std(Cl: TPSPascalCompiler);
+begin
+ SIRegister_Std_TypesAndConsts(Cl);
+ SIRegisterTObject(CL);
+ SIRegisterTPersistent(Cl);
+ SIRegisterTComponent(Cl);
+end;
+
+// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl)
+
+
+End.
+
+
diff --git a/Units/PascalScript/uPSC_stdctrls.pas b/Units/PascalScript/uPSC_stdctrls.pas
new file mode 100644
index 0000000..52ff4bc
--- /dev/null
+++ b/Units/PascalScript/uPSC_stdctrls.pas
@@ -0,0 +1,633 @@
+{ Compiletime STDCtrls support }
+unit uPSC_stdctrls;
+
+{$I PascalScript.inc}
+interface
+uses
+ uPSCompiler, uPSUtils;
+
+{
+ Will register files from:
+ stdctrls
+
+Requires:
+ STD, classes, controls and graphics
+}
+
+procedure SIRegister_StdCtrls_TypesAndConsts(cl: TPSPascalCompiler);
+
+
+
+procedure SIRegisterTCUSTOMGROUPBOX(Cl: TPSPascalCompiler);
+procedure SIRegisterTGROUPBOX(Cl: TPSPascalCompiler);
+procedure SIRegisterTCUSTOMLABEL(Cl: TPSPascalCompiler);
+procedure SIRegisterTLABEL(Cl: TPSPascalCompiler);
+procedure SIRegisterTCUSTOMEDIT(Cl: TPSPascalCompiler);
+procedure SIRegisterTEDIT(Cl: TPSPascalCompiler);
+procedure SIRegisterTCUSTOMMEMO(Cl: TPSPascalCompiler);
+procedure SIRegisterTMEMO(Cl: TPSPascalCompiler);
+procedure SIRegisterTCUSTOMCOMBOBOX(Cl: TPSPascalCompiler);
+procedure SIRegisterTCOMBOBOX(Cl: TPSPascalCompiler);
+procedure SIRegisterTBUTTONCONTROL(Cl: TPSPascalCompiler);
+procedure SIRegisterTBUTTON(Cl: TPSPascalCompiler);
+procedure SIRegisterTCUSTOMCHECKBOX(Cl: TPSPascalCompiler);
+procedure SIRegisterTCHECKBOX(Cl: TPSPascalCompiler);
+procedure SIRegisterTRADIOBUTTON(Cl: TPSPascalCompiler);
+procedure SIRegisterTCUSTOMLISTBOX(Cl: TPSPascalCompiler);
+procedure SIRegisterTLISTBOX(Cl: TPSPascalCompiler);
+procedure SIRegisterTSCROLLBAR(Cl: TPSPascalCompiler);
+
+procedure SIRegister_StdCtrls(cl: TPSPascalCompiler);
+
+
+implementation
+
+procedure SIRegisterTCUSTOMGROUPBOX(Cl: TPSPascalCompiler);
+begin
+ Cl.AddClassN(cl.FindClass('TCUSTOMCONTROL'), 'TCUSTOMGROUPBOX');
+end;
+
+
+procedure SIRegisterTGROUPBOX(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TCUSTOMGROUPBOX'), 'TGROUPBOX') do
+ begin
+ RegisterProperty('CAPTION', 'String', iptrw);
+ RegisterProperty('COLOR', 'TColor', iptrw);
+ RegisterProperty('FONT', 'TFont', iptrw);
+ RegisterProperty('PARENTCOLOR', 'Boolean', iptrw);
+ RegisterProperty('PARENTFONT', 'Boolean', iptrw);
+ RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONENTER', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw);
+
+ {$IFNDEF PS_MINIVCL}
+ RegisterProperty('CTL3D', 'Boolean', iptrw);
+ RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
+ RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
+ RegisterProperty('PARENTCTL3D', 'Boolean', iptrw);
+ RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
+ RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw);
+ RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
+ RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
+ RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
+ RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw);
+ RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw);
+ RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw);
+ RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
+ {$ENDIF}
+ end;
+end;
+
+
+
+
+
+procedure SIRegisterTCUSTOMLABEL(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TGRAPHICCONTROL'), 'TCUSTOMLABEL') do
+ begin
+ {$IFNDEF PS_MINIVCL}
+{$IFNDEF CLX}
+ RegisterProperty('CANVAS', 'TCANVAS', iptr);
+{$ENDIF}
+ {$ENDIF}
+ end;
+end;
+
+
+procedure SIRegisterTLABEL(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TCUSTOMLABEL'), 'TLABEL') do
+ begin
+ RegisterProperty('ALIGNMENT', 'TAlignment', iptrw);
+ RegisterProperty('AUTOSIZE', 'Boolean', iptrw);
+ RegisterProperty('CAPTION', 'String', iptrw);
+ RegisterProperty('COLOR', 'TColor', iptrw);
+ RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
+ RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
+ RegisterProperty('FOCUSCONTROL', 'TWinControl', iptrw);
+ RegisterProperty('FONT', 'TFont', iptrw);
+ RegisterProperty('LAYOUT', 'TTextLayout', iptrw);
+ RegisterProperty('PARENTCOLOR', 'Boolean', iptrw);
+ RegisterProperty('PARENTFONT', 'Boolean', iptrw);
+ RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
+ RegisterProperty('SHOWACCELCHAR', 'Boolean', iptrw);
+ RegisterProperty('TRANSPARENT', 'Boolean', iptrw);
+ RegisterProperty('WORDWRAP', 'Boolean', iptrw);
+ RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
+ RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
+ RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
+ RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw);
+ RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw);
+ RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw);
+ RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
+ end;
+end;
+
+
+
+
+
+
+
+procedure SIRegisterTCUSTOMEDIT(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TWINCONTROL'), 'TCUSTOMEDIT') do
+ begin
+ RegisterMethod('procedure CLEAR');
+ RegisterMethod('procedure CLEARSELECTION');
+ RegisterMethod('procedure SELECTALL');
+ RegisterProperty('MODIFIED', 'BOOLEAN', iptrw);
+ RegisterProperty('SELLENGTH', 'INTEGER', iptrw);
+ RegisterProperty('SELSTART', 'INTEGER', iptrw);
+ RegisterProperty('SELTEXT', 'String', iptrw);
+ RegisterProperty('TEXT', 'String', iptrw);
+
+ {$IFNDEF PS_MINIVCL}
+ RegisterMethod('procedure COPYTOCLIPBOARD');
+ RegisterMethod('procedure CUTTOCLIPBOARD');
+ RegisterMethod('procedure PASTEFROMCLIPBOARD');
+ RegisterMethod('function GETSELTEXTBUF(BUFFER:PCHAR;BUFSIZE:INTEGER):INTEGER');
+ RegisterMethod('procedure SETSELTEXTBUF(BUFFER:PCHAR)');
+ {$ENDIF}
+ end;
+end;
+
+
+
+
+procedure SIRegisterTEDIT(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TCUSTOMEDIT'), 'TEDIT') do
+ begin
+ RegisterProperty('AUTOSELECT', 'Boolean', iptrw);
+ RegisterProperty('AUTOSIZE', 'Boolean', iptrw);
+ RegisterProperty('BORDERSTYLE', 'TBorderStyle', iptrw);
+ RegisterProperty('CHARCASE', 'TEditCharCase', iptrw);
+ RegisterProperty('COLOR', 'TColor', iptrw);
+ RegisterProperty('FONT', 'TFont', iptrw);
+ RegisterProperty('HIDESELECTION', 'Boolean', iptrw);
+ RegisterProperty('MAXLENGTH', 'Integer', iptrw);
+ RegisterProperty('PARENTCOLOR', 'Boolean', iptrw);
+ RegisterProperty('PARENTFONT', 'Boolean', iptrw);
+ RegisterProperty('PASSWORDCHAR', 'Char', iptrw);
+ RegisterProperty('READONLY', 'Boolean', iptrw);
+ RegisterProperty('TEXT', 'String', iptrw);
+ RegisterProperty('ONCHANGE', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONENTER', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONKEYDOWN', 'TKeyEvent', iptrw);
+ RegisterProperty('ONKEYPRESS', 'TKeyPressEvent', iptrw);
+ RegisterProperty('ONKEYUP', 'TKeyEvent', iptrw);
+
+ {$IFNDEF PS_MINIVCL}
+ RegisterProperty('CTL3D', 'Boolean', iptrw);
+ RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
+ RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
+ RegisterProperty('OEMCONVERT', 'Boolean', iptrw);
+ RegisterProperty('PARENTCTL3D', 'Boolean', iptrw);
+ RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
+ RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw);
+ RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
+ RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
+ RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
+ RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw);
+ RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw);
+ RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw);
+ RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
+ {$ENDIF}
+ end;
+end;
+
+
+
+
+procedure SIRegisterTCUSTOMMEMO(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TCUSTOMEDIT'), 'TCUSTOMMEMO') do
+ begin
+ {$IFNDEF CLX}
+ RegisterProperty('LINES', 'TSTRINGS', iptrw);
+ {$ENDIF}
+ end;
+end;
+
+
+procedure SIRegisterTMEMO(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TCUSTOMMEMO'), 'TMEMO') do
+ begin
+ {$IFDEF CLX}
+ RegisterProperty('LINES', 'TSTRINGS', iptrw);
+ {$ENDIF}
+ RegisterProperty('ALIGNMENT', 'TAlignment', iptrw);
+ RegisterProperty('BORDERSTYLE', 'TBorderStyle', iptrw);
+ RegisterProperty('COLOR', 'TColor', iptrw);
+ RegisterProperty('FONT', 'TFont', iptrw);
+ RegisterProperty('HIDESELECTION', 'Boolean', iptrw);
+ RegisterProperty('MAXLENGTH', 'Integer', iptrw);
+ RegisterProperty('PARENTCOLOR', 'Boolean', iptrw);
+ RegisterProperty('PARENTFONT', 'Boolean', iptrw);
+ RegisterProperty('READONLY', 'Boolean', iptrw);
+ RegisterProperty('SCROLLBARS', 'TScrollStyle', iptrw);
+ RegisterProperty('WANTRETURNS', 'Boolean', iptrw);
+ RegisterProperty('WANTTABS', 'Boolean', iptrw);
+ RegisterProperty('WORDWRAP', 'Boolean', iptrw);
+ RegisterProperty('ONCHANGE', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONENTER', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONKEYDOWN', 'TKeyEvent', iptrw);
+ RegisterProperty('ONKEYPRESS', 'TKeyPressEvent', iptrw);
+ RegisterProperty('ONKEYUP', 'TKeyEvent', iptrw);
+
+ {$IFNDEF PS_MINIVCL}
+ RegisterProperty('CTL3D', 'Boolean', iptrw);
+ RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
+ RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
+ RegisterProperty('OEMCONVERT', 'Boolean', iptrw);
+ RegisterProperty('PARENTCTL3D', 'Boolean', iptrw);
+ RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
+ RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw);
+ RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
+ RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
+ RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
+ RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw);
+ RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw);
+ RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw);
+ RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
+ {$ENDIF}
+ end;
+end;
+
+
+
+
+
+procedure SIRegisterTCUSTOMCOMBOBOX(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TWINCONTROL'), 'TCUSTOMCOMBOBOX') do
+ begin
+ RegisterProperty('DROPPEDDOWN', 'BOOLEAN', iptrw);
+ RegisterProperty('ITEMS', 'TSTRINGS', iptrw);
+ RegisterProperty('ITEMINDEX', 'INTEGER', iptrw);
+
+ {$IFNDEF PS_MINIVCL}
+ RegisterMethod('procedure CLEAR');
+ RegisterMethod('procedure SELECTALL');
+ RegisterProperty('CANVAS', 'TCANVAS', iptr);
+ RegisterProperty('SELLENGTH', 'INTEGER', iptrw);
+ RegisterProperty('SELSTART', 'INTEGER', iptrw);
+ RegisterProperty('SELTEXT', 'String', iptrw);
+ {$ENDIF}
+ end;
+end;
+
+
+procedure SIRegisterTCOMBOBOX(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TCUSTOMCOMBOBOX'), 'TCOMBOBOX') do
+ begin
+ RegisterProperty('STYLE', 'TComboBoxStyle', iptrw);
+ RegisterProperty('COLOR', 'TColor', iptrw);
+ RegisterProperty('DROPDOWNCOUNT', 'Integer', iptrw);
+ RegisterProperty('FONT', 'TFont', iptrw);
+ RegisterProperty('MAXLENGTH', 'Integer', iptrw);
+ RegisterProperty('PARENTCOLOR', 'Boolean', iptrw);
+ RegisterProperty('PARENTFONT', 'Boolean', iptrw);
+ RegisterProperty('SORTED', 'Boolean', iptrw);
+ RegisterProperty('TEXT', 'String', iptrw);
+ RegisterProperty('ONCHANGE', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONDROPDOWN', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONENTER', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONKEYDOWN', 'TKeyEvent', iptrw);
+ RegisterProperty('ONKEYPRESS', 'TKeyPressEvent', iptrw);
+ RegisterProperty('ONKEYUP', 'TKeyEvent', iptrw);
+
+ {$IFNDEF PS_MINIVCL}
+ RegisterProperty('CTL3D', 'Boolean', iptrw);
+ RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
+ RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
+ RegisterProperty('ITEMHEIGHT', 'Integer', iptrw);
+ RegisterProperty('PARENTCTL3D', 'Boolean', iptrw);
+ RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
+ RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw);
+ RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
+ RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
+ RegisterProperty('ONDRAWITEM', 'TDrawItemEvent', iptrw);
+ RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
+ RegisterProperty('ONMEASUREITEM', 'TMeasureItemEvent', iptrw);
+ RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
+ {$ENDIF}
+ end;
+end;
+
+
+
+procedure SIRegisterTBUTTONCONTROL(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TWINCONTROL'), 'TBUTTONCONTROL') do
+ begin
+ end;
+end;
+
+
+
+procedure SIRegisterTBUTTON(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TBUTTONCONTROL'), 'TBUTTON') do
+ begin
+ RegisterProperty('CANCEL', 'BOOLEAN', iptrw);
+ RegisterProperty('CAPTION', 'String', iptrw);
+ RegisterProperty('DEFAULT', 'BOOLEAN', iptrw);
+ RegisterProperty('FONT', 'TFont', iptrw);
+ RegisterProperty('MODALRESULT', 'LONGINT', iptrw);
+ RegisterProperty('PARENTFONT', 'Boolean', iptrw);
+ RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONENTER', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw);
+
+ {$IFNDEF PS_MINIVCL}
+ RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
+ RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
+ RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
+ RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw);
+ RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
+ RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
+ RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
+ RegisterProperty('ONKEYDOWN', 'TKeyEvent', iptrw);
+ RegisterProperty('ONKEYPRESS', 'TKeyPressEvent', iptrw);
+ RegisterProperty('ONKEYUP', 'TKeyEvent', iptrw);
+ RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw);
+ RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw);
+ RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw);
+ RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
+ {$ENDIF}
+ end;
+end;
+
+
+
+procedure SIRegisterTCUSTOMCHECKBOX(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TBUTTONCONTROL'), 'TCUSTOMCHECKBOX') do
+ begin
+ end;
+end;
+
+
+
+procedure SIRegisterTCHECKBOX(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TCUSTOMCHECKBOX'), 'TCHECKBOX') do
+ begin
+ RegisterProperty('ALIGNMENT', 'TAlignment', iptrw);
+ RegisterProperty('ALLOWGRAYED', 'Boolean', iptrw);
+ RegisterProperty('CAPTION', 'String', iptrw);
+ RegisterProperty('CHECKED', 'Boolean', iptrw);
+ RegisterProperty('COLOR', 'TColor', iptrw);
+ RegisterProperty('FONT', 'TFont', iptrw);
+ RegisterProperty('PARENTCOLOR', 'Boolean', iptrw);
+ RegisterProperty('PARENTFONT', 'Boolean', iptrw);
+ RegisterProperty('STATE', 'TCheckBoxState', iptrw);
+ RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONENTER', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw);
+
+ {$IFNDEF PS_MINIVCL}
+ RegisterProperty('CTL3D', 'Boolean', iptrw);
+ RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
+ RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
+ RegisterProperty('PARENTCTL3D', 'Boolean', iptrw);
+ RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
+ RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw);
+ RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
+ RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
+ RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
+ RegisterProperty('ONKEYDOWN', 'TKeyEvent', iptrw);
+ RegisterProperty('ONKEYPRESS', 'TKeyPressEvent', iptrw);
+ RegisterProperty('ONKEYUP', 'TKeyEvent', iptrw);
+ RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw);
+ RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw);
+ RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw);
+ RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
+ {$ENDIF}
+ end;
+end;
+
+
+
+
+
+procedure SIRegisterTRADIOBUTTON(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TBUTTONCONTROL'), 'TRADIOBUTTON') do
+ begin
+ RegisterProperty('ALIGNMENT', 'TALIGNMENT', iptrw);
+ RegisterProperty('CAPTION', 'String', iptrw);
+ RegisterProperty('CHECKED', 'BOOLEAN', iptrw);
+ RegisterProperty('COLOR', 'TColor', iptrw);
+ RegisterProperty('FONT', 'TFont', iptrw);
+ RegisterProperty('PARENTCOLOR', 'Boolean', iptrw);
+ RegisterProperty('PARENTFONT', 'Boolean', iptrw);
+ RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONENTER', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw);
+
+ {$IFNDEF PS_MINIVCL}
+ RegisterProperty('CTL3D', 'Boolean', iptrw);
+ RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
+ RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
+ RegisterProperty('PARENTCTL3D', 'Boolean', iptrw);
+ RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
+ RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw);
+ RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
+ RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
+ RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
+ RegisterProperty('ONKEYDOWN', 'TKeyEvent', iptrw);
+ RegisterProperty('ONKEYPRESS', 'TKeyPressEvent', iptrw);
+ RegisterProperty('ONKEYUP', 'TKeyEvent', iptrw);
+ RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw);
+ RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw);
+ RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw);
+ RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
+ {$ENDIF}
+ end;
+end;
+
+
+
+procedure SIRegisterTCUSTOMLISTBOX(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TWINCONTROL'), 'TCUSTOMLISTBOX') do
+ begin
+ RegisterProperty('ITEMS', 'TSTRINGS', iptrw);
+ RegisterProperty('ITEMINDEX', 'INTEGER', iptrw);
+ RegisterProperty('SELCOUNT', 'INTEGER', iptr);
+ RegisterProperty('SELECTED', 'BOOLEAN INTEGER', iptrw);
+
+ {$IFNDEF PS_MINIVCL}
+ RegisterMethod('procedure CLEAR');
+ RegisterMethod('function ITEMATPOS(POS:TPOINT;EXISTING:BOOLEAN):INTEGER');
+ RegisterMethod('function ITEMRECT(INDEX:INTEGER):TRECT');
+ RegisterProperty('CANVAS', 'TCANVAS', iptr);
+ RegisterProperty('TOPINDEX', 'INTEGER', iptrw);
+ {$ENDIF}
+ end;
+end;
+
+
+
+procedure SIRegisterTLISTBOX(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TCUSTOMLISTBOX'), 'TLISTBOX') do
+ begin
+ RegisterProperty('BORDERSTYLE', 'TBorderStyle', iptrw);
+ RegisterProperty('COLOR', 'TColor', iptrw);
+ RegisterProperty('FONT', 'TFont', iptrw);
+ RegisterProperty('MULTISELECT', 'Boolean', iptrw);
+ RegisterProperty('PARENTCOLOR', 'Boolean', iptrw);
+ RegisterProperty('PARENTFONT', 'Boolean', iptrw);
+ RegisterProperty('SORTED', 'Boolean', iptrw);
+ RegisterProperty('STYLE', 'TListBoxStyle', iptrw);
+ RegisterProperty('ONCLICK', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONDBLCLICK', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONENTER', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONKEYDOWN', 'TKeyEvent', iptrw);
+ RegisterProperty('ONKEYPRESS', 'TKeyPressEvent', iptrw);
+ RegisterProperty('ONKEYUP', 'TKeyEvent', iptrw);
+
+ {$IFNDEF PS_MINIVCL}
+ RegisterProperty('COLUMNS', 'Integer', iptrw);
+ RegisterProperty('CTL3D', 'Boolean', iptrw);
+ RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
+ RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
+ RegisterProperty('EXTENDEDSELECT', 'Boolean', iptrw);
+ RegisterProperty('INTEGRALHEIGHT', 'Boolean', iptrw);
+ RegisterProperty('ITEMHEIGHT', 'Integer', iptrw);
+ RegisterProperty('PARENTCTL3D', 'Boolean', iptrw);
+ RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
+ RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw);
+ RegisterProperty('TABWIDTH', 'Integer', iptrw);
+ RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
+ RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
+ RegisterProperty('ONDRAWITEM', 'TDrawItemEvent', iptrw);
+ RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
+ RegisterProperty('ONMEASUREITEM', 'TMeasureItemEvent', iptrw);
+ RegisterProperty('ONMOUSEDOWN', 'TMouseEvent', iptrw);
+ RegisterProperty('ONMOUSEMOVE', 'TMouseMoveEvent', iptrw);
+ RegisterProperty('ONMOUSEUP', 'TMouseEvent', iptrw);
+ RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
+ {$ENDIF}
+ end;
+end;
+
+
+
+
+
+
+procedure SIRegisterTSCROLLBAR(Cl: TPSPascalCompiler);
+begin
+ with Cl.AddClassN(cl.FindClass('TWINCONTROL'), 'TSCROLLBAR') do
+ begin
+ RegisterProperty('KIND', 'TSCROLLBARKIND', iptrw);
+ RegisterProperty('MAX', 'INTEGER', iptrw);
+ RegisterProperty('MIN', 'INTEGER', iptrw);
+ RegisterProperty('POSITION', 'INTEGER', iptrw);
+ RegisterProperty('ONCHANGE', 'TNOTIFYEVENT', iptrw);
+ RegisterProperty('ONENTER', 'TNotifyEvent', iptrw);
+ RegisterProperty('ONEXIT', 'TNotifyEvent', iptrw);
+
+ {$IFNDEF PS_MINIVCL}
+ RegisterMethod('procedure SETPARAMS(APOSITION,AMIN,AMAX:INTEGER)');
+ RegisterProperty('CTL3D', 'Boolean', iptrw);
+ RegisterProperty('DRAGCURSOR', 'Longint', iptrw);
+ RegisterProperty('DRAGMODE', 'TDragMode', iptrw);
+ RegisterProperty('LARGECHANGE', 'TSCROLLBARINC', iptrw);
+ RegisterProperty('PARENTCTL3D', 'Boolean', iptrw);
+ RegisterProperty('PARENTSHOWHINT', 'Boolean', iptrw);
+ RegisterProperty('POPUPMENU', 'TPopupMenu', iptrw);
+ RegisterProperty('SMALLCHANGE', 'TSCROLLBARINC', iptrw);
+ RegisterProperty('ONDRAGDROP', 'TDragDropEvent', iptrw);
+ RegisterProperty('ONDRAGOVER', 'TDragOverEvent', iptrw);
+ RegisterProperty('ONENDDRAG', 'TEndDragEvent', iptrw);
+ RegisterProperty('ONKEYDOWN', 'TKeyEvent', iptrw);
+ RegisterProperty('ONKEYPRESS', 'TKeyPressEvent', iptrw);
+ RegisterProperty('ONKEYUP', 'TKeyEvent', iptrw);
+ RegisterProperty('ONSCROLL', 'TSCROLLEVENT', iptrw);
+ RegisterProperty('ONSTARTDRAG', 'TStartDragEvent', iptrw);
+ {$ENDIF}
+ end;
+end;
+
+
+
+procedure SIRegister_StdCtrls_TypesAndConsts(cl: TPSPascalCompiler);
+begin
+ cl.AddTypeS('TEditCharCase', '(ecNormal, ecUpperCase, ecLowerCase)');
+ cl.AddTypeS('TScrollStyle', '(ssNone, ssHorizontal, ssVertical, ssBoth)');
+ cl.AddTypeS('TComboBoxStyle', '(csDropDown, csSimple, csDropDownList, csOwnerDrawFixed, csOwnerDrawVariable)');
+ cl.AddTypeS('TDrawItemEvent', 'procedure(Control: TWinControl; Index: Integer; Rect: TRect; State: Byte)');
+ cl.AddTypeS('TMeasureItemEvent', 'procedure(Control: TWinControl; Index: Integer; var Height: Integer)');
+ cl.AddTypeS('TCheckBoxState', '(cbUnchecked, cbChecked, cbGrayed)');
+ cl.AddTypeS('TListBoxStyle', '(lbStandard, lbOwnerDrawFixed, lbOwnerDrawVariable)');
+ cl.AddTypeS('TScrollCode', '(scLineUp, scLineDown, scPageUp, scPageDown, scPosition, scTrack, scTop, scBottom, scEndScroll)');
+ cl.AddTypeS('TScrollEvent', 'procedure(Sender: TObject; ScrollCode: TScrollCode;var ScrollPos: Integer)');
+
+ Cl.addTypeS('TEOwnerDrawState', '(odSelected, odGrayed, odDisabled, odChecked,'
+ +' odFocused, odDefault, odHotLight, odInactive, odNoAccel, odNoFocusRect,'
+ +' odReserved1, odReserved2, odComboBoxEdit)');
+ cl.AddTypeS('TTextLayout', '( tlTop, tlCenter, tlBottom )');
+ cl.AddTypeS('TOwnerDrawState', 'set of TEOwnerDrawState');
+end;
+
+
+procedure SIRegister_stdctrls(cl: TPSPascalCompiler);
+begin
+ SIRegister_StdCtrls_TypesAndConsts(cl);
+ {$IFNDEF PS_MINIVCL}
+ SIRegisterTCUSTOMGROUPBOX(Cl);
+ SIRegisterTGROUPBOX(Cl);
+ {$ENDIF}
+ SIRegisterTCUSTOMLABEL(Cl);
+ SIRegisterTLABEL(Cl);
+ SIRegisterTCUSTOMEDIT(Cl);
+ SIRegisterTEDIT(Cl);
+ SIRegisterTCUSTOMMEMO(Cl);
+ SIRegisterTMEMO(Cl);
+ SIRegisterTCUSTOMCOMBOBOX(Cl);
+ SIRegisterTCOMBOBOX(Cl);
+ SIRegisterTBUTTONCONTROL(Cl);
+ SIRegisterTBUTTON(Cl);
+ SIRegisterTCUSTOMCHECKBOX(Cl);
+ SIRegisterTCHECKBOX(Cl);
+ SIRegisterTRADIOBUTTON(Cl);
+ SIRegisterTCUSTOMLISTBOX(Cl);
+ SIRegisterTLISTBOX(Cl);
+ {$IFNDEF PS_MINIVCL}
+ SIRegisterTSCROLLBAR(Cl);
+ {$ENDIF}
+end;
+
+// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl)
+
+
+end.
+
+
+
+
+
diff --git a/Units/PascalScript/uPSCompiler.pas b/Units/PascalScript/uPSCompiler.pas
new file mode 100644
index 0000000..6329849
--- /dev/null
+++ b/Units/PascalScript/uPSCompiler.pas
@@ -0,0 +1,15397 @@
+unit uPSCompiler;
+{$I PascalScript.inc}
+interface
+uses
+ {$IFNDEF DELPHI3UP}{$IFNDEF PS_NOINTERFACES}{$IFNDEF LINUX}Windows, Ole2,{$ENDIF}
+ {$ENDIF}{$ENDIF}SysUtils, uPSUtils;
+
+
+type
+{$IFNDEF PS_NOINTERFACES}
+ TPSInterface = class;
+{$ENDIF}
+
+ TPSParameterMode = (pmIn, pmOut, pmInOut);
+ TPSPascalCompiler = class;
+ TPSType = class;
+ TPSValue = class;
+ TPSParameters = class;
+
+ TPSSubOptType = (tMainBegin, tProcBegin, tSubBegin, tOneLiner, tifOneliner, tRepeat, tTry, tTryEnd
+ {$IFDEF PS_USESSUPPORT},tUnitInit, tUnitFinish {$ENDIF}); //nvds
+
+
+ {TPSExternalClass is used when external classes need to be called}
+ TPSCompileTimeClass = class;
+ TPSAttributes = class;
+ TPSAttribute = class;
+
+ EPSCompilerException = class(Exception) end;
+
+ TPSParameterDecl = class(TObject)
+ private
+ FName: tbtString;
+ FOrgName: tbtString;
+ FMode: TPSParameterMode;
+ FType: TPSType;
+ {$IFDEF PS_USESSUPPORT}
+ FDeclareUnit: tbtString;
+ {$ENDIF}
+ FDeclarePos: Cardinal;
+ FDeclareRow: Cardinal;
+ FDeclareCol: Cardinal;
+ procedure SetName(const s: tbtString);
+ public
+
+ property Name: tbtString read FName;
+
+ property OrgName: tbtString read FOrgName write SetName;
+
+ property aType: TPSType read FType write FType;
+
+ property Mode: TPSParameterMode read FMode write FMode;
+
+ {$IFDEF PS_USESSUPPORT}
+ property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit;
+ {$ENDIF}
+
+ property DeclarePos: Cardinal read FDeclarePos write FDeclarePos;
+
+ property DeclareRow: Cardinal read FDeclareRow write FDeclareRow;
+
+ property DeclareCol: Cardinal read FDeclareCol write FDeclareCol;
+
+ end;
+
+
+ TPSParametersDecl = class(TObject)
+ private
+ FParams: TPSList;
+ FResult: TPSType;
+ function GetParam(I: Longint): TPSParameterDecl;
+ function GetParamCount: Longint;
+ public
+
+ property Params[I: Longint]: TPSParameterDecl read GetParam;
+
+ property ParamCount: Longint read GetParamCount;
+
+
+ function AddParam: TPSParameterDecl;
+
+ procedure DeleteParam(I: Longint);
+
+
+ property Result : TPSType read FResult write FResult;
+
+
+ procedure Assign(Params: TPSParametersDecl);
+
+
+ function Same(d: TPSParametersDecl): boolean;
+
+
+ constructor Create;
+
+ destructor Destroy; override;
+ end;
+
+
+ TPSRegProc = class(TObject)
+ private
+ FNameHash: Longint;
+ FName: tbtString;
+ FDecl: TPSParametersDecl;
+ FExportName: Boolean;
+ FImportDecl: tbtString;
+ FOrgName: tbtString;
+ procedure SetName(const Value: tbtString);
+ public
+
+ property OrgName: tbtString read FOrgName write FOrgName;
+
+ property Name: tbtString read FName write SetName;
+
+ property NameHash: Longint read FNameHash;
+
+ property Decl: TPSParametersDecl read FDecl;
+
+ property ExportName: Boolean read FExportName write FExportName;
+
+ property ImportDecl: tbtString read FImportDecl write FImportDecl;
+
+
+ constructor Create;
+
+ destructor Destroy; override;
+ end;
+
+ PIFPSRegProc = TPSRegProc;
+
+ PIfRVariant = ^TIfRVariant;
+
+ TIfRVariant = record
+
+ FType: TPSType;
+ case Byte of
+ 1: (tu8: TbtU8);
+ 2: (tS8: TbtS8);
+ 3: (tu16: TbtU16);
+ 4: (ts16: TbtS16);
+ 5: (tu32: TbtU32);
+ 6: (ts32: TbtS32);
+ 7: (tsingle: TbtSingle);
+ 8: (tdouble: TbtDouble);
+ 9: (textended: TbtExtended);
+ 11: (tcurrency: tbtCurrency);
+ 10: (tstring: Pointer);
+ {$IFNDEF PS_NOINT64}
+ 17: (ts64: Tbts64);
+ {$ENDIF}
+ 19: (tchar: tbtChar);
+ {$IFNDEF PS_NOWIDESTRING}
+ 18: (twidestring: Pointer);
+ 20: (twidechar: tbtwidechar);
+ {$ENDIF}
+ 21: (ttype: TPSType);
+ 22: (tunistring: Pointer);
+ end;
+
+ TPSRecordFieldTypeDef = class(TObject)
+ private
+ FFieldOrgName: tbtString;
+ FFieldName: tbtString;
+ FFieldNameHash: Longint;
+ FType: TPSType;
+ procedure SetFieldOrgName(const Value: tbtString);
+ public
+
+ property FieldOrgName: tbtString read FFieldOrgName write SetFieldOrgName;
+
+ property FieldName: tbtString read FFieldName;
+
+ property FieldNameHash: Longint read FFieldNameHash;
+
+ property aType: TPSType read FType write FType;
+ end;
+
+ PIFPSRecordFieldTypeDef = TPSRecordFieldTypeDef;
+
+ TPSType = class(TObject)
+ private
+ FNameHash: Longint;
+ FName: tbtString;
+ FBaseType: TPSBaseType;
+ {$IFDEF PS_USESSUPPORT}
+ FDeclareUnit: tbtString;
+ {$ENDIF}
+ FDeclarePos: Cardinal;
+ FDeclareRow: Cardinal;
+ FDeclareCol: Cardinal;
+ FUsed: Boolean;
+ FExportName: Boolean;
+ FOriginalName: tbtString;
+ FAttributes: TPSAttributes;
+ FFinalTypeNo: cardinal;
+ procedure SetName(const Value: tbtString);
+ public
+
+ constructor Create;
+
+ destructor Destroy; override;
+
+ property Attributes: TPSAttributes read FAttributes;
+
+
+ property FinalTypeNo: cardinal read FFinalTypeNo;
+
+
+ property OriginalName: tbtString read FOriginalName write FOriginalName;
+
+ property Name: tbtString read FName write SetName;
+
+ property NameHash: Longint read FNameHash;
+
+ property BaseType: TPSBaseType read FBaseType write FBaseType;
+
+ {$IFDEF PS_USESSUPPORT}
+ property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit;
+ {$ENDIF}
+
+ property DeclarePos: Cardinal read FDeclarePos write FDeclarePos;
+
+ property DeclareRow: Cardinal read FDeclareRow write FDeclareRow;
+
+ property DeclareCol: Cardinal read FDeclareCol write FDeclareCol;
+
+ property Used: Boolean read FUsed;
+
+ property ExportName: Boolean read FExportName write FExportName;
+
+ procedure Use;
+ end;
+
+
+ PIFPSType = TPSType;
+
+ TPSVariantType = class(TPSType)
+ private
+ public
+ function GetDynInvokeProcNo(Owner: TPSPascalCompiler; const Name: tbtString; Params: TPSParameters): Cardinal; virtual;
+ function GetDynIvokeSelfType(Owner: TPSPascalCompiler): TPSType; virtual;
+ function GetDynInvokeParamType(Owner: TPSPascalCompiler): TPSType; virtual;
+ function GetDynIvokeResulType(Owner: TPSPascalCompiler): TPSType; virtual;
+ end;
+
+
+ TPSRecordType = class(TPSType)
+ private
+ FRecordSubVals: TPSList;
+ public
+
+ constructor Create;
+
+ destructor Destroy; override;
+
+ function RecValCount: Longint;
+
+ function RecVal(I: Longint): PIFPSRecordFieldTypeDef;
+
+ function AddRecVal: PIFPSRecordFieldTypeDef;
+ end;
+
+ TPSClassType = class(TPSType)
+ private
+ FCL: TPSCompiletimeClass;
+ public
+
+ property Cl: TPSCompileTimeClass read FCL write FCL;
+ end;
+ TPSExternalClass = class;
+ TPSUndefinedClassType = class(TPSType)
+ private
+ FExtClass: TPSExternalClass;
+ public
+ property ExtClass: TPSExternalClass read FExtClass write FExtClass;
+ end;
+{$IFNDEF PS_NOINTERFACES}
+
+ TPSInterfaceType = class(TPSType)
+ private
+ FIntf: TPSInterface;
+ public
+
+ property Intf: TPSInterface read FIntf write FIntf;
+ end;
+{$ENDIF}
+
+
+ TPSProceduralType = class(TPSType)
+ private
+ FProcDef: TPSParametersDecl;
+ public
+
+ property ProcDef: TPSParametersDecl read FProcDef;
+
+ constructor Create;
+
+ destructor Destroy; override;
+ end;
+
+ TPSArrayType = class(TPSType)
+ private
+ FArrayTypeNo: TPSType;
+ public
+
+ property ArrayTypeNo: TPSType read FArrayTypeNo write FArrayTypeNo;
+ end;
+
+ TPSStaticArrayType = class(TPSArrayType)
+ private
+ FStartOffset: Longint;
+ FLength: Cardinal;
+ public
+
+ property StartOffset: Longint read FStartOffset write FStartOffset;
+
+ property Length: Cardinal read FLength write FLength;
+ end;
+
+ TPSSetType = class(TPSType)
+ private
+ FSetType: TPSType;
+ function GetByteSize: Longint;
+ function GetBitSize: Longint;
+ public
+
+ property SetType: TPSType read FSetType write FSetType;
+
+ property ByteSize: Longint read GetByteSize;
+
+ property BitSize: Longint read GetBitSize;
+ end;
+
+ TPSTypeLink = class(TPSType)
+ private
+ FLinkTypeNo: TPSType;
+ public
+
+ property LinkTypeNo: TPSType read FLinkTypeNo write FLinkTypeNo;
+ end;
+
+ TPSEnumType = class(TPSType)
+ private
+ FHighValue: Cardinal;
+ public
+
+ property HighValue: Cardinal read FHighValue write FHighValue;
+ end;
+
+
+ TPSProcedure = class(TObject)
+ private
+ FAttributes: TPSAttributes;
+ public
+
+ property Attributes: TPSAttributes read FAttributes;
+
+
+ constructor Create;
+
+ destructor Destroy; override;
+ end;
+
+ TPSAttributeType = class;
+
+ TPSAttributeTypeField = class(TObject)
+ private
+ FOwner: TPSAttributeType;
+ FFieldOrgName: tbtString;
+ FFieldName: tbtString;
+ FFieldNameHash: Longint;
+ FFieldType: TPSType;
+ FHidden: Boolean;
+ procedure SetFieldOrgName(const Value: tbtString);
+ public
+
+ constructor Create(AOwner: TPSAttributeType);
+
+ property Owner: TPSAttributeType read FOwner;
+
+ property FieldOrgName: tbtString read FFieldOrgName write SetFieldOrgName;
+
+ property FieldName: tbtString read FFieldName;
+
+ property FieldNameHash: Longint read FFieldNameHash;
+
+ property FieldType: TPSType read FFieldType write FFieldType;
+
+ property Hidden: Boolean read FHidden write FHidden;
+ end;
+
+ TPSApplyAttributeToType = function (Sender: TPSPascalCompiler; aType: TPSType; Attr: TPSAttribute): Boolean;
+
+ TPSApplyAttributeToProc = function (Sender: TPSPascalCompiler; aProc: TPSProcedure; Attr: TPSAttribute): Boolean;
+ { An attribute type }
+ TPSAttributeType = class(TPSType)
+ private
+ FFields: TPSList;
+ FName: tbtString;
+ FOrgname: tbtString;
+ FNameHash: Longint;
+ FAAProc: TPSApplyAttributeToProc;
+ FAAType: TPSApplyAttributeToType;
+ function GetField(I: Longint): TPSAttributeTypeField;
+ function GetFieldCount: Longint;
+ procedure SetName(const s: tbtString);
+ public
+
+ property OnApplyAttributeToType: TPSApplyAttributeToType read FAAType write FAAType;
+
+ property OnApplyAttributeToProc: TPSApplyAttributeToProc read FAAProc write FAAProc;
+
+ property Fields[i: Longint]: TPSAttributeTypeField read GetField;
+
+ property FieldCount: Longint read GetFieldCount;
+
+ procedure DeleteField(I: Longint);
+
+ function AddField: TPSAttributeTypeField;
+
+ property Name: tbtString read FName;
+
+ property OrgName: tbtString read FOrgName write SetName;
+
+ property NameHash: Longint read FNameHash;
+
+ constructor Create;
+
+ destructor Destroy; override;
+ end;
+
+ TPSAttribute = class(TObject)
+ private
+ FAttribType: TPSAttributeType;
+ FValues: TPSList;
+ function GetValueCount: Longint;
+ function GetValue(I: Longint): PIfRVariant;
+ public
+
+ constructor Create(AttribType: TPSAttributeType);
+
+ procedure Assign(Item: TPSAttribute);
+
+ property AType: TPSAttributeType read FAttribType;
+
+ property Count: Longint read GetValueCount;
+
+ property Values[i: Longint]: PIfRVariant read GetValue; default;
+
+ procedure DeleteValue(i: Longint);
+
+ function AddValue(v: PIFRVariant): Longint;
+
+ destructor Destroy; override;
+ end;
+
+
+ TPSAttributes = class(TObject)
+ private
+ FItems: TPSList;
+ function GetCount: Longint;
+ function GetItem(I: Longint): TPSAttribute;
+ public
+
+ procedure Assign(attr: TPSAttributes; Move: Boolean);
+
+ property Count: Longint read GetCount;
+
+ property Items[i: Longint]: TPSAttribute read GetItem; default;
+
+ procedure Delete(i: Longint);
+
+ function Add(AttribType: TPSAttributeType): TPSAttribute;
+
+ function FindAttribute(const Name: tbtString): TPSAttribute;
+
+ constructor Create;
+
+ destructor Destroy; override;
+ end;
+
+
+ TPSProcVar = class(TObject)
+ private
+ FNameHash: Longint;
+ FName: tbtString;
+ FOrgName: tbtString;
+ FType: TPSType;
+ FUsed: Boolean;
+ {$IFDEF PS_USESSUPPORT}
+ FDeclareUnit: tbtString;
+ {$ENDIF}
+ FDeclarePos, FDeclareRow, FDeclareCol: Cardinal;
+ procedure SetName(const Value: tbtString);
+ public
+
+ property OrgName: tbtString read FOrgName write FOrgname;
+
+ property NameHash: Longint read FNameHash;
+
+ property Name: tbtString read FName write SetName;
+
+ property AType: TPSType read FType write FType;
+
+ property Used: Boolean read FUsed;
+
+ {$IFDEF PS_USESSUPPORT}
+ property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit;
+ {$ENDIF}
+
+ property DeclarePos: Cardinal read FDeclarePos write FDeclarePos;
+
+ property DeclareRow: Cardinal read FDeclareRow write FDeclareRow;
+
+ property DeclareCol: Cardinal read FDeclareCol write FDeclareCol;
+
+ procedure Use;
+ end;
+
+ PIFPSProcVar = TPSProcVar;
+
+ TPSExternalProcedure = class(TPSProcedure)
+ private
+ FRegProc: TPSRegProc;
+ public
+
+ property RegProc: TPSRegProc read FRegProc write FRegProc;
+ end;
+
+
+ TPSInternalProcedure = class(TPSProcedure)
+ private
+ FForwarded: Boolean;
+ FData: tbtString;
+ FNameHash: Longint;
+ FName: tbtString;
+ FDecl: TPSParametersDecl;
+ FProcVars: TPSList;
+ FUsed: Boolean;
+ FOutputDeclPosition: Cardinal;
+ FResultUsed: Boolean;
+ FLabels: TIfStringList;
+ FGotos: TIfStringList;
+ FDeclareRow: Cardinal;
+ {$IFDEF PS_USESSUPPORT}
+ FDeclareUnit: tbtString;
+ {$ENDIF}
+ FDeclarePos: Cardinal;
+ FDeclareCol: Cardinal;
+ FOriginalName: tbtString;
+ procedure SetName(const Value: tbtString);
+ public
+
+ constructor Create;
+
+ destructor Destroy; override;
+ {Attributes}
+
+
+ property Forwarded: Boolean read FForwarded write FForwarded;
+
+ property Data: tbtString read FData write FData;
+
+ property Decl: TPSParametersDecl read FDecl;
+
+ property OriginalName: tbtString read FOriginalName write FOriginalName;
+
+ property Name: tbtString read FName write SetName;
+
+ property NameHash: Longint read FNameHash;
+
+ property ProcVars: TPSList read FProcVars;
+
+ property Used: Boolean read FUsed;
+
+ {$IFDEF PS_USESSUPPORT}
+ property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit;
+ {$ENDIF}
+
+ property DeclarePos: Cardinal read FDeclarePos write FDeclarePos;
+
+ property DeclareRow: Cardinal read FDeclareRow write FDeclareRow;
+
+ property DeclareCol: Cardinal read FDeclareCol write FDeclareCol;
+
+ property OutputDeclPosition: Cardinal read FOutputDeclPosition write FOutputDeclPosition;
+
+ property ResultUsed: Boolean read FResultUsed;
+
+
+ property Labels: TIfStringList read FLabels;
+
+ property Gotos: TIfStringList read FGotos;
+
+ procedure Use;
+
+ procedure ResultUse;
+ end;
+
+ TPSVar = class(TObject)
+ private
+ FNameHash: Longint;
+ FOrgName: tbtString;
+ FName: tbtString;
+ FType: TPSType;
+ FUsed: Boolean;
+ FExportName: tbtString;
+ FDeclareRow: Cardinal;
+ {$IFDEF PS_USESSUPPORT}
+ FDeclareUnit: tbtString;
+ {$ENDIF}
+ FDeclarePos: Cardinal;
+ FDeclareCol: Cardinal;
+ FSaveAsPointer: Boolean;
+ procedure SetName(const Value: tbtString);
+ public
+
+ property SaveAsPointer: Boolean read FSaveAsPointer write FSaveAsPointer;
+
+ property ExportName: tbtString read FExportName write FExportName;
+
+ property Used: Boolean read FUsed;
+
+ property aType: TPSType read FType write FType;
+
+ property OrgName: tbtString read FOrgName write FOrgName;
+
+ property Name: tbtString read FName write SetName;
+
+ property NameHash: Longint read FNameHash;
+
+ {$IFDEF PS_USESSUPPORT}
+ property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit;
+ {$ENDIF}
+
+ property DeclarePos: Cardinal read FDeclarePos write FDeclarePos;
+
+ property DeclareRow: Cardinal read FDeclareRow write FDeclareRow;
+
+ property DeclareCol: Cardinal read FDeclareCol write FDeclareCol;
+
+ procedure Use;
+ end;
+
+ PIFPSVar = TPSVar;
+
+ TPSConstant = class(TObject)
+ private
+
+ FOrgName: tbtString;
+
+ FNameHash: Longint;
+
+ FName: tbtString;
+
+ FDeclareRow: Cardinal;
+ {$IFDEF PS_USESSUPPORT}
+ FDeclareUnit: tbtString;
+ {$ENDIF}
+ FDeclarePos: Cardinal;
+ FDeclareCol: Cardinal;
+
+ FValue: PIfRVariant;
+ procedure SetName(const Value: tbtString);
+ public
+
+ property OrgName: tbtString read FOrgName write FOrgName;
+
+ property Name: tbtString read FName write SetName;
+
+ property NameHash: Longint read FNameHash;
+
+ property Value: PIfRVariant read FValue write FValue;
+
+ {$IFDEF PS_USESSUPPORT}
+ property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit;
+ {$ENDIF}
+
+ property DeclarePos: Cardinal read FDeclarePos write FDeclarePos;
+
+ property DeclareRow: Cardinal read FDeclareRow write FDeclareRow;
+
+ property DeclareCol: Cardinal read FDeclareCol write FDeclareCol;
+
+
+ procedure SetSet(const val);
+
+
+ procedure SetInt(const Val: Longint);
+
+ procedure SetUInt(const Val: Cardinal);
+ {$IFNDEF PS_NOINT64}
+
+ procedure SetInt64(const Val: Int64);
+ {$ENDIF}
+
+ procedure SetString(const Val: tbtString);
+
+ procedure SetChar(c: tbtChar);
+ {$IFNDEF PS_NOWIDESTRING}
+
+ procedure SetWideChar(const val: WideChar);
+
+ procedure SetWideString(const val: tbtwidestring);
+ procedure SetUnicodeString(const val: tbtunicodestring);
+ {$ENDIF}
+
+ procedure SetExtended(const Val: Extended);
+
+
+ destructor Destroy; override;
+ end;
+
+ PIFPSConstant = TPSConstant;
+
+ TPSPascalCompilerErrorType = (
+ ecUnknownIdentifier,
+ ecIdentifierExpected,
+ ecCommentError,
+ ecStringError,
+ ecCharError,
+ ecSyntaxError,
+ ecUnexpectedEndOfFile,
+ ecSemicolonExpected,
+ ecBeginExpected,
+ ecPeriodExpected,
+ ecDuplicateIdentifier,
+ ecColonExpected,
+ ecUnknownType,
+ ecCloseRoundExpected,
+ ecTypeMismatch,
+ ecInternalError,
+ ecAssignmentExpected,
+ ecThenExpected,
+ ecDoExpected,
+ ecNoResult,
+ ecOpenRoundExpected,
+ ecCommaExpected,
+ ecToExpected,
+ ecIsExpected,
+ ecOfExpected,
+ ecCloseBlockExpected,
+ ecVariableExpected,
+ ecStringExpected,
+ ecEndExpected,
+ ecUnSetLabel,
+ ecNotInLoop,
+ ecInvalidJump,
+ ecOpenBlockExpected,
+ ecWriteOnlyProperty,
+ ecReadOnlyProperty,
+ ecClassTypeExpected,
+ ecCustomError,
+ ecDivideByZero,
+ ecMathError,
+ ecUnsatisfiedForward,
+ ecForwardParameterMismatch,
+ ecInvalidnumberOfParameters
+ {$IFDEF PS_USESSUPPORT}
+ , ecNotAllowed,
+ ecUnitNotFoundOrContainsErrors
+ {$ENDIF}
+ );
+
+ TPSPascalCompilerHintType = (
+ ehVariableNotUsed,
+ ehFunctionNotUsed,
+ ehCustomHint
+ );
+
+ TPSPascalCompilerWarningType = (
+ ewCalculationAlwaysEvaluatesTo,
+ ewIsNotNeeded,
+ ewAbstractClass,
+ ewCustomWarning
+ );
+
+ TPSPascalCompilerMessage = class(TObject)
+ protected
+
+ FRow: Cardinal;
+
+ FCol: Cardinal;
+
+ FModuleName: tbtString;
+
+ FParam: tbtString;
+
+ FPosition: Cardinal;
+
+ procedure SetParserPos(Parser: TPSPascalParser);
+ public
+
+ property ModuleName: tbtString read FModuleName write FModuleName;
+
+ property Param: tbtString read FParam write FParam;
+
+ property Pos: Cardinal read FPosition write FPosition;
+
+ property Row: Cardinal read FRow write FRow;
+
+ property Col: Cardinal read FCol write FCol;
+
+ function ErrorType: tbtString; virtual; abstract;
+
+ procedure SetCustomPos(Pos, Row, Col: Cardinal);
+
+ function MessageToString: tbtString; virtual;
+
+ function ShortMessageToString: tbtString; virtual; abstract;
+ end;
+
+ TPSPascalCompilerError = class(TPSPascalCompilerMessage)
+ protected
+
+ FError: TPSPascalCompilerErrorType;
+ public
+
+ property Error: TPSPascalCompilerErrorType read FError;
+
+ function ErrorType: tbtString; override;
+ function ShortMessageToString: tbtString; override;
+ end;
+
+ TPSPascalCompilerHint = class(TPSPascalCompilerMessage)
+ protected
+
+ FHint: TPSPascalCompilerHintType;
+ public
+
+ property Hint: TPSPascalCompilerHintType read FHint;
+
+ function ErrorType: tbtString; override;
+ function ShortMessageToString: tbtString; override;
+ end;
+
+ TPSPascalCompilerWarning = class(TPSPascalCompilerMessage)
+ protected
+
+ FWarning: TPSPascalCompilerWarningType;
+ public
+
+ property Warning: TPSPascalCompilerWarningType read FWarning;
+
+ function ErrorType: tbtString; override;
+ function ShortMessageToString: tbtString; override;
+ end;
+ TPSDuplicCheck = set of (dcTypes, dcProcs, dcVars, dcConsts);
+
+ TPSBlockInfo = class(TObject)
+ private
+ FOwner: TPSBlockInfo;
+ FWithList: TPSList;
+ FProcNo: Cardinal;
+ FProc: TPSInternalProcedure;
+ FSubType: TPSSubOptType;
+ public
+
+ property WithList: TPSList read FWithList;
+
+ property ProcNo: Cardinal read FProcNo write FProcNo;
+
+ property Proc: TPSInternalProcedure read FProc write FProc;
+
+ property SubType: TPSSubOptType read FSubType write FSubType;
+
+ procedure Clear;
+
+ constructor Create(Owner: TPSBlockInfo);
+
+ destructor Destroy; override;
+ end;
+
+
+
+ TPSBinOperatorType = (otAdd, otSub, otMul, otDiv, otMod, otShl, otShr, otAnd, otOr, otXor, otAs,
+ otGreaterEqual, otLessEqual, otGreater, otLess, otEqual,
+ otNotEqual, otIs, otIn);
+
+ TPSUnOperatorType = (otNot, otMinus, otCast);
+
+ TPSOnUseVariable = procedure (Sender: TPSPascalCompiler; VarType: TPSVariableType; VarNo: Longint; ProcNo, Position: Cardinal; const PropData: tbtString);
+
+ TPSOnUses = function(Sender: TPSPascalCompiler; const Name: tbtString): Boolean;
+
+ TPSOnExportCheck = function(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure; const ProcDecl: tbtString): Boolean;
+
+ {$IFNDEF PS_USESSUPPORT}
+ TPSOnWriteLineEvent = function (Sender: TPSPascalCompiler; Position: Cardinal): Boolean;
+ {$ELSE}
+ TPSOnWriteLineEvent = function (Sender: TPSPascalCompiler; FileName: tbtString; Position: Cardinal): Boolean;
+ {$ENDIF}
+
+ TPSOnExternalProc = function (Sender: TPSPascalCompiler; Decl: TPSParametersDecl; const Name, FExternal: tbtString): TPSRegProc;
+
+ TPSOnTranslateLineInfoProc = procedure (Sender: TPSPascalCompiler; var Pos, Row, Col: Cardinal; var Name: tbtString);
+ TPSOnNotify = function (Sender: TPSPascalCompiler): Boolean;
+
+ TPSOnFunction = procedure(name: tbtString; Pos, Row, Col: Integer) of object;
+
+
+ TPSPascalCompiler = class
+ protected
+ FAnyString: TPSType;
+ FUnitName: tbtString;
+ FID: Pointer;
+ FOnExportCheck: TPSOnExportCheck;
+ FDefaultBoolType: TPSType;
+ FRegProcs: TPSList;
+ FConstants: TPSList;
+ FProcs: TPSList;
+ FTypes: TPSList;
+ FAttributeTypes: TPSList;
+ FVars: TPSList;
+ FOutput: tbtString;
+ FParser: TPSPascalParser;
+ FParserHadError: Boolean;
+ FMessages: TPSList;
+ FOnUses: TPSOnUses;
+ FUtf8Decode: Boolean;
+ FIsUnit: Boolean;
+ FAllowNoBegin: Boolean;
+ FAllowNoEnd: Boolean;
+ FAllowUnit: Boolean;
+ FBooleanShortCircuit: Boolean;
+ FDebugOutput: tbtString;
+ FOnExternalProc: TPSOnExternalProc;
+ FOnUseVariable: TPSOnUseVariable;
+ FOnBeforeOutput: TPSOnNotify;
+ FOnBeforeCleanup: TPSOnNotify;
+ FOnWriteLine: TPSOnWriteLineEvent;
+ FContinueOffsets, FBreakOffsets: TPSList;
+ FOnTranslateLineInfo: TPSOnTranslateLineInfoProc;
+ FAutoFreeList: TPSList;
+ FClasses: TPSList;
+ FOnFunctionStart: TPSOnFunction;
+ FOnFunctionEnd: TPSOnFunction;
+
+
+ FWithCount: Integer;
+ FTryCount: Integer;
+ FExceptFinallyCount: Integer;
+
+
+ {$IFDEF PS_USESSUPPORT}
+ FUnitInits : TPSList; //nvds
+ FUnitFinits: TPSList; //nvds
+ FUses : TIFStringList;
+ fModule : tbtString;
+ {$ENDIF}
+ fInCompile : Integer;
+{$IFNDEF PS_NOINTERFACES}
+ FInterfaces: TPSList;
+{$ENDIF}
+
+ FCurrUsedTypeNo: Cardinal;
+ FGlobalBlock: TPSBlockInfo;
+
+ function IsBoolean(aType: TPSType): Boolean;
+ {$IFNDEF PS_NOWIDESTRING}
+
+ function GetWideString(Src: PIfRVariant; var s: Boolean): tbtwidestring;
+ function GetUnicodeString(Src: PIfRVariant; var s: Boolean): tbtunicodestring;
+ {$ENDIF}
+ function PreCalc(FUseUsedTypes: Boolean; Var1Mod: Byte; var1: PIFRVariant; Var2Mod: Byte;
+ Var2: PIfRVariant; Cmd: TPSBinOperatorType; Pos, Row, Col: Cardinal): Boolean;
+
+ function FindBaseType(BaseType: TPSBaseType): TPSType;
+
+ function IsIntBoolType(aType: TPSType): Boolean;
+ function GetTypeCopyLink(p: TPSType): TPSType;
+
+ function at2ut(p: TPSType): TPSType;
+ procedure UseProc(procdecl: TPSParametersDecl);
+
+
+ function GetMsgCount: Longint;
+
+ function GetMsg(l: Longint): TPSPascalCompilerMessage;
+
+
+ function MakeExportDecl(decl: TPSParametersDecl): tbtString;
+
+
+ procedure DefineStandardTypes;
+
+ procedure DefineStandardProcedures;
+
+ function ReadReal(const s: tbtString): PIfRVariant;
+ function ReadString: PIfRVariant;
+ function ReadInteger(const s: tbtString): PIfRVariant;
+ function ReadAttributes(Dest: TPSAttributes): Boolean;
+ function ReadConstant(FParser: TPSPascalParser; StopOn: TPSPasToken): PIfRVariant;
+
+ function ApplyAttribsToFunction(func: TPSProcedure): boolean;
+ function ProcessFunction(AlwaysForward: Boolean; Att: TPSAttributes): Boolean;
+ function ValidateParameters(BlockInfo: TPSBlockInfo; Params: TPSParameters; ParamTypes: TPSParametersDecl): boolean;
+
+ function IsVarInCompatible(ft1, ft2: TPSType): Boolean;
+ function GetTypeNo(BlockInfo: TPSBlockInfo; p: TPSValue): TPSType;
+ function DoVarBlock(proc: TPSInternalProcedure): Boolean;
+ function DoTypeBlock(FParser: TPSPascalParser): Boolean;
+ function ReadType(const Name: tbtString; FParser: TPSPascalParser): TPSType;
+ function ProcessLabel(Proc: TPSInternalProcedure): Boolean;
+ function ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
+ function ProcessLabelForwards(Proc: TPSInternalProcedure): Boolean;
+
+ procedure WriteDebugData(const s: tbtString);
+
+ procedure Debug_SavePosition(ProcNo: Cardinal; Proc: TPSInternalProcedure);
+
+ procedure Debug_WriteParams(ProcNo: Cardinal; Proc: TPSInternalProcedure);
+
+ procedure Debug_WriteLine(BlockInfo: TPSBlockInfo);
+
+
+ function IsCompatibleType(p1, p2: TPSType; Cast: Boolean): Boolean;
+
+ function IsDuplicate(const s: tbtString; const check: TPSDuplicCheck): Boolean;
+
+ function NewProc(const OriginalName, Name: tbtString): TPSInternalProcedure;
+
+ function AddUsedFunction(var Proc: TPSInternalProcedure): Cardinal;
+
+ function AddUsedFunction2(var Proc: TPSExternalProcedure): Cardinal;
+
+
+ function CheckCompatProc(P: TPSType; ProcNo: Cardinal): Boolean;
+
+
+ procedure ParserError(Parser: TObject; Kind: TPSParserErrorKind);
+
+ function ReadTypeAddProcedure(const Name: tbtString; FParser: TPSPascalParser): TPSType;
+
+ function VarIsDuplicate(Proc: TPSInternalProcedure; const VarNames, s: tbtString): Boolean;
+
+ function IsProcDuplicLabel(Proc: TPSInternalProcedure; const s: tbtString): Boolean;
+
+ procedure CheckForUnusedVars(Func: TPSInternalProcedure);
+ function ProcIsDuplic(Decl: TPSParametersDecl; const FunctionName, FunctionParamNames: tbtString; const s: tbtString; Func: TPSInternalProcedure): Boolean;
+ public
+ function GetConstant(const Name: tbtString): TPSConstant;
+
+ function UseExternalProc(const Name: tbtString): TPSParametersDecl;
+
+ function FindProc(const aName: tbtString): Cardinal;
+
+ function GetTypeCount: Longint;
+
+ function GetType(I: Longint): TPSType;
+
+ function GetVarCount: Longint;
+
+ function GetVar(I: Longint): TPSVar;
+
+ function GetProcCount: Longint;
+
+ function GetProc(I: Longint): TPSProcedure;
+
+ function GetConstCount: Longint;
+
+ function GetConst(I: Longint): TPSConstant;
+
+ function GetRegProcCount: Longint;
+
+ function GetRegProc(I: Longint): TPSRegProc;
+
+ function AddAttributeType: TPSAttributeType;
+ function FindAttributeType(const Name: tbtString): TPSAttributeType;
+
+ procedure AddToFreeList(Obj: TObject);
+
+ property ID: Pointer read FID write FID;
+
+ function MakeError(const Module: tbtString; E: TPSPascalCompilerErrorType; const
+ Param: tbtString): TPSPascalCompilerMessage;
+
+ function MakeWarning(const Module: tbtString; E: TPSPascalCompilerWarningType;
+ const Param: tbtString): TPSPascalCompilerMessage;
+
+ function MakeHint(const Module: tbtString; E: TPSPascalCompilerHintType;
+ const Param: tbtString): TPSPascalCompilerMessage;
+
+{$IFNDEF PS_NOINTERFACES}
+
+ function AddInterface(InheritedFrom: TPSInterface; Guid: TGuid; const Name: tbtString): TPSInterface;
+
+ function FindInterface(const Name: tbtString): TPSInterface;
+
+{$ENDIF}
+ function AddClass(InheritsFrom: TPSCompileTimeClass; aClass: TClass): TPSCompileTimeClass;
+
+ function AddClassN(InheritsFrom: TPSCompileTimeClass; const aClass: tbtString): TPSCompileTimeClass;
+
+
+ function FindClass(const aClass: tbtString): TPSCompileTimeClass;
+
+ function AddFunction(const Header: tbtString): TPSRegProc;
+
+ function AddDelphiFunction(const Decl: tbtString): TPSRegProc;
+
+ function AddType(const Name: tbtString; const BaseType: TPSBaseType): TPSType;
+
+ function AddTypeS(const Name, Decl: tbtString): TPSType;
+
+ function AddTypeCopy(const Name: tbtString; TypeNo: TPSType): TPSType;
+
+ function AddTypeCopyN(const Name, FType: tbtString): TPSType;
+
+ function AddConstant(const Name: tbtString; FType: TPSType): TPSConstant;
+
+ function AddConstantN(const Name, FType: tbtString): TPSConstant;
+
+ function AddVariable(const Name: tbtString; FType: TPSType): TPSVar;
+
+ function AddVariableN(const Name, FType: tbtString): TPSVar;
+
+ function AddUsedVariable(const Name: tbtString; FType: TPSType): TPSVar;
+
+ function AddUsedVariableN(const Name, FType: tbtString): TPSVar;
+
+ function AddUsedPtrVariable(const Name: tbtString; FType: TPSType): TPSVar;
+
+ function AddUsedPtrVariableN(const Name, FType: tbtString): TPSVar;
+
+ function FindType(const Name: tbtString): TPSType;
+
+ function MakeDecl(decl: TPSParametersDecl): tbtString;
+
+ function Compile(const s: tbtString): Boolean;
+
+ function GetOutput(var s: tbtString): Boolean;
+
+ function GetDebugOutput(var s: tbtString): Boolean;
+
+ procedure Clear;
+
+ constructor Create;
+
+ destructor Destroy; override;
+
+ property MsgCount: Longint read GetMsgCount;
+
+ property Msg[l: Longint]: TPSPascalCompilerMessage read GetMsg;
+
+ property OnTranslateLineInfo: TPSOnTranslateLineInfoProc read FOnTranslateLineInfo write FOnTranslateLineInfo;
+
+ property OnUses: TPSOnUses read FOnUses write FOnUses;
+
+ property OnExportCheck: TPSOnExportCheck read FOnExportCheck write FOnExportCheck;
+
+ property OnWriteLine: TPSOnWriteLineEvent read FOnWriteLine write FOnWriteLine;
+
+ property OnExternalProc: TPSOnExternalProc read FOnExternalProc write FOnExternalProc;
+
+ property OnUseVariable: TPSOnUseVariable read FOnUseVariable write FOnUseVariable;
+
+ property OnBeforeOutput: TPSOnNotify read FOnBeforeOutput write FOnBeforeOutput;
+
+ property OnBeforeCleanup: TPSOnNotify read FOnBeforeCleanup write FOnBeforeCleanup;
+
+ property OnFunctionStart: TPSOnFunction read FOnFunctionStart write FOnFunctionStart;
+
+ property OnFunctionEnd: TPSOnFunction read FOnFunctionEnd write FOnFunctionEnd;
+
+ property IsUnit: Boolean read FIsUnit;
+
+ property AllowNoBegin: Boolean read FAllowNoBegin write FAllowNoBegin;
+
+ property AllowUnit: Boolean read FAllowUnit write FAllowUnit;
+
+ property AllowNoEnd: Boolean read FAllowNoEnd write FAllowNoEnd;
+
+
+ property BooleanShortCircuit: Boolean read FBooleanShortCircuit write FBooleanShortCircuit;
+
+ property UTF8Decode: Boolean read FUtf8Decode write FUtf8Decode;
+
+ property UnitName: tbtString read FUnitName;
+ end;
+ TIFPSPascalCompiler = TPSPascalCompiler;
+
+ TPSValue = class(TObject)
+ private
+ FPos, FRow, FCol: Cardinal;
+ public
+
+ property Pos: Cardinal read FPos write FPos;
+
+ property Row: Cardinal read FRow write FRow;
+
+ property Col: Cardinal read FCol write FCol;
+
+ procedure SetParserPos(P: TPSPascalParser);
+
+ end;
+
+ TPSParameter = class(TObject)
+ private
+ FValue: TPSValue;
+ FTempVar: TPSValue;
+ FParamMode: TPSParameterMode;
+ FExpectedType: TPSType;
+ public
+
+ property Val: TPSValue read FValue write FValue;
+
+ property ExpectedType: TPSType read FExpectedType write FExpectedType;
+
+ property TempVar: TPSValue read FTempVar write FTempVar;
+
+ property ParamMode: TPSParameterMode read FParamMode write FParamMode;
+
+ destructor Destroy; override;
+ end;
+
+ TPSParameters = class(TObject)
+ private
+ FItems: TPSList;
+ function GetCount: Cardinal;
+ function GetItem(I: Longint): TPSParameter;
+ public
+
+ constructor Create;
+
+ destructor Destroy; override;
+
+ property Count: Cardinal read GetCount;
+
+ property Item[I: Longint]: TPSParameter read GetItem; default;
+
+ procedure Delete(I: Cardinal);
+
+ function Add: TPSParameter;
+ end;
+
+ TPSSubItem = class(TObject)
+ private
+ FType: TPSType;
+ public
+
+ property aType: TPSType read FType write FType;
+ end;
+
+ TPSSubNumber = class(TPSSubItem)
+ private
+ FSubNo: Cardinal;
+ public
+
+ property SubNo: Cardinal read FSubNo write FSubNo;
+ end;
+
+ TPSSubValue = class(TPSSubItem)
+ private
+ FSubNo: TPSValue;
+ public
+
+ property SubNo: TPSValue read FSubNo write FSubNo;
+
+ destructor Destroy; override;
+ end;
+
+ TPSValueVar = class(TPSValue)
+ private
+ FRecItems: TPSList;
+ function GetRecCount: Cardinal;
+ function GetRecItem(I: Cardinal): TPSSubItem;
+ public
+ constructor Create;
+ destructor Destroy; override;
+
+ function RecAdd(Val: TPSSubItem): Cardinal;
+
+ procedure RecDelete(I: Cardinal);
+
+ property RecItem[I: Cardinal]: TPSSubItem read GetRecItem;
+
+ property RecCount: Cardinal read GetRecCount;
+ end;
+
+ TPSValueGlobalVar = class(TPSValueVar)
+ private
+ FAddress: Cardinal;
+ public
+
+ property GlobalVarNo: Cardinal read FAddress write FAddress;
+ end;
+
+
+ TPSValueLocalVar = class(TPSValueVar)
+ private
+ FLocalVarNo: Longint;
+ public
+
+ property LocalVarNo: Longint read FLocalVarNo write FLocalVarNo;
+ end;
+
+ TPSValueParamVar = class(TPSValueVar)
+ private
+ FParamNo: Longint;
+ public
+
+ property ParamNo: Longint read FParamNo write FParamNo;
+ end;
+
+ TPSValueAllocatedStackVar = class(TPSValueLocalVar)
+ private
+ FProc: TPSInternalProcedure;
+ public
+
+ property Proc: TPSInternalProcedure read FProc write FProc;
+ destructor Destroy; override;
+ end;
+
+ TPSValueData = class(TPSValue)
+ private
+ FData: PIfRVariant;
+ public
+
+ property Data: PIfRVariant read FData write FData;
+ destructor Destroy; override;
+ end;
+
+ TPSValueReplace = class(TPSValue)
+ private
+ FPreWriteAllocated: Boolean;
+ FFreeOldValue: Boolean;
+ FFreeNewValue: Boolean;
+ FOldValue: TPSValue;
+ FNewValue: TPSValue;
+ FReplaceTimes: Longint;
+ public
+
+ property OldValue: TPSValue read FOldValue write FOldValue;
+
+ property NewValue: TPSValue read FNewValue write FNewValue;
+ {Should it free the old value when destroyed?}
+ property FreeOldValue: Boolean read FFreeOldValue write FFreeOldValue;
+ property FreeNewValue: Boolean read FFreeNewValue write FFreeNewValue;
+ property PreWriteAllocated: Boolean read FPreWriteAllocated write FPreWriteAllocated;
+
+ property ReplaceTimes: Longint read FReplaceTimes write FReplaceTimes;
+
+ constructor Create;
+ destructor Destroy; override;
+ end;
+
+
+ TPSUnValueOp = class(TPSValue)
+ private
+ FVal1: TPSValue;
+ FOperator: TPSUnOperatorType;
+ FType: TPSType;
+ public
+
+ property Val1: TPSValue read FVal1 write FVal1;
+ {The operator}
+ property Operator: TPSUnOperatorType read FOperator write FOperator;
+
+ property aType: TPSType read FType write FType;
+ destructor Destroy; override;
+ end;
+
+ TPSBinValueOp = class(TPSValue)
+ private
+ FVal1,
+ FVal2: TPSValue;
+ FOperator: TPSBinOperatorType;
+ FType: TPSType;
+ public
+
+ property Val1: TPSValue read FVal1 write FVal1;
+
+ property Val2: TPSValue read FVal2 write FVal2;
+ {The operator for this value}
+ property Operator: TPSBinOperatorType read FOperator write FOperator;
+
+ property aType: TPSType read FType write FType;
+
+ destructor Destroy; override;
+ end;
+
+ TPSValueNil = class(TPSValue)
+ end;
+
+ TPSValueProcPtr = class(TPSValue)
+ private
+ FProcNo: Cardinal;
+ public
+
+ property ProcPtr: Cardinal read FProcNo write FProcNo;
+ end;
+
+ TPSValueProc = class(TPSValue)
+ private
+ FSelfPtr: TPSValue;
+ FParameters: TPSParameters;
+ FResultType: TPSType;
+ public
+ property ResultType: TPSType read FResultType write FResultType;
+
+ property SelfPtr: TPSValue read FSelfPtr write FSelfPtr;
+
+ property Parameters: TPSParameters read FParameters write FParameters;
+ destructor Destroy; override;
+ end;
+
+ TPSValueProcNo = class(TPSValueProc)
+ private
+ FProcNo: Cardinal;
+ public
+
+ property ProcNo: Cardinal read FProcNo write FProcNo;
+ end;
+
+ TPSValueProcVal = class(TPSValueProc)
+ private
+ FProcNo: TPSValue;
+ public
+
+ property ProcNo: TPSValue read FProcNo write FProcNo;
+
+ destructor Destroy; override;
+ end;
+
+ TPSValueArray = class(TPSValue)
+ private
+ FItems: TPSList;
+ function GetCount: Cardinal;
+ function GetItem(I: Cardinal): TPSValue;
+ public
+ function Add(Item: TPSValue): Cardinal;
+ procedure Delete(I: Cardinal);
+ property Item[I: Cardinal]: TPSValue read GetItem;
+ property Count: Cardinal read GetCount;
+
+ constructor Create;
+ destructor Destroy; override;
+ end;
+
+ TPSDelphiClassItem = class;
+
+ TPSPropType = (iptRW, iptR, iptW);
+
+ TPSCompileTimeClass = class
+ private
+ FInheritsFrom: TPSCompileTimeClass;
+ FClass: TClass;
+ FClassName: tbtString;
+ FClassNameHash: Longint;
+ FClassItems: TPSList;
+ FDefaultProperty: Cardinal;
+ FIsAbstract: Boolean;
+ FCastProc,
+ FNilProc: Cardinal;
+ FType: TPSType;
+
+ FOwner: TPSPascalCompiler;
+ function GetCount: Longint;
+ function GetItem(i: Longint): TPSDelphiClassItem;
+ public
+
+ property aType: TPSType read FType;
+
+ property Items[i: Longint]: TPSDelphiClassItem read GetItem;
+
+ property Count: Longint read GetCount;
+
+ property IsAbstract: Boolean read FIsAbstract write FIsAbstract;
+
+
+ property ClassInheritsFrom: TPSCompileTimeClass read FInheritsFrom write FInheritsFrom;
+
+ function RegisterMethod(const Decl: tbtString): Boolean;
+
+ procedure RegisterProperty(const PropertyName, PropertyType: tbtString; PropAC: TPSPropType);
+
+ procedure RegisterPublishedProperties;
+
+ function RegisterPublishedProperty(const Name: tbtString): Boolean;
+
+ procedure SetDefaultPropery(const Name: tbtString);
+
+ constructor Create(ClassName: tbtString; aOwner: TPSPascalCompiler; aType: TPSType);
+
+ class function CreateC(FClass: TClass; aOwner: TPSPascalCompiler; aType: TPSType): TPSCompileTimeClass;
+
+
+ destructor Destroy; override;
+
+
+ function IsCompatibleWith(aType: TPSType): Boolean;
+
+ function SetNil(var ProcNo: Cardinal): Boolean;
+
+ function CastToType(IntoType: TPSType; var ProcNo: Cardinal): Boolean;
+
+
+ function Property_Find(const Name: tbtString; var Index: IPointer): Boolean;
+
+ function Property_Get(Index: IPointer; var ProcNo: Cardinal): Boolean;
+
+ function Property_Set(Index: IPointer; var ProcNo: Cardinal): Boolean;
+
+ function Property_GetHeader(Index: IPointer; Dest: TPSParametersDecl): Boolean;
+
+
+ function Func_Find(const Name: tbtString; var Index: IPointer): Boolean;
+
+ function Func_Call(Index: IPointer; var ProcNo: Cardinal): Boolean;
+
+
+ function ClassFunc_Find(const Name: tbtString; var Index: IPointer): Boolean;
+
+ function ClassFunc_Call(Index: IPointer; var ProcNo: Cardinal): Boolean;
+ end;
+
+ TPSDelphiClassItem = class(TObject)
+ private
+ FOwner: TPSCompileTimeClass;
+ FOrgName: tbtString;
+ FName: tbtString;
+ FNameHash: Longint;
+ FDecl: TPSParametersDecl;
+ procedure SetName(const s: tbtString);
+ public
+
+ constructor Create(Owner: TPSCompileTimeClass);
+
+ destructor Destroy; override;
+
+ property Decl: TPSParametersDecl read FDecl;
+
+ property Name: tbtString read FName;
+
+ property OrgName: tbtString read FOrgName write SetName;
+
+ property NameHash: Longint read FNameHash;
+
+ property Owner: TPSCompileTimeClass read FOwner;
+ end;
+
+ TPSDelphiClassItemMethod = class(TPSDelphiClassItem)
+ private
+ FMethodNo: Cardinal;
+ public
+
+ property MethodNo: Cardinal read FMethodNo write FMethodNo;
+ end;
+
+ TPSDelphiClassItemProperty = class(TPSDelphiClassItem)
+ private
+ FReadProcNo: Cardinal;
+ FWriteProcNo: Cardinal;
+ FAccessType: TPSPropType;
+ public
+
+ property AccessType: TPSPropType read FAccessType write FAccessType;
+
+ property ReadProcNo: Cardinal read FReadProcNo write FReadProcNo;
+
+ property WriteProcNo: Cardinal read FWriteProcNo write FWriteProcNo;
+ end;
+
+
+ TPSDelphiClassItemConstructor = class(TPSDelphiClassItemMethod)
+ end;
+
+{$IFNDEF PS_NOINTERFACES}
+
+ TPSInterface = class(TObject)
+ private
+ FOwner: TPSPascalCompiler;
+ FType: TPSType;
+ FInheritedFrom: TPSInterface;
+ FGuid: TGuid;
+ FCastProc,
+ FNilProc: Cardinal;
+ FItems: TPSList;
+ FName: tbtString;
+ FNameHash: Longint;
+ procedure SetInheritedFrom(p: TPSInterface);
+ public
+
+ constructor Create(Owner: TPSPascalCompiler; InheritedFrom: TPSInterface; Guid: TGuid; const Name: tbtString; aType: TPSType);
+
+ destructor Destroy; override;
+
+ property aType: TPSType read FType;
+
+ property InheritedFrom: TPSInterface read FInheritedFrom write SetInheritedFrom;
+
+ property Guid: TGuid read FGuid write FGuid;
+
+ property Name: tbtString read FName write FName;
+
+ property NameHash: Longint read FNameHash;
+
+
+ function RegisterMethod(const Declaration: tbtString; const cc: TPSCallingConvention): Boolean;
+
+ procedure RegisterDummyMethod;
+
+ function IsCompatibleWith(aType: TPSType): Boolean;
+
+ function SetNil(var ProcNo: Cardinal): Boolean;
+
+ function CastToType(IntoType: TPSType; var ProcNo: Cardinal): Boolean;
+
+ function Func_Find(const Name: tbtString; var Index: Cardinal): Boolean;
+
+ function Func_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean;
+ end;
+
+
+ TPSInterfaceMethod = class(TObject)
+ private
+ FName: tbtString;
+ FDecl: TPSParametersDecl;
+ FNameHash: Longint;
+ FCC: TPSCallingConvention;
+ FScriptProcNo: Cardinal;
+ FOrgName: tbtString;
+ FOwner: TPSInterface;
+ FOffsetCache: Cardinal;
+ function GetAbsoluteProcOffset: Cardinal;
+ public
+
+ property AbsoluteProcOffset: Cardinal read GetAbsoluteProcOffset;
+
+ property ScriptProcNo: Cardinal read FScriptProcNo;
+
+ property OrgName: tbtString read FOrgName;
+
+ property Name: tbtString read FName;
+
+ property NameHash: Longint read FNameHash;
+
+ property Decl: TPSParametersDecl read FDecl;
+
+ property CC: TPSCallingConvention read FCC;
+
+
+ constructor Create(Owner: TPSInterface);
+
+ destructor Destroy; override;
+ end;
+{$ENDIF}
+
+
+ TPSExternalClass = class(TObject)
+ protected
+
+ SE: TPSPascalCompiler;
+
+ FTypeNo: TPSType;
+ public
+
+ function SelfType: TPSType; virtual;
+
+ constructor Create(Se: TPSPascalCompiler; TypeNo: TPSType);
+
+ function ClassFunc_Find(const Name: tbtString; var Index: Cardinal): Boolean; virtual;
+
+ function ClassFunc_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; virtual;
+
+ function Func_Find(const Name: tbtString; var Index: Cardinal): Boolean; virtual;
+
+ function Func_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; virtual;
+
+ function IsCompatibleWith(Cl: TPSExternalClass): Boolean; virtual;
+
+ function SetNil(var ProcNo: Cardinal): Boolean; virtual;
+
+ function CastToType(IntoType: TPSType; var ProcNo: Cardinal): Boolean; virtual;
+
+ function CompareClass(OtherTypeNo: TPSType; var ProcNo: Cardinal): Boolean; virtual;
+ end;
+
+
+function ExportCheck(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure;
+ Types: array of TPSBaseType; Modes: array of TPSParameterMode): Boolean;
+
+
+procedure SetVarExportName(P: TPSVar; const ExpName: tbtString);
+
+function AddImportedClassVariable(Sender: TPSPascalCompiler; const VarName, VarType: tbtString): Boolean;
+
+const
+ {Invalid value, this is returned by most functions of pascal script that return a cardinal, when they fail}
+ InvalidVal = Cardinal(-1);
+
+type
+ TIFPSCompileTimeClass = TPSCompileTimeClass;
+ TIFPSInternalProcedure = TPSInternalProcedure;
+ TIFPSPascalCompilerError = TPSPascalCompilerError;
+
+ TPMFuncType = (mftProc
+ , mftConstructor
+ );
+
+
+function PS_mi2s(i: Cardinal): tbtString;
+
+function ParseMethod(Owner: TPSPascalCompiler; const FClassName: tbtString; Decl: tbtString; var OrgName: tbtString; DestDecl: TPSParametersDecl; var Func: TPMFuncType): Boolean;
+
+function DeclToBits(const Decl: TPSParametersDecl): tbtString;
+
+function NewVariant(FType: TPSType): PIfRVariant;
+procedure DisposeVariant(p: PIfRVariant);
+
+implementation
+
+uses Classes, typInfo;
+
+{$IFDEF DELPHI3UP}
+resourceString
+{$ELSE}
+const
+{$ENDIF}
+
+ RPS_OnUseEventOnly = 'This function can only be called from within the OnUses event';
+ RPS_UnableToRegisterFunction = 'Unable to register function %s';
+ RPS_UnableToRegisterConst = 'Unable to register constant %s';
+ RPS_InvalidTypeForVar = 'Invalid type for variable %s';
+ RPS_InvalidType = 'Invalid Type';
+ RPS_UnableToRegisterType = 'Unable to register type %s';
+ RPS_UnknownInterface = 'Unknown interface: %s';
+ RPS_ConstantValueMismatch = 'Constant Value Type Mismatch';
+ RPS_ConstantValueNotAssigned = 'Constant Value is not assigned';
+
+ RPS_Error = 'Error';
+ RPS_UnknownIdentifier = 'Unknown identifier ''%s''';
+ RPS_IdentifierExpected = 'Identifier expected';
+ RPS_CommentError = 'Comment error';
+ RPS_StringError = 'String error';
+ RPS_CharError = 'Char error';
+ RPS_SyntaxError = 'Syntax error';
+ RPS_EOF = 'Unexpected end of file';
+ RPS_SemiColonExpected = 'Semicolon ('';'') expected';
+ RPS_BeginExpected = '''BEGIN'' expected';
+ RPS_PeriodExpected = 'period (''.'') expected';
+ RPS_DuplicateIdent = 'Duplicate identifier ''%s''';
+ RPS_ColonExpected = 'colon ('':'') expected';
+ RPS_UnknownType = 'Unknown type ''%s''';
+ RPS_CloseRoundExpected = 'Closing parenthesis expected';
+ RPS_TypeMismatch = 'Type mismatch';
+ RPS_InternalError = 'Internal error (%s)';
+ RPS_AssignmentExpected = 'Assignment expected';
+ RPS_ThenExpected = '''THEN'' expected';
+ RPS_DoExpected = '''DO'' expected';
+ RPS_NoResult = 'No result';
+ RPS_OpenRoundExpected = 'opening parenthesis (''('')expected';
+ RPS_CommaExpected = 'comma ('','') expected';
+ RPS_ToExpected = '''TO'' expected';
+ RPS_IsExpected = 'is (''='') expected';
+ RPS_OfExpected = '''OF'' expected';
+ RPS_CloseBlockExpected = 'Closing square bracket ('']'') expected';
+ RPS_VariableExpected = 'Variable Expected';
+ RPS_StringExpected = 'String Expected';
+ RPS_EndExpected = '''END'' expected';
+ RPS_UnSetLabel = 'Label ''%s'' not set';
+ RPS_NotInLoop = 'Not in a loop';
+ RPS_InvalidJump = 'Invalid jump';
+ RPS_OpenBlockExpected = 'Opening square brackets (''['') expected';
+ RPS_WriteOnlyProperty = 'Write-only property';
+ RPS_ReadOnlyProperty = 'Read-only property';
+ RPS_ClassTypeExpected = 'Class type expected';
+ RPS_DivideByZero = 'Divide by Zero';
+ RPS_MathError = 'Math Error';
+ RPS_UnsatisfiedForward = 'Unsatisfied Forward %s';
+ RPS_ForwardParameterMismatch = 'Forward Parameter Mismatch';
+ RPS_InvalidNumberOfParameter = 'Invalid number of parameters';
+ RPS_UnknownError = 'Unknown error';
+ {$IFDEF PS_USESSUPPORT}
+ RPS_NotAllowed = '%s is not allowed at this position';
+ RPS_UnitNotFound = 'Unit ''%s'' not found or contains errors';
+ {$ENDIF}
+
+
+ RPS_Hint = 'Hint';
+ RPS_VariableNotUsed = 'Variable ''%s'' never used';
+ RPS_FunctionNotUsed = 'Function ''%s'' never used';
+ RPS_UnknownHint = 'Unknown hint';
+
+
+ RPS_Warning = 'Warning';
+ RPS_CalculationAlwaysEvaluatesTo = 'Calculation always evaluates to %s';
+ RPS_IsNotNeeded = '%s is not needed';
+ RPS_AbstractClass = 'Abstract Class Construction';
+ RPS_UnknownWarning = 'Unknown warning';
+
+
+ {$IFDEF DEBUG }
+ RPS_UnableToRegister = 'Unable to register %s';
+ {$ENDIF}
+
+ RPS_NotArrayProperty = 'Not an array property';
+ RPS_NotProperty = 'Not a property';
+ RPS_UnknownProperty = 'Unknown Property';
+
+function DeclToBits(const Decl: TPSParametersDecl): tbtString;
+var
+ i: longint;
+begin
+ Result := '';
+ if Decl.Result = nil then
+ begin
+ Result := Result + #0;
+ end else
+ Result := Result + #1;
+ for i := 0 to Decl.ParamCount -1 do
+ begin
+ if Decl.Params[i].Mode <> pmIn then
+ Result := Result + #1
+ else
+ Result := Result + #0;
+ end;
+end;
+
+
+procedure BlockWriteByte(BlockInfo: TPSBlockInfo; b: Byte);
+begin
+ BlockInfo.Proc.Data := BlockInfo.Proc.Data + tbtChar(b);
+end;
+
+procedure BlockWriteData(BlockInfo: TPSBlockInfo; const Data; Len: Longint);
+begin
+ SetLength(BlockInfo.Proc.FData, Length(BlockInfo.Proc.FData) + Len);
+ Move(Data, BlockInfo.Proc.FData[Length(BlockInfo.Proc.FData) - Len + 1], Len);
+end;
+
+procedure BlockWriteLong(BlockInfo: TPSBlockInfo; l: Cardinal);
+begin
+ BlockWriteData(BlockInfo, l, 4);
+end;
+
+procedure BlockWriteVariant(BlockInfo: TPSBlockInfo; p: PIfRVariant);
+var
+ du8: tbtu8;
+ du16: tbtu16;
+begin
+ BlockWriteLong(BlockInfo, p^.FType.FinalTypeNo);
+ case p.FType.BaseType of
+ btType: BlockWriteData(BlockInfo, p^.ttype.FinalTypeno, 4);
+ {$IFNDEF PS_NOWIDESTRING}
+ btWideString:
+ begin
+ BlockWriteLong(BlockInfo, Length(tbtWideString(p^.twidestring)));
+ BlockWriteData(BlockInfo, tbtwidestring(p^.twidestring)[1], 2*Length(tbtWideString(p^.twidestring)));
+ end;
+ btUnicodeString:
+ begin
+ BlockWriteLong(BlockInfo, Length(tbtUnicodeString(p^.twidestring)));
+ BlockWriteData(BlockInfo, tbtUnicodeString(p^.twidestring)[1], 2*Length(tbtUnicodeString(p^.twidestring)));
+ end;
+ btWideChar: BlockWriteData(BlockInfo, p^.twidechar, 2);
+ {$ENDIF}
+ btSingle: BlockWriteData(BlockInfo, p^.tsingle, sizeof(tbtSingle));
+ btDouble: BlockWriteData(BlockInfo, p^.tdouble, sizeof(tbtDouble));
+ btExtended: BlockWriteData(BlockInfo, p^.textended, sizeof(tbtExtended));
+ btCurrency: BlockWriteData(BlockInfo, p^.tcurrency, sizeof(tbtCurrency));
+ btChar: BlockWriteData(BlockInfo, p^.tchar, 1);
+ btSet:
+ begin
+ BlockWriteData(BlockInfo, tbtString(p^.tstring)[1], Length(tbtString(p^.tstring)));
+ end;
+ btString:
+ begin
+ BlockWriteLong(BlockInfo, Length(tbtString(p^.tstring)));
+ BlockWriteData(BlockInfo, tbtString(p^.tstring)[1], Length(tbtString(p^.tstring)));
+ end;
+ btenum:
+ begin
+ if TPSEnumType(p^.FType).HighValue <=256 then
+ begin
+ du8 := tbtu8(p^.tu32);
+ BlockWriteData(BlockInfo, du8, 1)
+ end
+ else if TPSEnumType(p^.FType).HighValue <=65536 then
+ begin
+ du16 := tbtu16(p^.tu32);
+ BlockWriteData(BlockInfo, du16, 2)
+ end;
+ end;
+
+ bts8,btu8: BlockWriteData(BlockInfo, p^.tu8, 1);
+ bts16,btu16: BlockWriteData(BlockInfo, p^.tu16, 2);
+ bts32,btu32: BlockWriteData(BlockInfo, p^.tu32, 4);
+ {$IFNDEF PS_NOINT64}
+ bts64: BlockWriteData(BlockInfo, p^.ts64, 8);
+ {$ENDIF}
+ btProcPtr: BlockWriteData(BlockInfo, p^.tu32, 4);
+ {$IFDEF DEBUG}
+ {$IFNDEF FPC}
+ else
+ asm int 3; end;
+ {$ENDIF}
+ {$ENDIF}
+ end;
+end;
+
+
+
+function ExportCheck(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure; Types: array of TPSBaseType; Modes: array of TPSParameterMode): Boolean;
+var
+ i: Longint;
+ ttype: TPSType;
+begin
+ if High(Types) <> High(Modes)+1 then
+ begin
+ Result := False;
+ exit;
+ end;
+ if High(Types) <> Proc.Decl.ParamCount then
+ begin
+ Result := False;
+ exit;
+ end;
+ TType := Proc.Decl.Result;
+ if TType = nil then
+ begin
+ if Types[0] <> btReturnAddress then
+ begin
+ Result := False;
+ exit;
+ end;
+ end else
+ begin
+ if TType.BaseType <> Types[0] then
+ begin
+ Result := False;
+ exit;
+ end;
+ end;
+ for i := 0 to High(Modes) do
+ begin
+ TType := Proc.Decl.Params[i].aType;
+ if Modes[i] <> Proc.Decl.Params[i].Mode then
+ begin
+ Result := False;
+ exit;
+ end;
+ if TType.BaseType <> Types[i+1] then
+ begin
+ Result := False;
+ exit;
+ end;
+ end;
+ Result := True;
+end;
+
+procedure SetVarExportName(P: TPSVar; const ExpName: tbtString);
+begin
+ if p <> nil then
+ p.exportname := ExpName;
+end;
+
+function FindAndAddType(Owner: TPSPascalCompiler; const Name, Decl: tbtString): TPSType;
+var
+ tt: TPSType;
+begin
+ Result := Owner.FindType(Name);
+ if Result = nil then
+ begin
+ tt := Owner.AddTypeS(Name, Decl);
+ tt.ExportName := True;
+ Result := tt;
+ end;
+end;
+
+
+function ParseMethod(Owner: TPSPascalCompiler; const FClassName: tbtString; Decl: tbtString; var OrgName: tbtString; DestDecl: TPSParametersDecl; var Func: TPMFuncType): Boolean;
+var
+ Parser: TPSPascalParser;
+ FuncType: Byte;
+ VNames: tbtString;
+ modifier: TPSParameterMode;
+ VCType: TPSType;
+ ERow, EPos, ECol: Integer;
+
+begin
+ Parser := TPSPascalParser.Create;
+ Parser.SetText(Decl);
+ if Parser.CurrTokenId = CSTII_Function then
+ FuncType:= 0
+ else if Parser.CurrTokenId = CSTII_Procedure then
+ FuncType := 1
+ else if (Parser.CurrTokenId = CSTII_Constructor) and (FClassName <> '') then
+ FuncType := 2
+ else
+ begin
+ Parser.Free;
+ Result := False;
+ exit;
+ end;
+ Parser.Next;
+ if Parser.CurrTokenId <> CSTI_Identifier then
+ begin
+ Parser.Free;
+ Result := False;
+ exit;
+ end; {if}
+ OrgName := Parser.OriginalToken;
+ Parser.Next;
+ if Parser.CurrTokenId = CSTI_OpenRound then
+ begin
+ Parser.Next;
+ if Parser.CurrTokenId <> CSTI_CloseRound then
+ begin
+ while True do
+ begin
+ if Parser.CurrTokenId = CSTII_Const then
+ begin
+ modifier := pmIn;
+ Parser.Next;
+ end
+ else
+ if Parser.CurrTokenId = CSTII_Var then
+ begin
+ modifier := pmInOut;
+ Parser.Next;
+ end
+ else
+ if Parser.CurrTokenId = CSTII_Out then
+ begin
+ modifier := pmOut;
+ Parser.Next;
+ end
+ else
+ modifier := pmIn;
+ if Parser.CurrTokenId <> CSTI_Identifier then
+ begin
+ Parser.Free;
+ Result := False;
+ exit;
+ end;
+ EPos:=Parser.CurrTokenPos;
+ ERow:=Parser.Row;
+ ECol:=Parser.Col;
+
+ VNames := Parser.OriginalToken + '|';
+ Parser.Next;
+ while Parser.CurrTokenId = CSTI_Comma do
+ begin
+ Parser.Next;
+ if Parser.CurrTokenId <> CSTI_Identifier then
+ begin
+ Parser.Free;
+ Result := False;
+ exit;
+ end;
+ VNames := VNames + Parser.OriginalToken + '|';
+ Parser.Next;
+ end;
+ if Parser.CurrTokenId <> CSTI_Colon then
+ begin
+ Parser.Free;
+ Result := False;
+ exit;
+ end;
+ Parser.Next;
+ if Parser.CurrTokenID = CSTII_Array then
+ begin
+ Parser.nExt;
+ if Parser.CurrTokenId <> CSTII_Of then
+ begin
+ Parser.Free;
+ Result := False;
+ exit;
+ end;
+ Parser.Next;
+ if Parser.CurrTokenId = CSTII_Const then
+ begin
+ VCType := FindAndAddType(Owner, '!OPENARRAYOFCONST', 'array of ___Pointer')
+ end
+ else begin
+ VCType := Owner.GetTypeCopyLink(Owner.FindType(Parser.GetToken));
+ if VCType = nil then
+ begin
+ Parser.Free;
+ Result := False;
+ exit;
+ end;
+ case VCType.BaseType of
+ btU8: VCType := FindAndAddType(Owner, '!OPENARRAYOFU8', 'array of byte');
+ btS8: VCType := FindAndAddType(Owner, '!OPENARRAYOFS8', 'array of ShortInt');
+ btU16: VCType := FindAndAddType(Owner, '!OPENARRAYOFU16', 'array of SmallInt');
+ btS16: VCType := FindAndAddType(Owner, '!OPENARRAYOFS16', 'array of Word');
+ btU32: VCType := FindAndAddType(Owner, '!OPENARRAYOFU32', 'array of Cardinal');
+ btS32: VCType := FindAndAddType(Owner, '!OPENARRAYOFS32', 'array of Longint');
+ btSingle: VCType := FindAndAddType(Owner, '!OPENARRAYOFSINGLE', 'array of Single');
+ btDouble: VCType := FindAndAddType(Owner, '!OPENARRAYOFDOUBLE', 'array of Double');
+ btExtended: VCType := FindAndAddType(Owner, '!OPENARRAYOFEXTENDED', 'array of Extended');
+ btString: VCType := FindAndAddType(Owner, '!OPENARRAYOFSTRING', 'array of String');
+ btPChar: VCType := FindAndAddType(Owner, '!OPENARRAYOFPCHAR', {$IFDEF PS_PANSICHAR}'array of PAnsiChar'{$ELSE}'array of PChar'{$ENDIF});
+ btNotificationVariant, btVariant: VCType := FindAndAddType(Owner, '!OPENARRAYOFVARIANT', 'array of variant');
+ {$IFNDEF PS_NOINT64}btS64: VCType := FindAndAddType(Owner, '!OPENARRAYOFS64', 'array of Int64');{$ENDIF}
+ btChar: VCType := FindAndAddType(Owner, '!OPENARRAYOFCHAR', 'array of Char');
+ {$IFNDEF PS_NOWIDESTRING}
+ btWideString: VCType := FindAndAddType(Owner, '!OPENARRAYOFWIDESTRING', 'array of WideString');
+ btUnicodeString: VCType := FindAndAddType(Owner, '!OPENARRAYOFUNICODESTRING', 'array of UnicodeString');
+ btWideChar: VCType := FindAndAddType(Owner, '!OPENARRAYOFWIDECHAR', 'array of WideChar');
+ {$ENDIF}
+ btClass: VCType := FindAndAddType(Owner, '!OPENARRAYOFTOBJECT', 'array of TObject');
+ btRecord: VCType := FindAndAddType(Owner, '!OPENARRAYOFRECORD_'+FastUpperCase(Parser.OriginalToken), 'array of ' +FastUpperCase(Parser.OriginalToken));
+ else
+ begin
+ Parser.Free;
+ Result := False;
+ exit;
+ end;
+ end;
+ end;
+ end else if Parser.CurrTokenID = CSTII_Const then
+ VCType := nil // any type
+ else begin
+ VCType := Owner.FindType(Parser.GetToken);
+ if VCType = nil then
+ begin
+ Parser.Free;
+ Result := False;
+ exit;
+ end;
+ end;
+ while Pos(tbtchar('|'), VNames) > 0 do
+ begin
+ with DestDecl.AddParam do
+ begin
+ {$IFDEF PS_USESSUPPORT}
+ DeclareUnit:=Owner.fModule;
+ {$ENDIF}
+ DeclarePos := EPos;
+ DeclareRow := ERow;
+ DeclareCol := ECol;
+ Mode := modifier;
+ OrgName := copy(VNames, 1, Pos(tbtchar('|'), VNames) - 1);
+ aType := VCType;
+ end;
+ Delete(VNames, 1, Pos(tbtchar('|'), VNames));
+ end;
+ Parser.Next;
+ if Parser.CurrTokenId = CSTI_CloseRound then
+ break;
+ if Parser.CurrTokenId <> CSTI_Semicolon then
+ begin
+ Parser.Free;
+ Result := False;
+ exit;
+ end;
+ Parser.Next;
+ end; {while}
+ end; {if}
+ Parser.Next;
+ end; {if}
+ if FuncType = 0 then
+ begin
+ if Parser.CurrTokenId <> CSTI_Colon then
+ begin
+ Parser.Free;
+ Result := False;
+ exit;
+ end;
+
+ Parser.Next;
+ VCType := Owner.FindType(Parser.GetToken);
+ if VCType = nil then
+ begin
+ Parser.Free;
+ Result := False;
+ exit;
+ end;
+ end
+ else if FuncType = 2 then {constructor}
+ begin
+ VCType := Owner.FindType(FClassName)
+ end else
+ VCType := nil;
+ DestDecl.Result := VCType;
+ Parser.Free;
+ if FuncType = 2 then
+ Func := mftConstructor
+ else
+ Func := mftProc;
+ Result := True;
+end;
+
+
+
+function TPSPascalCompiler.FindProc(const aName: tbtString): Cardinal;
+var
+ l, h: Longint;
+ x: TPSProcedure;
+ xr: TPSRegProc;
+ name: tbtString;
+
+begin
+ name := FastUpperCase(aName);
+ h := MakeHash(Name);
+ if FProcs = nil then
+ begin
+ result := InvalidVal;
+ Exit;
+ end;
+
+ for l := FProcs.Count - 1 downto 0 do
+ begin
+ x := FProcs.Data^[l];
+ if x.ClassType = TPSInternalProcedure then
+ begin
+ if (TPSInternalProcedure(x).NameHash = h) and
+ (TPSInternalProcedure(x).Name = Name) then
+ begin
+ Result := l;
+ exit;
+ end;
+ end
+ else
+ begin
+ if (TPSExternalProcedure(x).RegProc.NameHash = h) and
+ (TPSExternalProcedure(x).RegProc.Name = Name) then
+ begin
+ Result := l;
+ exit;
+ end;
+ end;
+ end;
+ for l := FRegProcs.Count - 1 downto 0 do
+ begin
+ xr := FRegProcs[l];
+ if (xr.NameHash = h) and (xr.Name = Name) then
+ begin
+ x := TPSExternalProcedure.Create;
+ TPSExternalProcedure(x).RegProc := xr;
+ FProcs.Add(x);
+ Result := FProcs.Count - 1;
+ exit;
+ end;
+ end;
+ Result := InvalidVal;
+end; {findfunc}
+
+function TPSPascalCompiler.UseExternalProc(const Name: tbtString): TPSParametersDecl;
+var
+ ProcNo: cardinal;
+ proc: TPSProcedure;
+begin
+ ProcNo := FindProc(FastUppercase(Name));
+ if ProcNo = InvalidVal then Result := nil
+ else
+ begin
+ proc := TPSProcedure(FProcs[ProcNo]);
+ if Proc is TPSExternalProcedure then
+ begin
+ Result := TPSExternalProcedure(Proc).RegProc.Decl;
+ end else result := nil;
+ end;
+end;
+
+
+
+function TPSPascalCompiler.FindBaseType(BaseType: TPSBaseType): TPSType;
+var
+ l: Longint;
+ x: TPSType;
+begin
+ for l := 0 to FTypes.Count -1 do
+ begin
+ X := FTypes[l];
+ if (x.BaseType = BaseType) and (x.ClassType = TPSType) then
+ begin
+ Result := at2ut(x);
+ exit;
+ end;
+ end;
+ X := TPSType.Create;
+ x.Name := '';
+ x.BaseType := BaseType;
+ {$IFDEF PS_USESSUPPORT}
+ x.DeclareUnit:=fModule;
+ {$ENDIF}
+ x.DeclarePos := InvalidVal;
+ x.DeclareCol := 0;
+ x.DeclareRow := 0;
+ FTypes.Add(x);
+ Result := at2ut(x);
+end;
+
+function TPSPascalCompiler.MakeDecl(decl: TPSParametersDecl): tbtString;
+var
+ i: Longint;
+begin
+ if Decl.Result = nil then result := '0' else
+ result := Decl.Result.Name;
+
+ for i := 0 to decl.ParamCount -1 do
+ begin
+ if decl.GetParam(i).Mode = pmIn then
+ Result := Result + ' @'
+ else
+ Result := Result + ' !';
+ Result := Result + decl.GetParam(i).aType.Name;
+ end;
+end;
+
+
+{ TPSPascalCompiler }
+
+const
+ BtTypeCopy = 255;
+
+
+type
+ TFuncType = (ftProc, ftFunc);
+
+function PS_mi2s(i: Cardinal): tbtString;
+begin
+ SetLength(Result, 4);
+ Cardinal((@Result[1])^) := i;
+end;
+
+
+
+
+function TPSPascalCompiler.AddType(const Name: tbtString; const BaseType: TPSBaseType): TPSType;
+begin
+ if FProcs = nil then
+ begin
+ raise EPSCompilerException.Create(RPS_OnUseEventOnly);
+ end;
+
+ case BaseType of
+ btProcPtr: Result := TPSProceduralType.Create;
+ BtTypeCopy: Result := TPSTypeLink.Create;
+ btRecord: Result := TPSRecordType.Create;
+ btArray: Result := TPSArrayType.Create;
+ btStaticArray: Result := TPSStaticArrayType.Create;
+ btEnum: Result := TPSEnumType.Create;
+ btClass: Result := TPSClassType.Create;
+ btExtClass: REsult := TPSUndefinedClassType.Create;
+ btNotificationVariant, btVariant: Result := TPSVariantType.Create;
+{$IFNDEF PS_NOINTERFACES}
+ btInterface: Result := TPSInterfaceType.Create;
+{$ENDIF}
+ else
+ Result := TPSType.Create;
+ end;
+ Result.Name := FastUppercase(Name);
+ Result.OriginalName := Name;
+ Result.BaseType := BaseType;
+ {$IFDEF PS_USESSUPPORT}
+ Result.DeclareUnit:=fModule;
+ {$ENDIF}
+ Result.DeclarePos := InvalidVal;
+ Result.DeclareCol := 0;
+ Result.DeclareRow := 0;
+ FTypes.Add(Result);
+end;
+
+
+function TPSPascalCompiler.AddFunction(const Header: tbtString): TPSRegProc;
+var
+ Parser: TPSPascalParser;
+ i: Integer;
+ IsFunction: Boolean;
+ VNames, Name: tbtString;
+ Decl: TPSParametersDecl;
+ modifier: TPSParameterMode;
+ VCType: TPSType;
+ x: TPSRegProc;
+begin
+ if FProcs = nil then
+ raise EPSCompilerException.Create(RPS_OnUseEventOnly);
+
+ Parser := TPSPascalParser.Create;
+ Parser.SetText(Header);
+ Decl := TPSParametersDecl.Create;
+ x := nil;
+ try
+ if Parser.CurrTokenId = CSTII_Function then
+ IsFunction := True
+ else if Parser.CurrTokenId = CSTII_Procedure then
+ IsFunction := False
+ else
+ Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, ['']);
+ Parser.Next;
+ if Parser.CurrTokenId <> CSTI_Identifier then
+ Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, ['']);
+ Name := Parser.OriginalToken;
+ Parser.Next;
+ if Parser.CurrTokenId = CSTI_OpenRound then
+ begin
+ Parser.Next;
+ if Parser.CurrTokenId <> CSTI_CloseRound then
+ begin
+ while True do
+ begin
+ if Parser.CurrTokenId = CSTII_Out then
+ begin
+ Modifier := pmOut;
+ Parser.Next;
+ end else
+ if Parser.CurrTokenId = CSTII_Const then
+ begin
+ Modifier := pmIn;
+ Parser.Next;
+ end else
+ if Parser.CurrTokenId = CSTII_Var then
+ begin
+ modifier := pmInOut;
+ Parser.Next;
+ end
+ else
+ modifier := pmIn;
+ if Parser.CurrTokenId <> CSTI_Identifier then
+ raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]);
+ VNames := Parser.OriginalToken + '|';
+ Parser.Next;
+ while Parser.CurrTokenId = CSTI_Comma do
+ begin
+ Parser.Next;
+ if Parser.CurrTokenId <> CSTI_Identifier then
+ Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]);
+ VNames := VNames + Parser.OriginalToken + '|';
+ Parser.Next;
+ end;
+ if Parser.CurrTokenId <> CSTI_Colon then
+ begin
+ Parser.Free;
+ Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]);
+ end;
+ Parser.Next;
+ VCType := FindType(Parser.GetToken);
+ if VCType = nil then
+ Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]);
+ while Pos(tbtchar('|'), VNames) > 0 do
+ begin
+ with Decl.AddParam do
+ begin
+ Mode := modifier;
+ OrgName := copy(VNames, 1, Pos(tbtchar('|'), VNames) - 1);
+ aType := VCType;
+ end;
+ Delete(VNames, 1, Pos(tbtchar('|'), VNames));
+ end;
+ Parser.Next;
+ if Parser.CurrTokenId = CSTI_CloseRound then
+ break;
+ if Parser.CurrTokenId <> CSTI_Semicolon then
+ Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]);
+ Parser.Next;
+ end; {while}
+ end; {if}
+ Parser.Next;
+ end; {if}
+ if IsFunction then
+ begin
+ if Parser.CurrTokenId <> CSTI_Colon then
+ Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]);
+
+ Parser.Next;
+ VCType := FindType(Parser.GetToken);
+ if VCType = nil then
+ Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]);
+ end
+ else
+ VCType := nil;
+ Decl.Result := VCType;
+ X := TPSRegProc.Create;
+ x.OrgName := Name;
+ x.Name := FastUpperCase(Name);
+ x.ExportName := True;
+ x.Decl.Assign(decl);
+ if Decl.Result = nil then
+ begin
+ x.ImportDecl := x.ImportDecl + #0;
+ end else
+ x.ImportDecl := x.ImportDecl + #1;
+ for i := 0 to Decl.ParamCount -1 do
+ begin
+ if Decl.Params[i].Mode <> pmIn then
+ x.ImportDecl := x.ImportDecl + #1
+ else
+ x.ImportDecl := x.ImportDecl + #0;
+ end;
+
+ FRegProcs.Add(x);
+ finally
+ Decl.Free;
+ Parser.Free;
+ end;
+ Result := x;
+end;
+
+function TPSPascalCompiler.MakeHint(const Module: tbtString; E: TPSPascalCompilerHintType; const Param: tbtString): TPSPascalCompilerMessage;
+var
+ n: TPSPascalCompilerHint;
+begin
+ N := TPSPascalCompilerHint.Create;
+ n.FHint := e;
+ n.SetParserPos(FParser);
+ n.FModuleName := Module;
+ n.FParam := Param;
+ FMessages.Add(n);
+ Result := n;
+end;
+
+function TPSPascalCompiler.MakeError(const Module: tbtString; E:
+ TPSPascalCompilerErrorType; const Param: tbtString): TPSPascalCompilerMessage;
+var
+ n: TPSPascalCompilerError;
+begin
+ N := TPSPascalCompilerError.Create;
+ n.FError := e;
+ n.SetParserPos(FParser);
+ {$IFNDEF PS_USESSUPPORT}
+ n.FModuleName := Module;
+ {$ELSE}
+ if Module <> '' then
+ n.FModuleName := Module
+ else
+ n.FModuleName := fModule;
+ {$ENDIF}
+ n.FParam := Param;
+ FMessages.Add(n);
+ Result := n;
+end;
+
+function TPSPascalCompiler.MakeWarning(const Module: tbtString; E:
+ TPSPascalCompilerWarningType; const Param: tbtString): TPSPascalCompilerMessage;
+var
+ n: TPSPascalCompilerWarning;
+begin
+ N := TPSPascalCompilerWarning.Create;
+ n.FWarning := e;
+ n.SetParserPos(FParser);
+ n.FModuleName := Module;
+ n.FParam := Param;
+ FMessages.Add(n);
+ Result := n;
+end;
+
+procedure TPSPascalCompiler.Clear;
+var
+ l: Longint;
+begin
+ FDebugOutput := '';
+ FOutput := '';
+ for l := 0 to FMessages.Count - 1 do
+ TPSPascalCompilerMessage(FMessages[l]).Free;
+ FMessages.Clear;
+ for L := FAutoFreeList.Count -1 downto 0 do
+ begin
+ TObject(FAutoFreeList[l]).Free;
+ end;
+ FAutoFreeList.Clear;
+end;
+
+procedure CopyVariantContents(Src, Dest: PIfRVariant);
+begin
+ case src.FType.BaseType of
+ btu8, bts8: dest^.tu8 := src^.tu8;
+ btu16, bts16: dest^.tu16 := src^.tu16;
+ btenum, btu32, bts32: dest^.tu32 := src^.tu32;
+ btsingle: Dest^.tsingle := src^.tsingle;
+ btdouble: Dest^.tdouble := src^.tdouble;
+ btextended: Dest^.textended := src^.textended;
+ btCurrency: Dest^.tcurrency := Src^.tcurrency;
+ btchar: Dest^.tchar := src^.tchar;
+ {$IFNDEF PS_NOINT64}bts64: dest^.ts64 := src^.ts64;{$ENDIF}
+ btset, btstring: tbtstring(dest^.tstring) := tbtstring(src^.tstring);
+ {$IFNDEF PS_NOWIDESTRING}
+ btunicodestring: tbtunicodestring(dest^.tunistring) := tbtunicodestring(src^.tunistring);
+ btwidestring: tbtwidestring(dest^.twidestring) := tbtwidestring(src^.twidestring);
+ btwidechar: Dest^.tchar := src^.tchar;
+ {$ENDIF}
+ end;
+end;
+
+function DuplicateVariant(Src: PIfRVariant): PIfRVariant;
+begin
+ New(Result);
+ FillChar(Result^, SizeOf(TIfRVariant), 0);
+ CopyVariantContents(Src, Result);
+end;
+
+
+procedure InitializeVariant(Vari: PIfRVariant; FType: TPSType);
+begin
+ FillChar(vari^, SizeOf(TIfRVariant), 0);
+ if FType.BaseType = btSet then
+ begin
+ SetLength(tbtstring(vari^.tstring), TPSSetType(FType).ByteSize);
+ fillchar(tbtstring(vari^.tstring)[1], length(tbtstring(vari^.tstring)), 0);
+ end;
+ vari^.FType := FType;
+end;
+
+function NewVariant(FType: TPSType): PIfRVariant;
+begin
+ New(Result);
+ InitializeVariant(Result, FType);
+end;
+
+procedure FinalizeA(var s: tbtString); overload; begin s := ''; end;
+procedure FinalizeW(var s: tbtwidestring); overload; begin s := ''; end;
+procedure FinalizeU(var s: tbtunicodestring); overload; begin s := ''; end;
+
+procedure FinalizeVariant(var p: TIfRVariant);
+begin
+ if (p.FType.BaseType = btString) or (p.FType.basetype = btSet) then
+ finalizeA(tbtstring(p.tstring))
+ {$IFNDEF PS_NOWIDESTRING}
+ else if p.FType.BaseType = btWideString then
+ finalizeW(tbtWideString(p.twidestring)) // tbtwidestring
+ else if p.FType.BaseType = btUnicodeString then
+ finalizeU(tbtUnicodeString(p.tunistring)); // tbtwidestring
+ {$ENDIF}
+end;
+
+procedure DisposeVariant(p: PIfRVariant);
+begin
+ if p <> nil then
+ begin
+ FinalizeVariant(p^);
+ Dispose(p);
+ end;
+end;
+
+
+
+function TPSPascalCompiler.GetTypeCopyLink(p: TPSType): TPSType;
+begin
+ if p = nil then
+ Result := nil
+ else
+ if p.BaseType = BtTypeCopy then
+ begin
+ Result := TPSTypeLink(p).LinkTypeNo;
+ end else Result := p;
+end;
+
+function IsIntType(b: TPSBaseType): Boolean;
+begin
+ case b of
+ btU8, btS8, btU16, btS16, btU32, btS32{$IFNDEF PS_NOINT64}, btS64{$ENDIF}: Result := True;
+ else
+ Result := False;
+ end;
+end;
+
+function IsRealType(b: TPSBaseType): Boolean;
+begin
+ case b of
+ btSingle, btDouble, btCurrency, btExtended: Result := True;
+ else
+ Result := False;
+ end;
+end;
+
+function IsIntRealType(b: TPSBaseType): Boolean;
+begin
+ case b of
+ btSingle, btDouble, btCurrency, btExtended, btU8, btS8, btU16, btS16, btU32, btS32{$IFNDEF PS_NOINT64}, btS64{$ENDIF}:
+ Result := True;
+ else
+ Result := False;
+ end;
+
+end;
+
+function DiffRec(p1, p2: TPSSubItem): Boolean;
+begin
+ if p1.ClassType = p2.ClassType then
+ begin
+ if P1.ClassType = TPSSubNumber then
+ Result := TPSSubNumber(p1).SubNo <> TPSSubNumber(p2).SubNo
+ else if P1.ClassType = TPSSubValue then
+ Result := TPSSubValue(p1).SubNo <> TPSSubValue(p2).SubNo
+ else
+ Result := False;
+ end else Result := True;
+end;
+
+function SameReg(x1, x2: TPSValue): Boolean;
+var
+ I: Longint;
+begin
+ if (x1.ClassType = x2.ClassType) and (X1 is TPSValueVar) then
+ begin
+ if
+ ((x1.ClassType = TPSValueGlobalVar) and (TPSValueGlobalVar(x1).GlobalVarNo = TPSValueGlobalVar(x2).GlobalVarNo)) or
+ ((x1.ClassType = TPSValueLocalVar) and (TPSValueLocalVar(x1).LocalVarNo = TPSValueLocalVar(x2).LocalVarNo)) or
+ ((x1.ClassType = TPSValueParamVar) and (TPSValueParamVar(x1).ParamNo = TPSValueParamVar(x2).ParamNo)) or
+ ((x1.ClassType = TPSValueAllocatedStackVar) and (TPSValueAllocatedStackVar(x1).LocalVarNo = TPSValueAllocatedStackVar(x2).LocalVarNo)) then
+ begin
+ if TPSValueVar(x1).GetRecCount <> TPSValueVar(x2).GetRecCount then
+ begin
+ Result := False;
+ exit;
+ end;
+ for i := 0 to TPSValueVar(x1).GetRecCount -1 do
+ begin
+ if DiffRec(TPSValueVar(x1).RecItem[i], TPSValueVar(x2).RecItem[i]) then
+ begin
+ Result := False;
+ exit;
+ end;
+ end;
+ Result := True;
+ end else Result := False;
+ end
+ else
+ Result := False;
+end;
+
+function GetUInt(Src: PIfRVariant; var s: Boolean): Cardinal;
+begin
+ case Src.FType.BaseType of
+ btU8: Result := Src^.tu8;
+ btS8: Result := Src^.ts8;
+ btU16: Result := Src^.tu16;
+ btS16: Result := Src^.ts16;
+ btU32: Result := Src^.tu32;
+ btS32: Result := Src^.ts32;
+ {$IFNDEF PS_NOINT64}
+ bts64: Result := src^.ts64;
+ {$ENDIF}
+ btChar: Result := ord(Src^.tchar);
+ {$IFNDEF PS_NOWIDESTRING}
+ btWideChar: Result := ord(tbtwidechar(src^.twidechar));
+ {$ENDIF}
+ btEnum: Result := src^.tu32;
+ else
+ begin
+ s := False;
+ Result := 0;
+ end;
+ end;
+end;
+
+function GetInt(Src: PIfRVariant; var s: Boolean): Longint;
+begin
+ case Src.FType.BaseType of
+ btU8: Result := Src^.tu8;
+ btS8: Result := Src^.ts8;
+ btU16: Result := Src^.tu16;
+ btS16: Result := Src^.ts16;
+ btU32: Result := Src^.tu32;
+ btS32: Result := Src^.ts32;
+ {$IFNDEF PS_NOINT64}
+ bts64: Result := src^.ts64;
+ {$ENDIF}
+ btChar: Result := ord(Src^.tchar);
+ {$IFNDEF PS_NOWIDESTRING}
+ btWideChar: Result := ord(tbtwidechar(src^.twidechar));
+ {$ENDIF}
+ btEnum: Result := src^.tu32;
+ else
+ begin
+ s := False;
+ Result := 0;
+ end;
+ end;
+end;
+{$IFNDEF PS_NOINT64}
+function GetInt64(Src: PIfRVariant; var s: Boolean): Int64;
+begin
+ case Src.FType.BaseType of
+ btU8: Result := Src^.tu8;
+ btS8: Result := Src^.ts8;
+ btU16: Result := Src^.tu16;
+ btS16: Result := Src^.ts16;
+ btU32: Result := Src^.tu32;
+ btS32: Result := Src^.ts32;
+ bts64: Result := src^.ts64;
+ btChar: Result := ord(Src^.tchar);
+ {$IFNDEF PS_NOWIDESTRING}
+ btWideChar: Result := ord(tbtwidechar(src^.twidechar));
+ {$ENDIF}
+ btEnum: Result := src^.tu32;
+ else
+ begin
+ s := False;
+ Result := 0;
+ end;
+ end;
+end;
+{$ENDIF}
+
+function GetReal(Src: PIfRVariant; var s: Boolean): Extended;
+begin
+ case Src.FType.BaseType of
+ btU8: Result := Src^.tu8;
+ btS8: Result := Src^.ts8;
+ btU16: Result := Src^.tu16;
+ btS16: Result := Src^.ts16;
+ btU32: Result := Src^.tu32;
+ btS32: Result := Src^.ts32;
+ {$IFNDEF PS_NOINT64}
+ bts64: Result := src^.ts64;
+ {$ENDIF}
+ btChar: Result := ord(Src^.tchar);
+ {$IFNDEF PS_NOWIDESTRING}
+ btWideChar: Result := ord(tbtwidechar(src^.twidechar));
+ {$ENDIF}
+ btSingle: Result := Src^.tsingle;
+ btDouble: Result := Src^.tdouble;
+ btCurrency: Result := SRc^.tcurrency;
+ btExtended: Result := Src^.textended;
+ else
+ begin
+ s := False;
+ Result := 0;
+ end;
+ end;
+end;
+
+function GetString(Src: PIfRVariant; var s: Boolean): tbtString;
+begin
+ case Src.FType.BaseType of
+ btChar: Result := Src^.tchar;
+ btString: Result := tbtstring(src^.tstring);
+ {$IFNDEF PS_NOWIDESTRING}
+ btWideChar: Result := tbtstring(src^.twidechar);
+ btWideString: Result := tbtstring(tbtWideString(src^.twidestring));
+ btUnicodeString: Result := tbtstring(tbtUnicodeString(src^.tunistring));
+ {$ENDIF}
+ else
+ begin
+ s := False;
+ Result := '';
+ end;
+ end;
+end;
+
+{$IFNDEF PS_NOWIDESTRING}
+function TPSPascalCompiler.GetWideString(Src: PIfRVariant; var s: Boolean): tbtwidestring;
+begin
+ case Src.FType.BaseType of
+ btChar: Result := tbtWidestring(Src^.tchar);
+ btString: Result := tbtWidestring(tbtstring(src^.tstring));
+ btWideChar: Result := src^.twidechar;
+ btWideString: Result := tbtWideString(src^.twidestring);
+ btUnicodeString: result := tbtUnicodeString(src^.tunistring);
+ else
+ begin
+ s := False;
+ Result := '';
+ end;
+ end;
+end;
+function TPSPascalCompiler.GetUnicodeString(Src: PIfRVariant; var s: Boolean): tbtunicodestring;
+begin
+ case Src.FType.BaseType of
+ btChar: Result := tbtWidestring(Src^.tchar);
+ btString: Result := tbtWidestring(tbtstring(src^.tstring));
+ btWideChar: Result := src^.twidechar;
+ btWideString: Result := tbtWideString(src^.twidestring);
+ btUnicodeString: result := tbtUnicodeString(src^.tunistring);
+ else
+ begin
+ s := False;
+ Result := '';
+ end;
+ end;
+end;
+{$ENDIF}
+
+function ab(b: Longint): Longint;
+begin
+ ab := Longint(b = 0);
+end;
+
+procedure Set_Union(Dest, Src: PByteArray; ByteSize: Integer);
+var
+ i: Longint;
+begin
+ for i := ByteSize -1 downto 0 do
+ Dest^[i] := Dest^[i] or Src^[i];
+end;
+
+procedure Set_Diff(Dest, Src: PByteArray; ByteSize: Integer);
+var
+ i: Longint;
+begin
+ for i := ByteSize -1 downto 0 do
+ Dest^[i] := Dest^[i] and not Src^[i];
+end;
+
+procedure Set_Intersect(Dest, Src: PByteArray; ByteSize: Integer);
+var
+ i: Longint;
+begin
+ for i := ByteSize -1 downto 0 do
+ Dest^[i] := Dest^[i] and Src^[i];
+end;
+
+procedure Set_Subset(Dest, Src: PByteArray; ByteSize: Integer; var Val: Boolean);
+var
+ i: Integer;
+begin
+ for i := ByteSize -1 downto 0 do
+ begin
+ if not (Src^[i] and Dest^[i] = Dest^[i]) then
+ begin
+ Val := False;
+ exit;
+ end;
+ end;
+ Val := True;
+end;
+
+procedure Set_Equal(Dest, Src: PByteArray; ByteSize: Integer; var Val: Boolean);
+var
+ i: Longint;
+begin
+ for i := ByteSize -1 downto 0 do
+ begin
+ if Dest^[i] <> Src^[i] then
+ begin
+ Val := False;
+ exit;
+ end;
+ end;
+ val := True;
+end;
+
+procedure Set_membership(Item: Longint; Src: PByteArray; var Val: Boolean);
+begin
+ Val := (Src^[Item shr 3] and (1 shl (Item and 7))) <> 0;
+end;
+
+procedure Set_MakeMember(Item: Longint; Src: PByteArray);
+begin
+ Src^[Item shr 3] := Src^[Item shr 3] or (1 shl (Item and 7));
+end;
+
+procedure ConvertToBoolean(SE: TPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIFRVariant; b: Boolean);
+begin
+ FinalizeVariant(var1^);
+ if FUseUsedTypes then
+ Var1^.FType := se.at2ut(se.FDefaultBoolType)
+ else
+ Var1^.FType := Se.FDefaultBoolType;
+ var1^.tu32 := Ord(b);
+end;
+
+procedure ConvertToString(SE: TPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIFRVariant; const s: tbtString);
+var
+ atype: TPSType;
+begin
+ FinalizeVariant(var1^);
+ atype := se.FindBaseType(btString);
+ if FUseUsedTypes then
+ InitializeVariant(var1, se.at2ut(atype))
+ else
+ InitializeVariant(var1, atype);
+ tbtstring(var1^.tstring) := s;
+end;
+{$IFNDEF PS_NOWIDESTRING}
+procedure ConvertToUnicodeString(SE: TPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIFRVariant; const s: tbtunicodestring);
+var
+ atype: TPSType;
+begin
+ FinalizeVariant(var1^);
+ atype := se.FindBaseType(btUnicodeString);
+ if FUseUsedTypes then
+ InitializeVariant(var1, se.at2ut(atype))
+ else
+ InitializeVariant(var1, atype);
+ tbtunicodestring(var1^.tunistring) := s;
+end;
+{$ENDIF}
+procedure ConvertToFloat(SE: TPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIfRVariant; NewType: TPSType);
+var
+ vartemp: PIfRVariant;
+ b: Boolean;
+begin
+ New(vartemp);
+ b := false;
+ if FUseUsedTypes then
+ NewType := se.at2ut(NewType);
+ InitializeVariant(vartemp, var1.FType);
+ CopyVariantContents(var1, vartemp);
+ FinalizeVariant(var1^);
+ InitializeVariant(var1, newtype);
+ case var1.ftype.basetype of
+ btSingle:
+ begin
+ if (vartemp.ftype.BaseType = btu8) or (vartemp.ftype.BaseType = btu16) or (vartemp.ftype.BaseType = btu32) then
+ var1^.tsingle := GetUInt(vartemp, b)
+ else
+ var1^.tsingle := GetInt(vartemp, b)
+ end;
+ btDouble:
+ begin
+ if (vartemp.ftype.BaseType = btu8) or (vartemp.ftype.BaseType = btu16) or (vartemp.ftype.BaseType = btu32) then
+ var1^.tdouble := GetUInt(vartemp, b)
+ else
+ var1^.tdouble := GetInt(vartemp, b)
+ end;
+ btExtended:
+ begin
+ if (vartemp.ftype.BaseType = btu8) or (vartemp.ftype.BaseType = btu16) or (vartemp.ftype.BaseType = btu32) then
+ var1^.textended:= GetUInt(vartemp, b)
+ else
+ var1^.textended:= GetInt(vartemp, b)
+ end;
+ btCurrency:
+ begin
+ if (vartemp.ftype.BaseType = btu8) or (vartemp.ftype.BaseType = btu16) or (vartemp.ftype.BaseType = btu32) then
+ var1^.tcurrency:= GetUInt(vartemp, b)
+ else
+ var1^.tcurrency:= GetInt(vartemp, b)
+ end;
+ end;
+ DisposeVariant(vartemp);
+end;
+
+
+function TPSPascalCompiler.IsCompatibleType(p1, p2: TPSType; Cast: Boolean): Boolean;
+begin
+ if
+ ((p1.BaseType = btProcPtr) and (p2 = p1)) or
+ (p1.BaseType = btPointer) or
+ (p2.BaseType = btPointer) or
+ ((p1.BaseType = btNotificationVariant) or (p1.BaseType = btVariant)) or
+ ((p2.BaseType = btNotificationVariant) or (p2.BaseType = btVariant)) or
+ (IsIntType(p1.BaseType) and IsIntType(p2.BaseType)) or
+ (IsRealType(p1.BaseType) and IsIntRealType(p2.BaseType)) or
+ (((p1.basetype = btPchar) or (p1.BaseType = btString)) and ((p2.BaseType = btString) or (p2.BaseType = btPchar))) or
+ (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btChar)) or
+ (((p1.BaseType = btArray) or (p1.BaseType = btStaticArray)) and (
+ (p2.BaseType = btArray) or (p2.BaseType = btStaticArray)) and IsCompatibleType(TPSArrayType(p1).ArrayTypeNo, TPSArrayType(p2).ArrayTypeNo, False)) or
+ ((p1.BaseType = btChar) and (p2.BaseType = btChar)) or
+ ((p1.BaseType = btSet) and (p2.BaseType = btSet)) or
+ {$IFNDEF PS_NOWIDESTRING}
+ ((p1.BaseType = btWideChar) and (p2.BaseType = btChar)) or
+ ((p1.BaseType = btWideChar) and (p2.BaseType = btWideChar)) or
+ ((p1.BaseType = btWidestring) and (p2.BaseType = btChar)) or
+ ((p1.BaseType = btWidestring) and (p2.BaseType = btWideChar)) or
+ ((p1.BaseType = btWidestring) and ((p2.BaseType = btString) or (p2.BaseType = btPchar) or (p2.BaseType = btUnicodeString))) or
+ ((p1.BaseType = btWidestring) and ((p2.BaseType = btWidestring))) or
+ ((p1.BaseType = btUnicodeString) and (p2.BaseType = btChar)) or
+ ((p1.BaseType = btUnicodeString) and (p2.BaseType = btWideChar)) or
+ ((p1.BaseType = btUnicodeString) and ((p2.BaseType = btString) or (p2.BaseType = btPchar) or (p2.BaseType = btUnicodeString))) or
+ ((p1.BaseType = btUnicodeString) and (p2.BaseType = btWidestring)) or
+ (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btWideString)or (p2.BaseType = btUnicodeString)) or
+ (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btWidechar)) or
+ (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btchar)) or
+ {$ENDIF}
+ ((p1.BaseType = btRecord) and (p2.BaseType = btrecord) and (not IsVarInCompatible(p1, p2))) or
+ ((p1.BaseType = btEnum) and (p2.BaseType = btEnum)) or
+ (Cast and IsIntType(P1.BaseType) and (p2.baseType = btEnum)) or
+ (Cast and (p1.baseType = btEnum) and IsIntType(P2.BaseType))
+ then
+ Result := True
+ // nx change start - allow casting class -> integer and vice versa
+ else if p1.BaseType = btclass then
+ Result := TPSClassType(p1).cl.IsCompatibleWith(p2) or (p2.BaseType in [btU32, btS32])
+ else if (p1.BaseType in [btU32, btS32]) then
+ Result := (p2.BaseType = btClass)
+ // nx change end
+{$IFNDEF PS_NOINTERFACES}
+ else if p1.BaseType = btInterface then
+ Result := TPSInterfaceType(p1).Intf.IsCompatibleWith(p2)
+{$ENDIF}
+ else if ((p1.BaseType = btExtClass) and (p2.BaseType = btExtClass)) then
+ begin
+ Result := TPSUndefinedClassType(p1).ExtClass.IsCompatibleWith(TPSUndefinedClassType(p2).ExtClass);
+ end
+ else
+ Result := False;
+end;
+
+
+function TPSPascalCompiler.PreCalc(FUseUsedTypes: Boolean; Var1Mod: Byte; var1: PIFRVariant; Var2Mod: Byte; Var2: PIfRVariant; Cmd: TPSBinOperatorType; Pos, Row, Col: Cardinal): Boolean;
+ { var1=dest, var2=src }
+var
+ b: Boolean;
+
+begin
+ Result := True;
+ try
+ if (IsRealType(var2.FType.BaseType) and IsIntType(var1.FType.BaseType)) then
+ ConvertToFloat(Self, FUseUsedTypes, var1, var2^.FType);
+ case Cmd of
+ otAdd:
+ begin { + }
+ case var1.FType.BaseType of
+ btU8: var1^.tu8 := var1^.tu8 + GetUint(Var2, Result);
+ btS8: var1^.ts8 := var1^.ts8 + GetInt(Var2, Result);
+ btU16: var1^.tu16 := var1^.tu16 + GetUint(Var2, Result);
+ btS16: var1^.ts16 := var1^.ts16 + Getint(Var2, Result);
+ btEnum, btU32: var1^.tu32 := var1^.tu32 + GetUint(Var2, Result);
+ btS32: var1^.ts32 := var1^.ts32 + Getint(Var2, Result);
+ {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 + GetInt64(Var2, Result); {$ENDIF}
+ btSingle: var1^.tsingle := var1^.tsingle + GetReal( Var2, Result);
+ btDouble: var1^.tdouble := var1^.tdouble + GetReal( Var2, Result);
+ btExtended: var1^.textended := var1^.textended + GetReal( Var2, Result);
+ btCurrency: var1^.tcurrency := var1^.tcurrency + GetReal( Var2, Result);
+ btSet:
+ begin
+ if (var1.FType = var2.FType) then
+ begin
+ Set_Union(var1.tstring, var2.tstring, TPSSetType(var1.FType).ByteSize);
+ end else Result := False;
+ end;
+ btChar:
+ begin
+ ConvertToString(Self, FUseUsedTypes, var1, getstring(Var1, b)+getstring(Var2, b));
+ end;
+ btString: tbtstring(var1^.tstring) := tbtstring(var1^.tstring) + GetString(Var2, Result);
+ {$IFNDEF PS_NOWIDESTRING}
+ btwideString: tbtwidestring(var1^.twidestring) := tbtwidestring(var1^.twidestring) + GetWideString(Var2, Result);
+ btUnicodeString: tbtunicodestring(var1^.tunistring) := tbtunicodestring(var1^.tunistring) + GetUnicodeString(Var2, Result);
+ btWidechar:
+ begin
+ ConvertToUnicodeString(Self, FUseUsedTypes, var1, GetUnicodeString(Var1, b)+GetUnicodeString(Var2, b));
+ end;
+ {$ENDIF}
+ else Result := False;
+ end;
+ end;
+ otSub:
+ begin { - }
+ case Var1.FType.BaseType of
+ btU8: var1^.tu8 := var1^.tu8 - GetUint(Var2, Result);
+ btS8: var1^.ts8 := var1^.ts8 - Getint(Var2, Result);
+ btU16: var1^.tu16 := var1^.tu16 - GetUint(Var2, Result);
+ btS16: var1^.ts16 := var1^.ts16 - Getint(Var2, Result);
+ btEnum, btU32: var1^.tu32 := var1^.tu32 - GetUint(Var2, Result);
+ btS32: var1^.ts32 := var1^.ts32 - Getint(Var2, Result);
+ {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 - GetInt64(Var2, Result); {$ENDIF}
+ btSingle: var1^.tsingle := var1^.tsingle - GetReal( Var2, Result);
+ btDouble: var1^.tdouble := var1^.tdouble - GetReal(Var2, Result);
+ btExtended: var1^.textended := var1^.textended - GetReal(Var2, Result);
+ btCurrency: var1^.tcurrency := var1^.tcurrency - GetReal( Var2, Result);
+ btSet:
+ begin
+ if (var1.FType = var2.FType) then
+ begin
+ Set_Diff(var1.tstring, var2.tstring, TPSSetType(var1.FType).ByteSize);
+ end else Result := False;
+ end;
+ else Result := False;
+ end;
+ end;
+ otMul:
+ begin { * }
+ case Var1.FType.BaseType of
+ btU8: var1^.tu8 := var1^.tu8 * GetUint(Var2, Result);
+ btS8: var1^.ts8 := var1^.ts8 * Getint(Var2, Result);
+ btU16: var1^.tu16 := var1^.tu16 * GetUint(Var2, Result);
+ btS16: var1^.ts16 := var1^.ts16 * Getint(Var2, Result);
+ btU32: var1^.tu32 := var1^.tu32 * GetUint(Var2, Result);
+ btS32: var1^.ts32 := var1^.ts32 * Getint(Var2, Result);
+ {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 * GetInt64(Var2, Result); {$ENDIF}
+ btSingle: var1^.tsingle := var1^.tsingle * GetReal(Var2, Result);
+ btDouble: var1^.tdouble := var1^.tdouble * GetReal(Var2, Result);
+ btExtended: var1^.textended := var1^.textended * GetReal( Var2, Result);
+ btCurrency: var1^.tcurrency := var1^.tcurrency * GetReal( Var2, Result);
+ btSet:
+ begin
+ if (var1.FType = var2.FType) then
+ begin
+ Set_Intersect(var1.tstring, var2.tstring, TPSSetType(var1.FType).ByteSize);
+ end else Result := False;
+ end;
+ else Result := False;
+ end;
+ end;
+ otDiv:
+ begin { / }
+ case Var1.FType.BaseType of
+ btU8: var1^.tu8 := var1^.tu8 div GetUint(Var2, Result);
+ btS8: var1^.ts8 := var1^.ts8 div Getint(Var2, Result);
+ btU16: var1^.tu16 := var1^.tu16 div GetUint(Var2, Result);
+ btS16: var1^.ts16 := var1^.ts16 div Getint(Var2, Result);
+ btU32: var1^.tu32 := var1^.tu32 div GetUint(Var2, Result);
+ btS32: var1^.ts32 := var1^.ts32 div Getint(Var2, Result);
+ {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 div GetInt64(Var2, Result); {$ENDIF}
+ btSingle: var1^.tsingle := var1^.tsingle / GetReal( Var2, Result);
+ btDouble: var1^.tdouble := var1^.tdouble / GetReal( Var2, Result);
+ btExtended: var1^.textended := var1^.textended / GetReal( Var2, Result);
+ btCurrency: var1^.tcurrency := var1^.tcurrency / GetReal( Var2, Result);
+ else Result := False;
+ end;
+ end;
+ otMod:
+ begin { MOD }
+ case Var1.FType.BaseType of
+ btU8: var1^.tu8 := var1^.tu8 mod GetUint(Var2, Result);
+ btS8: var1^.ts8 := var1^.ts8 mod Getint(Var2, Result);
+ btU16: var1^.tu16 := var1^.tu16 mod GetUint(Var2, Result);
+ btS16: var1^.ts16 := var1^.ts16 mod Getint(Var2, Result);
+ btU32: var1^.tu32 := var1^.tu32 mod GetUint(Var2, Result);
+ btS32: var1^.ts32 := var1^.ts32 mod Getint(Var2, Result);
+ {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 mod GetInt64(Var2, Result); {$ENDIF}
+ else Result := False;
+ end;
+ end;
+ otshl:
+ begin { SHL }
+ case Var1.FType.BaseType of
+ btU8: var1^.tu8 := var1^.tu8 shl GetUint(Var2, Result);
+ btS8: var1^.ts8 := var1^.ts8 shl Getint(Var2, Result);
+ btU16: var1^.tu16 := var1^.tu16 shl GetUint(Var2, Result);
+ btS16: var1^.ts16 := var1^.ts16 shl Getint(Var2, Result);
+ btU32: var1^.tu32 := var1^.tu32 shl GetUint(Var2, Result);
+ btS32: var1^.ts32 := var1^.ts32 shl Getint(Var2, Result);
+ {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 shl GetInt64(Var2, Result); {$ENDIF}
+ else Result := False;
+ end;
+ end;
+ otshr:
+ begin { SHR }
+ case Var1.FType.BaseType of
+ btU8: var1^.tu8 := var1^.tu8 shr GetUint(Var2, Result);
+ btS8: var1^.ts8 := var1^.ts8 shr Getint(Var2, Result);
+ btU16: var1^.tu16 := var1^.tu16 shr GetUint(Var2, Result);
+ btS16: var1^.ts16 := var1^.ts16 shr Getint(Var2, Result);
+ btU32: var1^.tu32 := var1^.tu32 shr GetUint(Var2, Result);
+ btS32: var1^.ts32 := var1^.ts32 shr Getint(Var2, Result);
+ {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 shr GetInt64( Var2, Result); {$ENDIF}
+ else Result := False;
+ end;
+ end;
+ otAnd:
+ begin { AND }
+ case Var1.FType.BaseType of
+ btU8: var1^.tu8 := var1^.tu8 and GetUint(Var2, Result);
+ btS8: var1^.ts8 := var1^.ts8 and Getint(Var2, Result);
+ btU16: var1^.tu16 := var1^.tu16 and GetUint(Var2, Result);
+ btS16: var1^.ts16 := var1^.ts16 and Getint(Var2, Result);
+ btU32: var1^.tu32 := var1^.tu32 and GetUint(Var2, Result);
+ btS32: var1^.ts32 := var1^.ts32 and Getint(Var2, Result);
+ btEnum: var1^.ts32 := var1^.ts32 and Getint(Var2, Result);
+ {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 and GetInt64(Var2, Result); {$ENDIF}
+ else Result := False;
+ end;
+ end;
+ otor:
+ begin { OR }
+ case Var1.FType.BaseType of
+ btU8: var1^.tu8 := var1^.tu8 or GetUint(Var2, Result);
+ btS8: var1^.ts8 := var1^.ts8 or Getint(Var2, Result);
+ btU16: var1^.tu16 := var1^.tu16 or GetUint(Var2, Result);
+ btS16: var1^.ts16 := var1^.ts16 or Getint(Var2, Result);
+ btU32: var1^.tu32 := var1^.tu32 or GetUint(Var2, Result);
+ btS32: var1^.ts32 := var1^.ts32 or Getint(Var2, Result);
+ {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 or GetInt64(Var2, Result); {$ENDIF}
+ btEnum: var1^.ts32 := var1^.ts32 or Getint(Var2, Result);
+ else Result := False;
+ end;
+ end;
+ otxor:
+ begin { XOR }
+ case Var1.FType.BaseType of
+ btU8: var1^.tu8 := var1^.tu8 xor GetUint(Var2, Result);
+ btS8: var1^.ts8 := var1^.ts8 xor Getint(Var2, Result);
+ btU16: var1^.tu16 := var1^.tu16 xor GetUint(Var2, Result);
+ btS16: var1^.ts16 := var1^.ts16 xor Getint(Var2, Result);
+ btU32: var1^.tu32 := var1^.tu32 xor GetUint(Var2, Result);
+ btS32: var1^.ts32 := var1^.ts32 xor Getint(Var2, Result);
+ {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 xor GetInt64(Var2, Result); {$ENDIF}
+ btEnum: var1^.ts32 := var1^.ts32 xor Getint(Var2, Result);
+ else Result := False;
+ end;
+ end;
+ otGreaterEqual:
+ begin { >= }
+ case Var1.FType.BaseType of
+ btU8: b := var1^.tu8 >= GetUint(Var2, Result);
+ btS8: b := var1^.ts8 >= Getint(Var2, Result);
+ btU16: b := var1^.tu16 >= GetUint(Var2, Result);
+ btS16: b := var1^.ts16 >= Getint(Var2, Result);
+ btU32: b := var1^.tu32 >= GetUint(Var2, Result);
+ btS32: b := var1^.ts32 >= Getint(Var2, Result);
+ {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 >= GetInt64(Var2, Result); {$ENDIF}
+ btSingle: b := var1^.tsingle >= GetReal( Var2, Result);
+ btDouble: b := var1^.tdouble >= GetReal( Var2, Result);
+ btExtended: b := var1^.textended >= GetReal( Var2, Result);
+ btCurrency: b := var1^.tcurrency >= GetReal( Var2, Result);
+ btSet:
+ begin
+ if (var1.FType = var2.FType) then
+ begin
+ Set_Subset(var2.tstring, var1.tstring, TPSSetType(var1.FType).ByteSize, b);
+ end else Result := False;
+ end;
+ else
+ Result := False;
+ end;
+ ConvertToBoolean(Self, FUseUsedTypes, Var1, b);
+ end;
+ otLessEqual:
+ begin { <= }
+ case Var1.FType.BaseType of
+ btU8: b := var1^.tu8 <= GetUint(Var2, Result);
+ btS8: b := var1^.ts8 <= Getint(Var2, Result);
+ btU16: b := var1^.tu16 <= GetUint(Var2, Result);
+ btS16: b := var1^.ts16 <= Getint(Var2, Result);
+ btU32: b := var1^.tu32 <= GetUint(Var2, Result);
+ btS32: b := var1^.ts32 <= Getint(Var2, Result);
+ {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 <= GetInt64(Var2, Result); {$ENDIF}
+ btSingle: b := var1^.tsingle <= GetReal( Var2, Result);
+ btDouble: b := var1^.tdouble <= GetReal( Var2, Result);
+ btExtended: b := var1^.textended <= GetReal( Var2, Result);
+ btCurrency: b := var1^.tcurrency <= GetReal( Var2, Result);
+ btSet:
+ begin
+ if (var1.FType = var2.FType) then
+ begin
+ Set_Subset(var1.tstring, var2.tstring, TPSSetType(var1.FType).ByteSize, b);
+ end else Result := False;
+ end;
+ else
+ Result := False;
+ end;
+ ConvertToBoolean(Self, FUseUsedTypes, Var1, b);
+ end;
+ otGreater:
+ begin { > }
+ case Var1.FType.BaseType of
+ btU8: b := var1^.tu8 > GetUint(Var2, Result);
+ btS8: b := var1^.ts8 > Getint(Var2, Result);
+ btU16: b := var1^.tu16 > GetUint(Var2, Result);
+ btS16: b := var1^.ts16 > Getint(Var2, Result);
+ btU32: b := var1^.tu32 > GetUint(Var2, Result);
+ btS32: b := var1^.ts32 > Getint(Var2, Result);
+ {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 > GetInt64(Var2, Result); {$ENDIF}
+ btSingle: b := var1^.tsingle > GetReal( Var2, Result);
+ btDouble: b := var1^.tdouble > GetReal( Var2, Result);
+ btExtended: b := var1^.textended > GetReal( Var2, Result);
+ btCurrency: b := var1^.tcurrency > GetReal( Var2, Result);
+ else
+ Result := False;
+ end;
+ ConvertToBoolean(Self, FUseUsedTypes, Var1, b);
+ end;
+ otLess:
+ begin { < }
+ case Var1.FType.BaseType of
+ btU8: b := var1^.tu8 < GetUint(Var2, Result);
+ btS8: b := var1^.ts8 < Getint(Var2, Result);
+ btU16: b := var1^.tu16 < GetUint(Var2, Result);
+ btS16: b := var1^.ts16 < Getint(Var2, Result);
+ btU32: b := var1^.tu32 < GetUint(Var2, Result);
+ btS32: b := var1^.ts32 < Getint(Var2, Result);
+ {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 < GetInt64(Var2, Result); {$ENDIF}
+ btSingle: b := var1^.tsingle < GetReal( Var2, Result);
+ btDouble: b := var1^.tdouble < GetReal( Var2, Result);
+ btExtended: b := var1^.textended < GetReal( Var2, Result);
+ btCurrency: b := var1^.tcurrency < GetReal( Var2, Result);
+ else
+ Result := False;
+ end;
+ ConvertToBoolean(Self, FUseUsedTypes, Var1, b);
+ end;
+ otNotEqual:
+ begin { <> }
+ case Var1.FType.BaseType of
+ btU8: b := var1^.tu8 <> GetUint(Var2, Result);
+ btS8: b := var1^.ts8 <> Getint(Var2, Result);
+ btU16: b := var1^.tu16 <> GetUint(Var2, Result);
+ btS16: b := var1^.ts16 <> Getint(Var2, Result);
+ btU32: b := var1^.tu32 <> GetUint(Var2, Result);
+ {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 <> GetInt64(Var2, Result); {$ENDIF}
+ btS32: b := var1^.ts32 <> Getint(Var2, Result);
+ btSingle: b := var1^.tsingle <> GetReal( Var2, Result);
+ btDouble: b := var1^.tdouble <> GetReal( Var2, Result);
+ btExtended: b := var1^.textended <> GetReal( Var2, Result);
+ btCurrency: b := var1^.tcurrency <> GetReal( Var2, Result);
+ btEnum: b := var1^.ts32 <> Getint(Var2, Result);
+ btString: b := tbtstring(var1^.tstring) <> GetString(var2, Result);
+ btChar: b := var1^.tchar <> GetString(var2, Result);
+ {$IFNDEF PS_NOWIDESTRING}
+ btWideString: b := tbtWideString(var1^.twidestring) <> GetWideString(var2, Result);
+ btUnicodeString: b := tbtUnicodeString(var1^.tunistring) <> GetUnicodeString(var2, Result);
+ btWideChar: b := var1^.twidechar <> GetUnicodeString(var2, Result);
+ {$ENDIF}
+ btSet:
+ begin
+ if (var1.FType = var2.FType) then
+ begin
+ Set_Equal(var1.tstring, var2.tstring, TPSSetType(var1.FType).GetByteSize, b);
+ b := not b;
+ end else Result := False;
+ end;
+ else
+ Result := False;
+ end;
+ ConvertToBoolean(Self, FUseUsedTypes, Var1, b);
+ end;
+ otEqual:
+ begin { = }
+ case Var1.FType.BaseType of
+ btU8: b := var1^.tu8 = GetUint(Var2, Result);
+ btS8: b := var1^.ts8 = Getint(Var2, Result);
+ btU16: b := var1^.tu16 = GetUint(Var2, Result);
+ btS16: b := var1^.ts16 = Getint(Var2, Result);
+ btU32: b := var1^.tu32 = GetUint(Var2, Result);
+ btS32: b := var1^.ts32 = Getint(Var2, Result);
+ {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 = GetInt64(Var2, Result); {$ENDIF}
+ btSingle: b := var1^.tsingle = GetReal( Var2, Result);
+ btDouble: b := var1^.tdouble = GetReal( Var2, Result);
+ btExtended: b := var1^.textended = GetReal( Var2, Result);
+ btCurrency: b := var1^.tcurrency = GetReal( Var2, Result);
+ btEnum: b := var1^.ts32 = Getint(Var2, Result);
+ btString: b := tbtstring(var1^.tstring) = GetString(var2, Result);
+ btChar: b := var1^.tchar = GetString(var2, Result);
+ {$IFNDEF PS_NOWIDESTRING}
+ btWideString: b := tbtWideString(var1^.twidestring) = GetWideString(var2, Result);
+ btUnicodeString: b := tbtUnicodeString(var1^.twidestring) = GetUnicodeString(var2, Result);
+ btWideChar: b := var1^.twidechar = GetUnicodeString(var2, Result);
+ {$ENDIF}
+ btSet:
+ begin
+ if (var1.FType = var2.FType) then
+ begin
+ Set_Equal(var1.tstring, var2.tstring, TPSSetType(var1.FType).ByteSize, b);
+ end else Result := False;
+ end;
+ else
+ Result := False;
+ end;
+ ConvertToBoolean(Self, FUseUsedTypes, Var1, b);
+ end;
+ otIn:
+ begin
+ if (var2.Ftype.BaseType = btset) and (TPSSetType(var2).SetType = Var1.FType) then
+ begin
+ Set_membership(GetUint(var1, result), var2.tstring, b);
+ end else Result := False;
+ end;
+ else
+ Result := False;
+ end;
+ except
+ on E: EDivByZero do
+ begin
+ Result := False;
+ MakeError('', ecDivideByZero, '');
+ Exit;
+ end;
+ on E: EZeroDivide do
+ begin
+ Result := False;
+ MakeError('', ecDivideByZero, '');
+ Exit;
+ end;
+ on E: EMathError do
+ begin
+ Result := False;
+ MakeError('', ecMathError, tbtstring(e.Message));
+ Exit;
+ end;
+ on E: Exception do
+ begin
+ Result := False;
+ MakeError('', ecInternalError, tbtstring(E.Message));
+ Exit;
+ end;
+ end;
+ if not Result then
+ begin
+ with MakeError('', ecTypeMismatch, '') do
+ begin
+ FPosition := Pos;
+ FRow := Row;
+ FCol := Col;
+ end;
+ end;
+end;
+
+function TPSPascalCompiler.IsDuplicate(const s: tbtString; const check: TPSDuplicCheck): Boolean;
+var
+ h, l: Longint;
+ x: TPSProcedure;
+begin
+ h := MakeHash(s);
+ if (s = 'RESULT') then
+ begin
+ Result := True;
+ exit;
+ end;
+ if dcTypes in Check then
+ for l := FTypes.Count - 1 downto 0 do
+ begin
+ if (TPSType(FTypes.Data[l]).NameHash = h) and
+ (TPSType(FTypes.Data[l]).Name = s) then
+ begin
+ Result := True;
+ exit;
+ end;
+ end;
+
+ if dcProcs in Check then
+ for l := FProcs.Count - 1 downto 0 do
+ begin
+ x := FProcs.Data[l];
+ if x.ClassType = TPSInternalProcedure then
+ begin
+ if (h = TPSInternalProcedure(x).NameHash) and (s = TPSInternalProcedure(x).Name) then
+ begin
+ Result := True;
+ exit;
+ end;
+ end
+ else
+ begin
+ if (TPSExternalProcedure(x).RegProc.NameHash = h) and
+ (TPSExternalProcedure(x).RegProc.Name = s) then
+ begin
+ Result := True;
+ exit;
+ end;
+ end;
+ end;
+ if dcVars in Check then
+ for l := FVars.Count - 1 downto 0 do
+ begin
+ if (TPSVar(FVars.Data[l]).NameHash = h) and
+ (TPSVar(FVars.Data[l]).Name = s) then
+ begin
+ Result := True;
+ exit;
+ end;
+ end;
+ if dcConsts in Check then
+ for l := FConstants.Count -1 downto 0 do
+ begin
+ if (TPSConstant(FConstants.Data[l]).NameHash = h) and
+ (TPSConstant(FConstants.Data[l]).Name = s) then
+ begin
+ Result := TRue;
+ exit;
+ end;
+ end;
+ Result := False;
+end;
+
+procedure ClearRecSubVals(RecSubVals: TPSList);
+var
+ I: Longint;
+begin
+ for I := 0 to RecSubVals.Count - 1 do
+ TPSRecordFieldTypeDef(RecSubVals[I]).Free;
+ RecSubVals.Free;
+end;
+
+function TPSPascalCompiler.ReadTypeAddProcedure(const Name: tbtString; FParser: TPSPascalParser): TPSType;
+var
+ IsFunction: Boolean;
+ VNames: tbtString;
+ modifier: TPSParameterMode;
+ Decl: TPSParametersDecl;
+ VCType: TPSType;
+begin
+ if FParser.CurrTokenId = CSTII_Function then
+ IsFunction := True
+ else
+ IsFunction := False;
+ Decl := TPSParametersDecl.Create;
+ try
+ FParser.Next;
+ if FParser.CurrTokenId = CSTI_OpenRound then
+ begin
+ FParser.Next;
+ if FParser.CurrTokenId <> CSTI_CloseRound then
+ begin
+ while True do
+ begin
+ if FParser.CurrTokenId = CSTII_Const then
+ begin
+ Modifier := pmIn;
+ FParser.Next;
+ end else
+ if FParser.CurrTokenId = CSTII_Out then
+ begin
+ Modifier := pmOut;
+ FParser.Next;
+ end else
+ if FParser.CurrTokenId = CSTII_Var then
+ begin
+ modifier := pmInOut;
+ FParser.Next;
+ end
+ else
+ modifier := pmIn;
+ if FParser.CurrTokenId <> CSTI_Identifier then
+ begin
+ Result := nil;
+ if FParser = Self.FParser then
+ MakeError('', ecIdentifierExpected, '');
+ exit;
+ end;
+ VNames := FParser.OriginalToken + '|';
+ FParser.Next;
+ while FParser.CurrTokenId = CSTI_Comma do
+ begin
+ FParser.Next;
+ if FParser.CurrTokenId <> CSTI_Identifier then
+ begin
+ Result := nil;
+ if FParser = Self.FParser then
+ MakeError('', ecIdentifierExpected, '');
+ exit;
+ end;
+ VNames := VNames + FParser.GetToken + '|';
+ FParser.Next;
+ end;
+ if FParser.CurrTokenId <> CSTI_Colon then
+ begin
+ Result := nil;
+ if FParser = Self.FParser then
+ MakeError('', ecColonExpected, '');
+ exit;
+ end;
+ FParser.Next;
+ if FParser.CurrTokenId <> CSTI_Identifier then
+ begin
+ Result := nil;
+ if FParser = self.FParser then
+ MakeError('', ecIdentifierExpected, '');
+ exit;
+ end;
+ VCType := FindType(FParser.GetToken);
+ if VCType = nil then
+ begin
+ if FParser = self.FParser then
+ MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
+ Result := nil;
+ exit;
+ end;
+ while Pos(tbtchar('|'), VNames) > 0 do
+ begin
+ with Decl.AddParam do
+ begin
+ Mode := modifier;
+ OrgName := copy(VNames, 1, Pos(tbtchar('|'), VNames) - 1);
+ FType := VCType;
+ end;
+ Delete(VNames, 1, Pos(tbtchar('|'), VNames));
+ end;
+ FParser.Next;
+ if FParser.CurrTokenId = CSTI_CloseRound then
+ break;
+ if FParser.CurrTokenId <> CSTI_Semicolon then
+ begin
+ if FParser = Self.FParser then
+ MakeError('', ecSemicolonExpected, '');
+ Result := nil;
+ exit;
+ end;
+ FParser.Next;
+ end; {while}
+ end; {if}
+ FParser.Next;
+ end; {if}
+ if IsFunction then
+ begin
+ if FParser.CurrTokenId <> CSTI_Colon then
+ begin
+ if FParser = Self.FParser then
+ MakeError('', ecColonExpected, '');
+ Result := nil;
+ exit;
+ end;
+ FParser.Next;
+ if FParser.CurrTokenId <> CSTI_Identifier then
+ begin
+ Result := nil;
+ if FParser = Self.FParser then
+ MakeError('', ecIdentifierExpected, '');
+ exit;
+ end;
+ VCType := self.FindType(FParser.GetToken);
+ if VCType = nil then
+ begin
+ if FParser = self.FParser then
+ MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
+ Result := nil;
+ exit;
+ end;
+ FParser.Next;
+ end
+ else
+ VCType := nil;
+ Decl.Result := VcType;
+ VCType := TPSProceduralType.Create;
+ VCType.Name := FastUppercase(Name);
+ VCType.OriginalName := Name;
+ VCType.BaseType := btProcPtr;
+ {$IFDEF PS_USESSUPPORT}
+ VCType.DeclareUnit:=fModule;
+ {$ENDIF}
+ VCType.DeclarePos := FParser.CurrTokenPos;
+ VCType.DeclareRow := FParser.Row;
+ VCType.DeclareCol := FParser.Col;
+ TPSProceduralType(VCType).ProcDef.Assign(Decl);
+ FTypes.Add(VCType);
+ Result := VCType;
+ finally
+ Decl.Free;
+ end;
+end; {ReadTypeAddProcedure}
+
+
+function TPSPascalCompiler.ReadType(const Name: tbtString; FParser: TPSPascalParser): TPSType; // InvalidVal = Invalid
+var
+ TypeNo: TPSType;
+ h, l: Longint;
+ FieldName,fieldorgname,s: tbtString;
+ RecSubVals: TPSList;
+ FArrayStart, FArrayLength: Longint;
+ rvv: PIFPSRecordFieldTypeDef;
+ p, p2: TPSType;
+ tempf: PIfRVariant;
+
+begin
+ if (FParser.CurrTokenID = CSTII_Function) or (FParser.CurrTokenID = CSTII_Procedure) then
+ begin
+ Result := ReadTypeAddProcedure(Name, FParser);
+ Exit;
+ end else if FParser.CurrTokenId = CSTII_Set then
+ begin
+ FParser.Next;
+ if FParser.CurrTokenId <> CSTII_Of then
+ begin
+ MakeError('', ecOfExpected, '');
+ Result := nil;
+ Exit;
+ end;
+ FParser.Next;
+ if FParser.CurrTokenID <> CSTI_Identifier then
+ begin
+ MakeError('', ecIdentifierExpected, '');
+ Result := nil;
+ exit;
+ end;
+ TypeNo := FindType(FParser.GetToken);
+ if TypeNo = nil then
+ begin
+ MakeError('', ecUnknownIdentifier, '');
+ Result := nil;
+ exit;
+ end;
+ if (TypeNo.BaseType = btEnum) or (TypeNo.BaseType = btChar) or (TypeNo.BaseType = btU8) then
+ begin
+ FParser.Next;
+ p2 := TPSSetType.Create;
+ p2.Name := FastUppercase(Name);
+ p2.OriginalName := Name;
+ p2.BaseType := btSet;
+ {$IFDEF PS_USESSUPPORT}
+ p2.DeclareUnit:=fModule;
+ {$ENDIF}
+ p2.DeclarePos := FParser.CurrTokenPos;
+ p2.DeclareRow := FParser.Row;
+ p2.DeclareCol := FParser.Col;
+ TPSSetType(p2).SetType := TypeNo;
+ FTypes.Add(p2);
+ Result := p2;
+ end else
+ begin
+ MakeError('', ecTypeMismatch, '');
+ Result := nil;
+ end;
+ exit;
+ end else if FParser.CurrTokenId = CSTI_OpenRound then
+ begin
+ FParser.Next;
+ L := 0;
+ P2 := TPSEnumType.Create;
+ P2.Name := FastUppercase(Name);
+ p2.OriginalName := Name;
+ p2.BaseType := btEnum;
+ {$IFDEF PS_USESSUPPORT}
+ p2.DeclareUnit:=fModule;
+ {$ENDIF}
+ p2.DeclarePos := FParser.CurrTokenPos;
+ p2.DeclareRow := FParser.Row;
+ p2.DeclareCol := FParser.Col;
+ FTypes.Add(p2);
+
+ repeat
+ if FParser.CurrTokenId <> CSTI_Identifier then
+ begin
+ if FParser = Self.FParser then
+ MakeError('', ecIdentifierExpected, '');
+ Result := nil;
+ exit;
+ end;
+ s := FParser.OriginalToken;
+ if IsDuplicate(FastUppercase(s), [dcTypes]) then
+ begin
+ if FParser = Self.FParser then
+ MakeError('', ecDuplicateIdentifier, s);
+ Result := nil;
+ Exit;
+ end;
+ with AddConstant(s, p2) do
+ begin
+ FValue.tu32 := L;
+ {$IFDEF PS_USESSUPPORT}
+ DeclareUnit:=fModule;
+ {$ENDIF}
+ DeclarePos:=FParser.CurrTokenPos;
+ DeclareRow:=FParser.Row;
+ DeclareCol:=FParser.Col;
+ end;
+ Inc(L);
+ FParser.Next;
+ if FParser.CurrTokenId = CSTI_CloseRound then
+ Break
+ else if FParser.CurrTokenId <> CSTI_Comma then
+ begin
+ if FParser = Self.FParser then
+ MakeError('', ecCloseRoundExpected, '');
+ Result := nil;
+ Exit;
+ end;
+ FParser.Next;
+ until False;
+ FParser.Next;
+ TPSEnumType(p2).HighValue := L-1;
+ Result := p2;
+ exit;
+ end else
+ if FParser.CurrTokenId = CSTII_Array then
+ begin
+ FParser.Next;
+ if FParser.CurrTokenID = CSTI_OpenBlock then
+ begin
+ FParser.Next;
+ tempf := ReadConstant(FParser, CSTI_TwoDots);
+ if tempf = nil then
+ begin
+ Result := nil;
+ exit;
+ end;
+ case tempf.FType.BaseType of
+ btU8: FArrayStart := tempf.tu8;
+ btS8: FArrayStart := tempf.ts8;
+ btU16: FArrayStart := tempf.tu16;
+ btS16: FArrayStart := tempf.ts16;
+ btU32: FArrayStart := tempf.tu32;
+ btS32: FArrayStart := tempf.ts32;
+ {$IFNDEF PS_NOINT64}
+ bts64: FArrayStart := tempf.ts64;
+ {$ENDIF}
+ else
+ begin
+ DisposeVariant(tempf);
+ MakeError('', ecTypeMismatch, '');
+ Result := nil;
+ exit;
+ end;
+ end;
+ DisposeVariant(tempf);
+ if FParser.CurrTokenID <> CSTI_TwoDots then
+ begin
+ MakeError('', ecPeriodExpected, '');
+ Result := nil;
+ exit;
+ end;
+ FParser.Next;
+ tempf := ReadConstant(FParser, CSTI_CloseBlock);
+ if tempf = nil then
+ begin
+ Result := nil;
+ exit;
+ end;
+ case tempf.FType.BaseType of
+ btU8: FArrayLength := tempf.tu8;
+ btS8: FArrayLength := tempf.ts8;
+ btU16: FArrayLength := tempf.tu16;
+ btS16: FArrayLength := tempf.ts16;
+ btU32: FArrayLength := tempf.tu32;
+ btS32: FArrayLength := tempf.ts32;
+ {$IFNDEF PS_NOINT64}
+ bts64: FArrayLength := tempf.ts64;
+ {$ENDIF}
+ else
+ DisposeVariant(tempf);
+ MakeError('', ecTypeMismatch, '');
+ Result := nil;
+ exit;
+ end;
+ DisposeVariant(tempf);
+ FArrayLength := FArrayLength - FArrayStart + 1;
+ if (FArrayLength < 0) or (FArrayLength > MaxInt div 4) then
+ begin
+ MakeError('', ecTypeMismatch, '');
+ Result := nil;
+ exit;
+ end;
+ if FParser.CurrTokenID <> CSTI_CloseBlock then
+ begin
+ MakeError('', ecCloseBlockExpected, '');
+ Result := nil;
+ exit;
+ end;
+ FParser.Next;
+ end else
+ begin
+ FArrayStart := 0;
+ FArrayLength := -1;
+ end;
+ if FParser.CurrTokenId <> CSTII_Of then
+ begin
+ if FParser = Self.FParser then
+ MakeError('', ecOfExpected, '');
+ Result := nil;
+ exit;
+ end;
+ FParser.Next;
+ TypeNo := ReadType('', FParser);
+ if TypeNo = nil then
+ begin
+ if FParser = Self.FParser then
+ MakeError('', ecUnknownIdentifier, '');
+ Result := nil;
+ exit;
+ end;
+ if (Name = '') and (FArrayLength = -1) then
+ begin
+ if TypeNo.Used then
+ begin
+ for h := 0 to FTypes.Count -1 do
+ begin
+ p := FTypes[H];
+ if (p.BaseType = btArray) and (TPSArrayType(p).ArrayTypeNo = TypeNo) and (Copy(p.Name, 1, 1) <> '!') then
+ begin
+ Result := p;
+ exit;
+ end;
+ end;
+ end;
+ end;
+ if FArrayLength <> -1 then
+ begin
+ p := TPSStaticArrayType.Create;
+ TPSStaticArrayType(p).StartOffset := FArrayStart;
+ TPSStaticArrayType(p).Length := FArrayLength;
+ p.BaseType := btStaticArray;
+ end else
+ begin
+ p := TPSArrayType.Create;
+ p.BaseType := btArray;
+ end;
+ p.Name := FastUppercase(Name);
+ p.OriginalName := Name;
+ {$IFDEF PS_USESSUPPORT}
+ p.DeclareUnit:=fModule;
+ {$ENDIF}
+ p.DeclarePos := FParser.CurrTokenPos;
+ p.DeclareRow := FParser.Row;
+ p.DeclareCol := FParser.Col;
+ TPSArrayType(p).ArrayTypeNo := TypeNo;
+ FTypes.Add(p);
+ Result := p;
+ Exit;
+ end
+ else if FParser.CurrTokenId = CSTII_Record then
+ begin
+ FParser.Next;
+ RecSubVals := TPSList.Create;
+ repeat
+ repeat
+ if FParser.CurrTokenId <> CSTI_Identifier then
+ begin
+ ClearRecSubVals(RecSubVals);
+ if FParser = Self.FParser then
+ MakeError('', ecIdentifierExpected, '');
+ Result := nil;
+ exit;
+ end;
+ FieldName := FParser.GetToken;
+ s := S+FParser.OriginalToken+'|';
+ FParser.Next;
+ h := MakeHash(FieldName);
+ for l := 0 to RecSubVals.Count - 1 do
+ begin
+ if (PIFPSRecordFieldTypeDef(RecSubVals[l]).FieldNameHash = h) and
+ (PIFPSRecordFieldTypeDef(RecSubVals[l]).FieldName = FieldName) then
+ begin
+ if FParser = Self.FParser then
+ MakeError('', ecDuplicateIdentifier, FParser.OriginalToken);
+ ClearRecSubVals(RecSubVals);
+ Result := nil;
+ exit;
+ end;
+ end;
+ if FParser.CurrTokenID = CSTI_Colon then Break else
+ if FParser.CurrTokenID <> CSTI_Comma then
+ begin
+ if FParser = Self.FParser then
+ MakeError('', ecColonExpected, '');
+ ClearRecSubVals(RecSubVals);
+ Result := nil;
+ exit;
+ end;
+ FParser.Next;
+ until False;
+ FParser.Next;
+ p := ReadType('', FParser);
+ if p = nil then
+ begin
+ ClearRecSubVals(RecSubVals);
+ Result := nil;
+ exit;
+ end;
+ p := GetTypeCopyLink(p);
+ if FParser.CurrTokenId <> CSTI_Semicolon then
+ begin
+ ClearRecSubVals(RecSubVals);
+ if FParser = Self.FParser then
+ MakeError('', ecSemicolonExpected, '');
+ Result := nil;
+ exit;
+ end; {if}
+ FParser.Next;
+ while Pos(tbtchar('|'), s) > 0 do
+ begin
+ fieldorgname := copy(s, 1, Pos(tbtchar('|'), s)-1);
+ Delete(s, 1, length(FieldOrgName)+1);
+ rvv := TPSRecordFieldTypeDef.Create;
+ rvv.FieldOrgName := fieldorgname;
+ rvv.FType := p;
+ RecSubVals.Add(rvv);
+ end;
+ until FParser.CurrTokenId = CSTII_End;
+ FParser.Next; // skip CSTII_End
+ P := TPSRecordType.Create;
+ p.Name := FastUppercase(Name);
+ p.OriginalName := Name;
+ p.BaseType := btRecord;
+ {$IFDEF PS_USESSUPPORT}
+ p.DeclareUnit:=fModule;
+ {$ENDIF}
+ p.DeclarePos := FParser.CurrTokenPos;
+ p.DeclareRow := FParser.Row;
+ p.DeclareCol := FParser.Col;
+ for l := 0 to RecSubVals.Count -1 do
+ begin
+ rvv := RecSubVals[l];
+ with TPSRecordType(p).AddRecVal do
+ begin
+ FieldOrgName := rvv.FieldOrgName;
+ FType := rvv.FType;
+ end;
+ rvv.Free;
+ end;
+ RecSubVals.Free;
+ FTypes.Add(p);
+ Result := p;
+ Exit;
+ end else if FParser.CurrTokenId = CSTI_Identifier then
+ begin
+ s := FParser.GetToken;
+ h := MakeHash(s);
+ Typeno := nil;
+ for l := 0 to FTypes.Count - 1 do
+ begin
+ p2 := FTypes[l];
+ if (p2.NameHash = h) and (p2.Name = s) then
+ begin
+ FParser.Next;
+ Typeno := GetTypeCopyLink(p2);
+ Break;
+ end;
+ end;
+ if Typeno = nil then
+ begin
+ Result := nil;
+ if FParser = Self.FParser then
+ MakeError('', ecUnknownType, FParser.OriginalToken);
+ exit;
+ end;
+ if Name <> '' then
+ begin
+ p := TPSTypeLink.Create;
+ p.Name := FastUppercase(Name);
+ p.OriginalName := Name;
+ p.BaseType := BtTypeCopy;
+ {$IFDEF PS_USESSUPPORT}
+ p.DeclareUnit:=fModule;
+ {$ENDIF}
+ p.DeclarePos := FParser.CurrTokenPos;
+ p.DeclareRow := FParser.Row;
+ p.DeclareCol := FParser.Col;
+ TPSTypeLink(p).LinkTypeNo := TypeNo;
+ FTypes.Add(p);
+ Result := p;
+ Exit;
+ end else
+ begin
+ Result := TypeNo;
+ exit;
+ end;
+ end;
+ Result := nil;
+ if FParser = Self.FParser then
+ MakeError('', ecIdentifierExpected, '');
+ Exit;
+end;
+
+function TPSPascalCompiler.VarIsDuplicate(Proc: TPSInternalProcedure; const Varnames, s: tbtString): Boolean;
+var
+ h, l: Longint;
+ x: TPSProcedure;
+ v: tbtString;
+begin
+ h := MakeHash(s);
+ if (s = 'RESULT') then
+ begin
+ Result := True;
+ exit;
+ end;
+
+ for l := FProcs.Count - 1 downto 0 do
+ begin
+ x := FProcs.Data[l];
+ if x.ClassType = TPSInternalProcedure then
+ begin
+ if (h = TPSInternalProcedure(x).NameHash) and (s = TPSInternalProcedure(x).Name) then
+ begin
+ Result := True;
+ exit;
+ end;
+ end
+ else
+ begin
+ if (TPSExternalProcedure(x).RegProc.NameHash = h) and (TPSExternalProcedure(x).RegProc.Name = s) then
+ begin
+ Result := True;
+ exit;
+ end;
+ end;
+ end;
+ if proc <> nil then
+ begin
+ for l := proc.ProcVars.Count - 1 downto 0 do
+ begin
+ if (PIFPSProcVar(proc.ProcVars.Data[l]).NameHash = h) and
+ (PIFPSProcVar(proc.ProcVars.Data[l]).Name = s) then
+ begin
+ Result := True;
+ exit;
+ end;
+ end;
+ for l := Proc.FDecl.ParamCount -1 downto 0 do
+ begin
+ if (Proc.FDecl.Params[l].Name = s) then
+ begin
+ Result := True;
+ exit;
+ end;
+ end;
+ end
+ else
+ begin
+ for l := FVars.Count - 1 downto 0 do
+ begin
+ if (TPSVar(FVars.Data[l]).NameHash = h) and
+ (TPSVar(FVars.Data[l]).Name = s) then
+ begin
+ Result := True;
+ exit;
+ end;
+ end;
+ end;
+ v := VarNames;
+ while Pos(tbtchar('|'), v) > 0 do
+ begin
+ if FastUppercase(copy(v, 1, Pos(tbtchar('|'), v) - 1)) = s then
+ begin
+ Result := True;
+ exit;
+ end;
+ Delete(v, 1, Pos(tbtchar('|'), v));
+ end;
+ for l := FConstants.Count -1 downto 0 do
+ begin
+ if (TPSConstant(FConstants.Data[l]).NameHash = h) and
+ (TPSConstant(FConstants.Data[l]).Name = s) then
+ begin
+ Result := True;
+ exit;
+ end;
+ end;
+ Result := False;
+end;
+
+
+function TPSPascalCompiler.DoVarBlock(proc: TPSInternalProcedure): Boolean;
+var
+ VarName, s: tbtString;
+ VarType: TPSType;
+ VarNo: Cardinal;
+ v: TPSVar;
+ vp: PIFPSProcVar;
+ EPos, ERow, ECol: Integer;
+begin
+ Result := False;
+ FParser.Next; // skip CSTII_Var
+ if FParser.CurrTokenId <> CSTI_Identifier then
+ begin
+ MakeError('', ecIdentifierExpected, '');
+ exit;
+ end;
+ repeat
+ VarNAme := '';
+ if VarIsDuplicate(proc, VarName, FParser.GetToken) then
+ begin
+ MakeError('', ecDuplicateIdentifier, FParser.OriginalToken);
+ exit;
+ end;
+ VarName := FParser.OriginalToken + '|';
+ Varno := 0;
+ if @FOnUseVariable <> nil then
+ begin
+ if Proc <> nil then
+ FOnUseVariable(Self, ivtVariable, Proc.ProcVars.Count + VarNo, FProcs.Count -1, FParser.CurrTokenPos, '')
+ else
+ FOnUseVariable(Self, ivtGlobal, FVars.Count + VarNo, InvalidVal, FParser.CurrTokenPos, '')
+ end;
+ EPos:=FParser.CurrTokenPos;
+ ERow:=FParser.Row;
+ ECol:=FParser.Col;
+ FParser.Next;
+ while FParser.CurrTokenId = CSTI_Comma do
+ begin
+ FParser.Next;
+ if FParser.CurrTokenId <> CSTI_Identifier then
+ begin
+ MakeError('', ecIdentifierExpected, '');
+ end;
+ if VarIsDuplicate(proc, VarName, FParser.GetToken) then
+ begin
+ MakeError('', ecDuplicateIdentifier, FParser.OriginalToken);
+ exit;
+ end;
+ VarName := VarName + FParser.OriginalToken + '|';
+ Inc(varno);
+ if @FOnUseVariable <> nil then
+ begin
+ if Proc <> nil then
+ FOnUseVariable(Self, ivtVariable, Proc.ProcVars.Count + VarNo, FProcs.Count -1, FParser.CurrTokenPos, '')
+ else
+ FOnUseVariable(Self, ivtGlobal, FVars.Count + VarNo, InvalidVal, FParser.CurrTokenPos, '')
+ end;
+ FParser.Next;
+ end;
+ if FParser.CurrTokenId <> CSTI_Colon then
+ begin
+ MakeError('', ecColonExpected, '');
+ exit;
+ end;
+ FParser.Next;
+ VarType := at2ut(ReadType('', FParser));
+ if VarType = nil then
+ begin
+ exit;
+ end;
+ while Pos(tbtchar('|'), VarName) > 0 do
+ begin
+ s := copy(VarName, 1, Pos(tbtchar('|'), VarName) - 1);
+ Delete(VarName, 1, Pos(tbtchar('|'), VarName));
+ if proc = nil then
+ begin
+ v := TPSVar.Create;
+ v.OrgName := s;
+ v.Name := FastUppercase(s);
+ {$IFDEF PS_USESSUPPORT}
+ v.DeclareUnit:=fModule;
+ {$ENDIF}
+ v.DeclarePos := EPos;
+ v.DeclareRow := ERow;
+ v.DeclareCol := ECol;
+ v.FType := VarType;
+ FVars.Add(v);
+ end
+ else
+ begin
+ vp := TPSProcVar.Create;
+ vp.OrgName := s;
+ vp.Name := FastUppercase(s);
+ vp.aType := VarType;
+ {$IFDEF PS_USESSUPPORT}
+ vp.DeclareUnit:=fModule;
+ {$ENDIF}
+ vp.DeclarePos := EPos;
+ vp.DeclareRow := ERow;
+ vp.DeclareCol := ECol;
+ proc.ProcVars.Add(vp);
+ end;
+ end;
+ if FParser.CurrTokenId <> CSTI_Semicolon then
+ begin
+ MakeError('', ecSemicolonExpected, '');
+ exit;
+ end;
+ FParser.Next;
+ until FParser.CurrTokenId <> CSTI_Identifier;
+ Result := True;
+end;
+
+function TPSPascalCompiler.NewProc(const OriginalName, Name: tbtString): TPSInternalProcedure;
+begin
+ Result := TPSInternalProcedure.Create;
+ Result.OriginalName := OriginalName;
+ Result.Name := Name;
+ {$IFDEF PS_USESSUPPORT}
+ Result.DeclareUnit:=fModule;
+ {$ENDIF}
+ Result.DeclarePos := FParser.CurrTokenPos;
+ Result.DeclareRow := FParser.Row;
+ Result.DeclareCol := FParser.Col;
+ FProcs.Add(Result);
+end;
+
+function TPSPascalCompiler.IsProcDuplicLabel(Proc: TPSInternalProcedure; const s: tbtString): Boolean;
+var
+ i: Longint;
+ h: Longint;
+ u: tbtString;
+begin
+ h := MakeHash(s);
+ if s = 'RESULT' then
+ Result := True
+ else if Proc.Name = s then
+ Result := True
+ else if IsDuplicate(s, [dcVars, dcConsts, dcProcs]) then
+ Result := True
+ else
+ begin
+ for i := 0 to Proc.Decl.ParamCount -1 do
+ begin
+ if Proc.Decl.Params[i].Name = s then
+ begin
+ Result := True;
+ exit;
+ end;
+ end;
+ for i := 0 to Proc.ProcVars.Count -1 do
+ begin
+ if (PIFPSProcVar(Proc.ProcVars[I]).NameHash = h) and (PIFPSProcVar(Proc.ProcVars[I]).Name = s) then
+ begin
+ Result := True;
+ exit;
+ end;
+ end;
+ for i := 0 to Proc.FLabels.Count -1 do
+ begin
+ u := Proc.FLabels[I];
+ delete(u, 1, 4);
+ if Longint((@u[1])^) = h then
+ begin
+ delete(u, 1, 4);
+ if u = s then
+ begin
+ Result := True;
+ exit;
+ end;
+ end;
+ end;
+ Result := False;
+ end;
+end;
+
+
+function TPSPascalCompiler.ProcessLabel(Proc: TPSInternalProcedure): Boolean;
+var
+ CurrLabel: tbtString;
+begin
+ FParser.Next;
+ while true do
+ begin
+ if FParser.CurrTokenId <> CSTI_Identifier then
+ begin
+ MakeError('', ecIdentifierExpected, '');
+ Result := False;
+ exit;
+ end;
+ CurrLabel := FParser.GetToken;
+ if IsProcDuplicLabel(Proc, CurrLabel) then
+ begin
+ MakeError('', ecDuplicateIdentifier, CurrLabel);
+ Result := False;
+ exit;
+ end;
+ FParser.Next;
+ Proc.FLabels.Add(#$FF#$FF#$FF#$FF+PS_mi2s(MakeHash(CurrLabel))+CurrLabel);
+ if FParser.CurrTokenId = CSTI_Semicolon then
+ begin
+ FParser.Next;
+ Break;
+ end;
+ if FParser.CurrTokenId <> CSTI_Comma then
+ begin
+ MakeError('', ecCommaExpected, '');
+ Result := False;
+ exit;
+ end;
+ FParser.Next;
+ end;
+ Result := True;
+end;
+
+procedure TPSPascalCompiler.Debug_SavePosition(ProcNo: Cardinal; Proc: TPSInternalProcedure);
+var
+ Row,
+ Col,
+ Pos: Cardinal;
+ s: tbtString;
+begin
+ Row := FParser.Row;
+ Col := FParser.Col;
+ Pos := FParser.CurrTokenPos;
+ {$IFNDEF PS_USESSUPPORT}
+ s := '';
+ {$ELSE}
+ s := fModule;
+ {$ENDIF}
+ if @FOnTranslateLineInfo <> nil then
+ FOnTranslateLineInfo(Self, Pos, Row, Col, S);
+ {$IFDEF FPC}
+ WriteDebugData(#4 + s + #1);
+ WriteDebugData(Ps_mi2s(ProcNo));
+ WriteDebugData(Ps_mi2s(Length(Proc.Data)));
+ WriteDebugData(Ps_mi2s(Pos));
+ WriteDebugData(Ps_mi2s(Row));
+ WriteDebugData(Ps_mi2s(Col));
+ {$ELSE}
+ WriteDebugData(#4 + s + #1 + PS_mi2s(ProcNo) + PS_mi2s(Length(Proc.Data)) + PS_mi2s(Pos) + PS_mi2s(Row)+ PS_mi2s(Col));
+ {$ENDIF}
+end;
+
+procedure TPSPascalCompiler.Debug_WriteParams(ProcNo: Cardinal; Proc: TPSInternalProcedure);
+var
+ I: Longint;
+ s: tbtString;
+begin
+ s := #2 + PS_mi2s(ProcNo);
+ if Proc.Decl.Result <> nil then
+ begin
+ s := s + 'Result' + #1;
+ end;
+ for i := 0 to Proc.Decl.ParamCount -1 do
+ s := s + Proc.Decl.Params[i].OrgName + #1;
+ s := s + #0#3 + PS_mi2s(ProcNo);
+ for I := 0 to Proc.ProcVars.Count - 1 do
+ begin
+ s := s + PIFPSProcVar(Proc.ProcVars[I]).OrgName + #1;
+ end;
+ s := s + #0;
+ WriteDebugData(s);
+end;
+
+procedure TPSPascalCompiler.CheckForUnusedVars(Func: TPSInternalProcedure);
+var
+ i: Integer;
+ p: PIFPSProcVar;
+begin
+ for i := 0 to Func.ProcVars.Count -1 do
+ begin
+ p := Func.ProcVars[I];
+ if not p.Used then
+ begin
+ with MakeHint({$IFDEF PS_USESSUPPORT}p.DeclareUnit{$ELSE}''{$ENDIF}, ehVariableNotUsed, p.Name) do
+ begin
+ FRow := p.DeclareRow;
+ FCol := p.DeclareCol;
+ FPosition := p.DeclarePos;
+ end;
+ end;
+ end;
+ if (not Func.ResultUsed) and (Func.Decl.Result <> nil) then
+ begin
+ with MakeHint({$IFDEF PS_USESSUPPORT}Func.DeclareUnit{$ELSE}''{$ENDIF}, ehVariableNotUsed, 'Result') do
+ begin
+ FRow := Func.DeclareRow;
+ FCol := Func.DeclareCol;
+ FPosition := Func.DeclarePos;
+ end;
+ end;
+end;
+
+function TPSPascalCompiler.ProcIsDuplic(Decl: TPSParametersDecl; const FunctionName, FunctionParamNames: tbtString; const s: tbtString; Func: TPSInternalProcedure): Boolean;
+var
+ i: Longint;
+ u: tbtString;
+begin
+ if s = 'RESULT' then
+ Result := True
+ else if FunctionName = s then
+ Result := True
+ else
+ begin
+ for i := 0 to Decl.ParamCount -1 do
+ begin
+ if Decl.Params[i].Name = s then
+ begin
+ Result := True;
+ exit;
+ end;
+ GRFW(u);
+ end;
+ u := FunctionParamNames;
+ while Pos(tbtchar('|'), u) > 0 do
+ begin
+ if copy(u, 1, Pos(tbtchar('|'), u) - 1) = s then
+ begin
+ Result := True;
+ exit;
+ end;
+ Delete(u, 1, Pos(tbtchar('|'), u));
+ end;
+ if Func = nil then
+ begin
+ result := False;
+ exit;
+ end;
+ for i := 0 to Func.ProcVars.Count -1 do
+ begin
+ if s = PIFPSProcVar(Func.ProcVars[I]).Name then
+ begin
+ Result := True;
+ exit;
+ end;
+ end;
+ for i := 0 to Func.FLabels.Count -1 do
+ begin
+ u := Func.FLabels[I];
+ delete(u, 1, 4);
+ if u = s then
+ begin
+ Result := True;
+ exit;
+ end;
+ end;
+ Result := False;
+ end;
+end;
+procedure WriteProcVars(Func:TPSInternalProcedure; t: TPSList);
+var
+ l: Longint;
+ v: PIFPSProcVar;
+begin
+ for l := 0 to t.Count - 1 do
+ begin
+ v := t[l];
+ Func.Data := Func.Data + chr(cm_pt)+ PS_mi2s(v.AType.FinalTypeNo);
+ end;
+end;
+
+
+function TPSPascalCompiler.ApplyAttribsToFunction(func: TPSProcedure): boolean;
+var
+ i: Longint;
+begin
+ for i := 0 to Func.Attributes.Count -1 do
+ begin
+ if @Func.Attributes.Items[i].AType.OnApplyAttributeToProc <> nil then
+ begin
+ if not Func.Attributes.Items[i].AType.OnApplyAttributeToProc(Self, Func, Func.Attributes.Items[i]) then
+ begin
+ Result := false;
+ exit;
+ end;
+ end;
+ end;
+ result := true;
+end;
+
+
+function TPSPascalCompiler.ProcessFunction(AlwaysForward: Boolean; Att: TPSAttributes): Boolean;
+var
+ FunctionType: TFuncType;
+ OriginalName, FunctionName: tbtString;
+ FunctionParamNames: tbtString;
+ FunctionTempType: TPSType;
+ ParamNo: Cardinal;
+ FunctionDecl: TPSParametersDecl;
+ modifier: TPSParameterMode;
+ Func: TPSInternalProcedure;
+ F2: TPSProcedure;
+ EPos, ECol, ERow: Cardinal;
+ E2Pos, E2Col, E2Row: Cardinal;
+ pp: TPSRegProc;
+ pp2: TPSExternalProcedure;
+ FuncNo, I: Longint;
+ Block: TPSBlockInfo;
+begin
+ if att = nil then
+ begin
+ Att := TPSAttributes.Create;
+ if not ReadAttributes(Att) then
+ begin
+ att.free;
+ Result := false;
+ exit;
+ end;
+ end;
+
+ if FParser.CurrTokenId = CSTII_Procedure then
+ FunctionType := ftProc
+ else
+ FunctionType := ftFunc;
+ Func := nil;
+ EPos := FParser.CurrTokenPos;
+ ERow := FParser.Row;
+ ECol := FParser.Col;
+ FParser.Next;
+ Result := False;
+ if FParser.CurrTokenId <> CSTI_Identifier then
+ begin
+ MakeError('', ecIdentifierExpected, '');
+ att.free;
+ exit;
+ end;
+ if assigned(FOnFunctionStart) then
+ {$IFDEF PS_USESSUPPORT}
+ FOnFunctionStart(fModule + '.' + FParser.OriginalToken, EPos, ERow, ECol);
+ {$ELSE}
+ FOnFunctionStart(FParser.OriginalToken, EPos, ERow, ECol);
+ {$ENDIF}
+ EPos := FParser.CurrTokenPos;
+ ERow := FParser.Row;
+ ECol := FParser.Col;
+ OriginalName := FParser.OriginalToken;
+ FunctionName := FParser.GetToken;
+ FuncNo := -1;
+ for i := 0 to FProcs.Count -1 do
+ begin
+ f2 := FProcs[I];
+ if (f2.ClassType = TPSInternalProcedure) and (TPSInternalProcedure(f2).Name = FunctionName) and (TPSInternalProcedure(f2).Forwarded) then
+ begin
+ Func := FProcs[I];
+ FuncNo := i;
+ Break;
+ end;
+ end;
+ if (Func = nil) and IsDuplicate(FunctionName, [dcTypes, dcProcs, dcVars, dcConsts]) then
+ begin
+ att.free;
+ MakeError('', ecDuplicateIdentifier, FunctionName);
+ exit;
+ end;
+ FParser.Next;
+ FunctionDecl := TPSParametersDecl.Create;
+ try
+ if FParser.CurrTokenId = CSTI_OpenRound then
+ begin
+ FParser.Next;
+ if FParser.CurrTokenId = CSTI_CloseRound then
+ begin
+ FParser.Next;
+ end
+ else
+ begin
+ if FunctionType = ftFunc then
+ ParamNo := 1
+ else
+ ParamNo := 0;
+ while True do
+ begin
+ if FParser.CurrTokenId = CSTII_Const then
+ begin
+ modifier := pmIn;
+ FParser.Next;
+ end
+ else
+ if FParser.CurrTokenId = CSTII_Out then
+ begin
+ modifier := pmOut;
+ FParser.Next;
+ end
+ else
+ if FParser.CurrTokenId = CSTII_Var then
+ begin
+ modifier := pmInOut;
+ FParser.Next;
+ end
+ else
+ modifier := pmIn;
+ if FParser.CurrTokenId <> CSTI_Identifier then
+ begin
+ MakeError('', ecIdentifierExpected, '');
+ exit;
+ end;
+ E2Pos := FParser.CurrTokenPos;
+ E2Row := FParser.Row;
+ E2Col := FParser.Col;
+ FunctionParamNames := '';
+ if ProcIsDuplic(FunctionDecl, FunctionName, FunctionParamNames, FParser.GetToken, Func) then
+ begin
+ MakeError('', ecDuplicateIdentifier, FParser.OriginalToken);
+ exit;
+ end;
+ FunctionParamNames := FParser.OriginalToken + '|';
+ if @FOnUseVariable <> nil then
+ begin
+ FOnUseVariable(Self, ivtParam, ParamNo, FProcs.Count, FParser.CurrTokenPos, '');
+ end;
+ inc(ParamNo);
+ FParser.Next;
+ while FParser.CurrTokenId = CSTI_Comma do
+ begin
+ FParser.Next;
+ if FParser.CurrTokenId <> CSTI_Identifier then
+ begin
+ MakeError('', ecIdentifierExpected, '');
+ exit;
+ end;
+ if ProcIsDuplic(FunctionDecl, FunctionName, FunctionParamNames, FParser.GetToken, Func) then
+ begin
+ MakeError('', ecDuplicateIdentifier, '');
+ exit;
+ end;
+ if @FOnUseVariable <> nil then
+ begin
+ FOnUseVariable(Self, ivtParam, ParamNo, FProcs.Count, FParser.CurrTokenPos, '');
+ end;
+ inc(ParamNo);
+ FunctionParamNames := FunctionParamNames + FParser.OriginalToken +
+ '|';
+ FParser.Next;
+ end;
+ if FParser.CurrTokenId <> CSTI_Colon then
+ begin
+ MakeError('', ecColonExpected, '');
+ exit;
+ end;
+ FParser.Next;
+ FunctionTempType := at2ut(ReadType('', FParser));
+ if FunctionTempType = nil then
+ begin
+ exit;
+ end;
+ while Pos(tbtchar('|'), FunctionParamNames) > 0 do
+ begin
+ with FunctionDecl.AddParam do
+ begin
+ OrgName := copy(FunctionParamNames, 1, Pos(tbtchar('|'), FunctionParamNames) - 1);
+ Mode := modifier;
+ aType := FunctionTempType;
+ {$IFDEF PS_USESSUPPORT}
+ DeclareUnit:=fModule;
+ {$ENDIF}
+ DeclarePos:=E2Pos;
+ DeclareRow:=E2Row;
+ DeclareCol:=E2Col;
+ end;
+ Delete(FunctionParamNames, 1, Pos(tbtchar('|'), FunctionParamNames));
+ end;
+ if FParser.CurrTokenId = CSTI_CloseRound then
+ break;
+ if FParser.CurrTokenId <> CSTI_Semicolon then
+ begin
+ MakeError('', ecSemicolonExpected, '');
+ exit;
+ end;
+ FParser.Next;
+ end;
+ FParser.Next;
+ end;
+ end;
+ if FunctionType = ftFunc then
+ begin
+ if FParser.CurrTokenId <> CSTI_Colon then
+ begin
+ MakeError('', ecColonExpected, '');
+ exit;
+ end;
+ FParser.Next;
+ FunctionTempType := at2ut(ReadType('', FParser));
+ if FunctionTempType = nil then
+ exit;
+ FunctionDecl.Result := FunctionTempType;
+ end;
+ if FParser.CurrTokenId <> CSTI_Semicolon then
+ begin
+ MakeError('', ecSemicolonExpected, '');
+ exit;
+ end;
+ FParser.Next;
+ if (Func = nil) and (FParser.CurrTokenID = CSTII_External) then
+ begin
+ FParser.Next;
+ if FParser.CurrTokenID <> CSTI_String then
+ begin
+ MakeError('', ecStringExpected, '');
+ exit;
+ end;
+ FunctionParamNames := FParser.GetToken;
+ FunctionParamNames := copy(FunctionParamNames, 2, length(FunctionParamNames) - 2);
+ FParser.Next;
+ if FParser.CurrTokenID <> CSTI_Semicolon then
+ begin
+ MakeError('', ecSemicolonExpected, '');
+ exit;
+ end;
+ FParser.Next;
+ if @FOnExternalProc = nil then
+ begin
+ MakeError('', ecSemicolonExpected, '');
+ exit;
+ end;
+ pp := FOnExternalProc(Self, FunctionDecl, OriginalName, FunctionParamNames);
+ if pp = nil then
+ begin
+ MakeError('', ecCustomError, '');
+ exit;
+ end;
+ pp2 := TPSExternalProcedure.Create;
+ pp2.Attributes.Assign(att, true);
+ pp2.RegProc := pp;
+ FProcs.Add(pp2);
+ FRegProcs.Add(pp);
+ Result := ApplyAttribsToFunction(pp2);
+ Exit;
+ end else if (FParser.CurrTokenID = CSTII_Forward) or AlwaysForward then
+ begin
+ if Func <> nil then
+ begin
+ MakeError('', ecBeginExpected, '');
+ exit;
+ end;
+ if not AlwaysForward then
+ begin
+ FParser.Next;
+ if FParser.CurrTokenID <> CSTI_Semicolon then
+ begin
+ MakeError('', ecSemicolonExpected, '');
+ Exit;
+ end;
+ FParser.Next;
+ end;
+ Func := NewProc(OriginalName, FunctionName);
+ Func.Attributes.Assign(Att, True);
+ Func.Forwarded := True;
+ {$IFDEF PS_USESSUPPORT}
+ Func.FDeclareUnit := fModule;
+ {$ENDIF}
+ Func.FDeclarePos := EPos;
+ Func.FDeclareRow := ERow;
+ Func.FDeclarePos := ECol;
+ Func.Decl.Assign(FunctionDecl);
+ Result := ApplyAttribsToFunction(Func);
+ exit;
+ end;
+ if (Func = nil) then
+ begin
+ Func := NewProc(OriginalName, FunctionName);
+ Func.Attributes.Assign(att, True);
+ Func.Decl.Assign(FunctionDecl);
+ {$IFDEF PS_USESSUPPORT}
+ Func.FDeclareUnit := fModule;
+ {$ENDIF}
+ Func.FDeclarePos := EPos;
+ Func.FDeclareRow := ERow;
+ Func.FDeclareCol := ECol;
+ FuncNo := FProcs.Count -1;
+ if not ApplyAttribsToFunction(Func) then
+ begin
+ result := false;
+ exit;
+ end;
+ end else begin
+ if not FunctionDecl.Same(Func.Decl) then
+ begin
+ MakeError('', ecForwardParameterMismatch, '');
+ Result := false;
+ exit;
+ end;
+ Func.Forwarded := False;
+ end;
+ if FParser.CurrTokenID = CSTII_Export then
+ begin
+ FParser.Next;
+ if FParser.CurrTokenID <> CSTI_Semicolon then
+ begin
+ MakeError('', ecSemicolonExpected, '');
+ exit;
+ end;
+ FParser.Next;
+ end;
+ while FParser.CurrTokenId <> CSTII_Begin do
+ begin
+ if FParser.CurrTokenId = CSTII_Var then
+ begin
+ if not DoVarBlock(Func) then
+ exit;
+ end else if FParser.CurrTokenId = CSTII_Label then
+ begin
+ if not ProcessLabel(Func) then
+ Exit;
+ end else
+ begin
+ MakeError('', ecBeginExpected, '');
+ exit;
+ end;
+ end;
+ Debug_WriteParams(FuncNo, Func);
+ WriteProcVars(Func, Func.ProcVars);
+ Block := TPSBlockInfo.Create(FGlobalBlock);
+ Block.SubType := tProcBegin;
+ Block.ProcNo := FuncNo;
+ Block.Proc := Func;
+ if not ProcessSub(Block) then
+ begin
+ Block.Free;
+ exit;
+ end;
+ Block.Free;
+ CheckForUnusedVars(Func);
+ Result := ProcessLabelForwards(Func);
+ if assigned(FOnFunctionEnd) then
+ {$IFDEF PS_USESSUPPORT}
+ OnFunctionEnd(fModule + '.' + OriginalName, FParser.CurrTokenPos, FParser.Row, FParser.Col);
+ {$ELSE}
+ OnFunctionEnd(OriginalName, FParser.CurrTokenPos, FParser.Row, FParser.Col);
+ {$ENDIF}
+ finally
+ FunctionDecl.Free;
+ att.Free;
+ end;
+end;
+
+function GetParamType(BlockInfo: TPSBlockInfo; I: Longint): TPSType;
+begin
+ if BlockInfo.Proc.Decl.Result <> nil then dec(i);
+ if i = -1 then
+ Result := BlockInfo.Proc.Decl.Result
+ else
+ begin
+ Result := BlockInfo.Proc.Decl.Params[i].aType;
+ end;
+end;
+
+function TPSPascalCompiler.GetTypeNo(BlockInfo: TPSBlockInfo; p: TPSValue): TPSType;
+begin
+ if p.ClassType = TPSUnValueOp then
+ Result := TPSUnValueOp(p).aType
+ else if p.ClassType = TPSBinValueOp then
+ Result := TPSBinValueOp(p).aType
+ else if p.ClassType = TPSValueArray then
+ Result := at2ut(FindType('TVariantArray'))
+ else if p.ClassType = TPSValueData then
+ Result := TPSValueData(p).Data.FType
+ else if p is TPSValueProc then
+ Result := TPSValueProc(p).ResultType
+ else if (p is TPSValueVar) and (TPSValueVar(p).RecCount > 0) then
+ Result := TPSValueVar(p).RecItem[TPSValueVar(p).RecCount - 1].aType
+ else if p.ClassType = TPSValueGlobalVar then
+ Result := TPSVar(FVars[TPSValueGlobalVar(p).GlobalVarNo]).FType
+ else if p.ClassType = TPSValueParamVar then
+ Result := GetParamType(BlockInfo, TPSValueParamVar(p).ParamNo)
+ else if p is TPSValueLocalVar then
+ Result := TPSProcVar(BlockInfo.Proc.ProcVars[TPSValueLocalVar(p).LocalVarNo]).AType
+ else if p.classtype = TPSValueReplace then
+ Result := GetTypeNo(BlockInfo, TPSValueReplace(p).NewValue)
+ else
+ Result := nil;
+end;
+
+function TPSPascalCompiler.IsVarInCompatible(ft1, ft2: TPSType): Boolean;
+begin
+ ft1 := GetTypeCopyLink(ft1);
+ ft2 := GetTypeCopyLink(ft2);
+ Result := (ft1 <> ft2) and (ft2 <> nil);
+end;
+
+function TPSPascalCompiler.ValidateParameters(BlockInfo: TPSBlockInfo; Params: TPSParameters; ParamTypes: TPSParametersDecl): boolean;
+var
+ i, c: Longint;
+ pType: TPSType;
+
+begin
+ UseProc(ParamTypes);
+ c := 0;
+ for i := 0 to ParamTypes.ParamCount -1 do
+ begin
+ while (c < Longint(Params.Count)) and (Params[c].Val = nil) do
+ Inc(c);
+ if c >= Longint(Params.Count) then
+ begin
+ MakeError('', ecInvalidnumberOfParameters, '');
+ Result := False;
+ exit;
+ end;
+ Params[c].ExpectedType := ParamTypes.Params[i].aType;
+ Params[c].ParamMode := ParamTypes.Params[i].Mode;
+ if ParamTypes.Params[i].Mode <> pmIn then
+ begin
+ if not (Params[c].Val is TPSValueVar) then
+ begin
+ with MakeError('', ecVariableExpected, '') do
+ begin
+ Row := Params[c].Val.Row;
+ Col := Params[c].Val.Col;
+ Pos := Params[c].Val.Pos;
+ end;
+ result := false;
+ exit;
+ end;
+ PType := Params[c].ExpectedType;
+ if (PType = nil) or ((PType.BaseType = btArray) and (TPSArrayType(PType).ArrayTypeNo = nil) and (GetTypeNo(BlockInfo, Params[c].Val).BaseType = btArray)) or
+ (PType = FAnyString) then
+ begin
+ Params[c].ExpectedType := GetTypeNo(BlockInfo, Params[c].Val);
+ if PType <> nil then
+ if (Params[c].ExpectedType = nil) or not (Params[c].ExpectedType.BaseType in [btString, btWideString, btUnicodeString, btChar, btWideChar]) then begin
+ MakeError('', ecTypeMismatch, '');
+ Result := False;
+ exit;
+ end;
+ if Params[c].ExpectedType.BaseType = btChar then
+ Params[c].ExpectedType := FindBaseType(btString) else
+ if Params[c].ExpectedType.BaseType = btWideChar then
+ Params[c].ExpectedType := FindBaseType(btUnicodeString);
+ end else if (PType.BaseType = btArray) and (GetTypeNo(BlockInfo, Params[c].Val).BaseType = btArray) then
+ begin
+ if TPSArrayType(GetTypeNo(BlockInfo, Params[c].Val)).ArrayTypeNo <> TPSArrayType(PType).ArrayTypeNo then
+ begin
+ MakeError('', ecTypeMismatch, '');
+ Result := False;
+ exit;
+ end;
+ end else if IsVarInCompatible(PType, GetTypeNo(BlockInfo, Params[c].Val)) then
+ begin
+ MakeError('', ecTypeMismatch, '');
+ Result := False;
+ exit;
+ end;
+ end;
+ Inc(c);
+ end;
+ for i := c to Params.Count -1 do
+ begin
+ if Params[i].Val <> nil then
+ begin
+ MakeError('', ecInvalidnumberOfParameters, '');
+ Result := False;
+ exit;
+ end;
+ end;
+ Result := true;
+end;
+
+function TPSPascalCompiler.DoTypeBlock(FParser: TPSPascalParser): Boolean;
+var
+ VOrg,VName: tbtString;
+ Attr: TPSAttributes;
+ FType: TPSType;
+ i: Longint;
+begin
+ Result := False;
+ FParser.Next;
+ repeat
+ Attr := TPSAttributes.Create;
+ if not ReadAttributes(Attr) then
+ begin
+ Attr.Free;
+ exit;
+ end;
+ if (FParser.CurrTokenID = CSTII_Procedure) or (FParser.CurrTokenID = CSTII_Function) then
+ begin
+ Result := ProcessFunction(false, Attr);
+ exit;
+ end;
+ if FParser.CurrTokenId <> CSTI_Identifier then
+ begin
+ MakeError('', ecIdentifierExpected, '');
+ Attr.Free;
+ exit;
+ end;
+
+ VName := FParser.GetToken;
+ VOrg := FParser.OriginalToken;
+ if IsDuplicate(VName, [dcTypes, dcProcs, dcVars]) then
+ begin
+ MakeError('', ecDuplicateIdentifier, FParser.OriginalToken);
+ Attr.Free;
+ exit;
+ end;
+
+ FParser.Next;
+ if FParser.CurrTokenId <> CSTI_Equal then
+ begin
+ MakeError('', ecIsExpected, '');
+ Attr.Free;
+ exit;
+ end;
+ FParser.Next;
+ FType := ReadType(VOrg, FParser);
+ if Ftype = nil then
+ begin
+ Attr.Free;
+ Exit;
+ end;
+ FType.Attributes.Assign(Attr, True);
+ for i := 0 to FType.Attributes.Count -1 do
+ begin
+ if @FType.Attributes[i].FAttribType.FAAType <> nil then
+ FType.Attributes[i].FAttribType.FAAType(Self, FType, Attr[i]);
+ end;
+ Attr.Free;
+ if FParser.CurrTokenID <> CSTI_Semicolon then
+ begin
+ MakeError('', ecSemicolonExpected, '');
+ Exit;
+ end;
+ FParser.Next;
+ until (FParser.CurrTokenId <> CSTI_Identifier) and (FParser.CurrTokenID <> CSTI_OpenBlock);
+ Result := True;
+end;
+
+procedure TPSPascalCompiler.Debug_WriteLine(BlockInfo: TPSBlockInfo);
+var
+ b: Boolean;
+begin
+ if @FOnWriteLine <> nil then begin
+ {$IFNDEF PS_USESSUPPORT}
+ b := FOnWriteLine(Self, FParser.CurrTokenPos);
+ {$ELSE}
+ b := FOnWriteLine(Self, FModule, FParser.CurrTokenPos);
+ {$ENDIF}
+ end else
+ b := true;
+ if b then Debug_SavePosition(BlockInfo.ProcNo, BlockInfo.Proc);
+end;
+
+
+function TPSPascalCompiler.ReadReal(const s: tbtString): PIfRVariant;
+var
+ C: Integer;
+begin
+ New(Result);
+ InitializeVariant(Result, FindBaseType(btExtended));
+ Val(string(s), Result^.textended, C);
+end;
+
+function TPSPascalCompiler.ReadString: PIfRVariant;
+{$IFNDEF PS_NOWIDESTRING}var wchar: Boolean;{$ENDIF}
+
+ function ParseString({$IFNDEF PS_NOWIDESTRING}var res: tbtunicodestring{$ELSE}var res: tbtString{$ENDIF}): Boolean;
+ var
+ temp3: {$IFNDEF PS_NOWIDESTRING}tbtunicodestring{$ELSE}tbtString{$ENDIF};
+
+ function ChrToStr(s: tbtString): {$IFNDEF PS_NOWIDESTRING}widechar{$ELSE}tbtchar{$ENDIF};
+ var
+ w: Longint;
+ begin
+ Delete(s, 1, 1); {First char : #}
+ w := StrToInt(s);
+ Result := {$IFNDEF PS_NOWIDESTRING}widechar{$ELSE}tbtchar{$ENDIF}(w);
+ {$IFNDEF PS_NOWIDESTRING}if w > $FF then wchar := true;{$ENDIF}
+ end;
+
+ function PString(s: tbtString): tbtString;
+ var
+ i: Longint;
+ begin
+ s := copy(s, 2, Length(s) - 2);
+ i := length(s);
+ while i > 0 do
+ begin
+ if (i < length(s)) and (s[i] = #39) and (s[i + 1] = #39) then
+ begin
+ Delete(s, i, 1);
+ dec(i);
+ end;
+ dec(i);
+ end;
+ PString := s;
+ end;
+ var
+ lastwasstring: Boolean;
+ begin
+ temp3 := '';
+ while (FParser.CurrTokenId = CSTI_String) or (FParser.CurrTokenId = CSTI_Char) do
+ begin
+ lastwasstring := FParser.CurrTokenId = CSTI_String;
+ if FParser.CurrTokenId = CSTI_String then
+ begin
+ if UTF8Decode then
+ begin
+ temp3 := temp3 + {$IFNDEF PS_NOWIDESTRING}{$IFDEF DELPHI6UP}System.{$IFDEF DELPHI2009UP}UTF8ToWidestring{$ELSE}UTF8Decode{$ENDIF}{$ENDIF}{$ENDIF}(PString(FParser.GetToken));
+ {$IFNDEF PS_NOWIDESTRING}wchar:=true;{$ENDIF}
+ end else
+ temp3 := temp3 + tbtUnicodestring(PString(FParser.GetToken));
+
+ FParser.Next;
+ if FParser.CurrTokenId = CSTI_String then
+ temp3 := temp3 + #39;
+ end {if}
+ else
+ begin
+ temp3 := temp3 + ChrToStr(FParser.GetToken);
+ FParser.Next;
+ end; {else if}
+ if lastwasstring and (FParser.CurrTokenId = CSTI_String) then
+ begin
+ MakeError('', ecSyntaxError, '');
+ result := false;
+ exit;
+ end;
+ end; {while}
+ res := temp3;
+ result := true;
+ end;
+var
+{$IFNDEF PS_NOWIDESTRING}
+ w: tbtunicodestring;
+{$ENDIF}
+ s: tbtString;
+begin
+ {$IFNDEF PS_NOWIDESTRING}wchar:=false;{$ENDIF}
+ if not ParseString({$IFDEF PS_NOWIDESTRING} s {$ELSE} w {$ENDIF}) then
+ begin
+ result := nil;
+ exit;
+ end;
+{$IFNDEF PS_NOWIDESTRING}
+ if wchar then
+ begin
+ New(Result);
+ if Length(w) = 1 then
+ begin
+ InitializeVariant(Result, at2ut(FindBaseType(btwidechar)));
+ Result^.twidechar := w[1];
+ end else begin
+ InitializeVariant(Result, at2ut(FindBaseType(btUnicodeString)));
+ tbtunicodestring(Result^.tunistring) := w;
+ end;
+ end else begin
+ s := tbtstring(w);
+{$ENDIF}
+ New(Result);
+ if Length(s) = 1 then
+ begin
+ InitializeVariant(Result, at2ut(FindBaseType(btchar)));
+ Result^.tchar := s[1];
+ end else begin
+ InitializeVariant(Result, at2ut(FindBaseType(btstring)));
+ tbtstring(Result^.tstring) := s;
+ end;
+{$IFNDEF PS_NOWIDESTRING}
+ end;
+{$ENDIF}
+end;
+
+
+function TPSPascalCompiler.ReadInteger(const s: tbtString): PIfRVariant;
+var
+ R: {$IFNDEF PS_NOINT64}Int64;{$ELSE}Longint;{$ENDIF}
+begin
+ New(Result);
+{$IFNDEF PS_NOINT64}
+ r := StrToInt64Def(string(s), 0);
+ if (r >= Low(Integer)) and (r <= High(Integer)) then
+ begin
+ InitializeVariant(Result, at2ut(FindBaseType(bts32)));
+ Result^.ts32 := r;
+ end else if (r <= $FFFFFFFF) then
+ begin
+ InitializeVariant(Result, at2ut(FindBaseType(btu32)));
+ Result^.tu32 := r;
+ end else
+ begin
+ InitializeVariant(Result, at2ut(FindBaseType(bts64)));
+ Result^.ts64 := r;
+ end;
+{$ELSE}
+ r := StrToIntDef(s, 0);
+ InitializeVariant(Result, at2ut(FindBaseType(bts32)));
+ Result^.ts32 := r;
+{$ENDIF}
+end;
+
+function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
+
+ function AllocStackReg2(MType: TPSType): TPSValue;
+ var
+ x: TPSProcVar;
+ begin
+{$IFDEF DEBUG}
+ if (mtype = nil) or (not mtype.Used) then asm int 3; end;
+{$ENDIF}
+ x := TPSProcVar.Create;
+ {$IFDEF PS_USESSUPPORT}
+ x.DeclareUnit:=fModule;
+ {$ENDIF}
+ x.DeclarePos := FParser.CurrTokenPos;
+ x.DeclareRow := FParser.Row;
+ x.DeclareCol := FParser.Col;
+ x.Name := '';
+ x.AType := MType;
+ x.Use;
+ BlockInfo.Proc.ProcVars.Add(x);
+ Result := TPSValueAllocatedStackVar.Create;
+ Result.SetParserPos(FParser);
+ TPSValueAllocatedStackVar(Result).Proc := BlockInfo.Proc;
+ with TPSValueAllocatedStackVar(Result) do
+ begin
+ LocalVarNo := proc.ProcVars.Count -1;
+ end;
+ end;
+
+ function AllocStackReg(MType: TPSType): TPSValue;
+ begin
+ Result := AllocStackReg2(MType);
+ BlockWriteByte(BlockInfo, Cm_Pt);
+ BlockWriteLong(BlockInfo, MType.FinalTypeNo);
+ end;
+
+ function AllocPointer(MDestType: TPSType): TPSValue;
+ begin
+ Result := AllocStackReg(at2ut(FindBaseType(btPointer)));
+ TPSProcVar(BlockInfo.Proc.ProcVars[TPSValueAllocatedStackVar(Result).LocalVarNo]).AType := MDestType;
+ end;
+
+ function WriteCalculation(InData, OutReg: TPSValue): Boolean; forward;
+ function PreWriteOutRec(var X: TPSValue; FArrType: TPSType): Boolean; forward;
+ function WriteOutRec(x: TPSValue; AllowData: Boolean): Boolean; forward;
+ procedure AfterWriteOutRec(var x: TPSValue); forward;
+
+ function CheckCompatType(V1, v2: TPSValue): Boolean;
+ var
+ p1, P2: TPSType;
+ begin
+ p1 := GetTypeNo(BlockInfo, V1);
+ P2 := GetTypeNo(BlockInfo, v2);
+ if (p1 = nil) or (p2 = nil) then
+ begin
+ if ((p1 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p1.ClassType = TPSInterfaceType) or {$ENDIF}(p1.BaseType = btProcPtr)) and (v2.ClassType = TPSValueNil)) or
+ ((p2 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p2.ClassType = TPSInterfaceType) or {$ENDIF}(p2.BaseType = btProcPtr)) and (v1.ClassType = TPSValueNil)) then
+ begin
+ Result := True;
+ exit;
+ end else
+ if ((p1 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p1.ClassType = TPSInterfaceType) or {$ENDIF}(p1.ClassType = TPSClassType)) and (v2.ClassType = TPSValueNil)) or
+ ((p2 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p2.ClassType = TPSInterfaceType) or {$ENDIF}(p2.ClassType = TPSClassType)) and (v1.ClassType = TPSValueNil)) then
+ begin
+ Result := True;
+ exit;
+ end else
+ if ((p1 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p1.ClassType = TPSInterfaceType) or {$ENDIF}(p1.ClassType = TPSUndefinedClassType)) and (v2.ClassType = TPSValueNil)) or
+ ((p2 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p2.ClassType = TPSInterfaceType) or {$ENDIF}(p2.ClassType = TPSUndefinedClassType)) and (v1.ClassType = TPSValueNil)) then
+ begin
+ Result := True;
+ exit;
+ end else
+ if (v1.ClassType = TPSValueProcPtr) and (p2 <> nil) and (p2.BaseType = btProcPtr) then
+ begin
+ Result := CheckCompatProc(p2, TPSValueProcPtr(v1).ProcPtr);
+ exit;
+ end else if (v2.ClassType = TPSValueProcPtr) and (p1 <> nil) and (p1.BaseType = btProcPtr) then
+ begin
+ Result := CheckCompatProc(p1, TPSValueProcPtr(v2).ProcPtr);
+ exit;
+ end;
+ Result := False;
+ end else
+ if (p1 <> nil) and (p1.BaseType = btSet) and (v2 is TPSValueArray) then
+ begin
+ Result := True;
+ end else
+ Result := IsCompatibleType(p1, p2, False);
+ end;
+
+ function _ProcessFunction(ProcCall: TPSValueProc; ResultRegister: TPSValue): Boolean; forward;
+ function ProcessFunction2(ProcNo: Cardinal; Par: TPSParameters; ResultReg: TPSValue): Boolean;
+ var
+ Temp: TPSValueProcNo;
+ i: Integer;
+ begin
+ Temp := TPSValueProcNo.Create;
+ Temp.Parameters := Par;
+ Temp.ProcNo := ProcNo;
+ if TObject(FProcs[ProcNo]).ClassType = TPSInternalProcedure then
+ Temp.ResultType := TPSInternalProcedure(FProcs[ProcNo]).Decl.Result
+ else
+ Temp.ResultType := TPSExternalProcedure(FProcs[ProcNo]).RegProc.Decl.Result;
+ if (Temp.ResultType <> nil) and (Temp.ResultType = FAnyString) then begin // workaround to make the result type match
+ for i := 0 to Par.Count -1 do begin
+ if Par[i].ExpectedType.BaseType in [btString, btWideString] then
+ Temp.ResultType := Par[i].ExpectedType;
+ end;
+ end;
+ Result := _ProcessFunction(Temp, ResultReg);
+ Temp.Parameters := nil;
+ Temp.Free;
+ end;
+
+ function MakeNil(NilPos, NilRow, nilCol: Cardinal;ivar: TPSValue): Boolean;
+ var
+ Procno: Cardinal;
+ PF: TPSType;
+ Par: TPSParameters;
+ begin
+ Pf := GetTypeNo(BlockInfo, IVar);
+ if not (Ivar is TPSValueVar) then
+ begin
+ with MakeError('', ecTypeMismatch, '') do
+ begin
+ FPosition := nilPos;
+ FRow := NilRow;
+ FCol := nilCol;
+ end;
+ Result := False;
+ exit;
+ end;
+ if (pf.BaseType = btProcPtr) then
+ begin
+ Result := True;
+ end else
+ if (pf.BaseType = btString) or (pf.BaseType = btPChar) then
+ begin
+ if not PreWriteOutRec(iVar, nil) then
+ begin
+ Result := false;
+ exit;
+ end;
+ BlockWriteByte(BlockInfo, CM_A);
+ WriteOutRec(ivar, False);
+ BlockWriteByte(BlockInfo, 1);
+ BlockWriteLong(BlockInfo, GetTypeNo(BlockInfo, IVar).FinalTypeNo);
+ BlockWriteLong(BlockInfo, 0); //empty tbtString
+ AfterWriteOutRec(ivar);
+ Result := True;
+ end else if (pf.BaseType = btClass) {$IFNDEF PS_NOINTERFACES}or (pf.BaseType = btInterface){$ENDIF} then
+ begin
+{$IFNDEF PS_NOINTERFACES}
+ if (pf.BaseType = btClass) then
+ begin
+{$ENDIF}
+ if not TPSClassType(pf).Cl.SetNil(ProcNo) then
+ begin
+ with MakeError('', ecTypeMismatch, '') do
+ begin
+ FPosition := nilPos;
+ FRow := NilRow;
+ FCol := nilCol;
+ end;
+ Result := False;
+ exit;
+ end;
+{$IFNDEF PS_NOINTERFACES}
+ end else
+ begin
+ if not TPSInterfaceType(pf).Intf.SetNil(ProcNo) then
+ begin
+ with MakeError('', ecTypeMismatch, '') do
+ begin
+ FPosition := nilPos;
+ FRow := NilRow;
+ FCol := nilCol;
+ end;
+ Result := False;
+ exit;
+ end;
+ end;
+{$ENDIF}
+ Par := TPSParameters.Create;
+ with par.Add do
+ begin
+ Val := IVar;
+ ExpectedType := GetTypeNo(BlockInfo, ivar);
+{$IFDEF DEBUG}
+ if not ExpectedType.Used then asm int 3; end;
+{$ENDIF}
+ ParamMode := pmInOut;
+ end;
+ Result := ProcessFunction2(ProcNo, Par, nil);
+
+ Par[0].Val := nil; // don't free IVAR
+
+ Par.Free;
+ end else if pf.BaseType = btExtClass then
+ begin
+ if not TPSUndefinedClassType(pf).ExtClass.SetNil(ProcNo) then
+ begin
+ with MakeError('', ecTypeMismatch, '') do
+ begin
+ FPosition := nilPos;
+ FRow := NilRow;
+ FCol := nilCol;
+ end;
+ Result := False;
+ exit;
+ end;
+ Par := TPSParameters.Create;
+ with par.Add do
+ begin
+ Val := IVar;
+ ExpectedType := GetTypeNo(BlockInfo, ivar);
+ ParamMode := pmInOut;
+ end;
+ Result := ProcessFunction2(ProcNo, Par, nil);
+
+ Par[0].Val := nil; // don't free IVAR
+
+ Par.Free;
+ end else begin
+ with MakeError('', ecTypeMismatch, '') do
+ begin
+ FPosition := nilPos;
+ FRow := NilRow;
+ FCol := nilCol;
+ end;
+ Result := False;
+ end;
+ end;
+ function DoBinCalc(BVal: TPSBinValueOp; Output: TPSValue): Boolean;
+ var
+ tmpp, tmpc: TPSValue;
+ jend, jover: Cardinal;
+ procno: Cardinal;
+
+ begin
+ if BVal.Operator >= otGreaterEqual then
+ begin
+ if BVal.FVal1.ClassType = TPSValueNil then
+ begin
+ tmpp := AllocStackReg(GetTypeNo(BlockInfo, BVal.FVal2));
+ if not MakeNil(BVal.FVal1.Pos, BVal.FVal1.Row, BVal.FVal1.Col, tmpp) then
+ begin
+ tmpp.Free;
+ Result := False;
+ exit;
+ end;
+ tmpc := TPSValueReplace.Create;
+ with TPSValueReplace(tmpc) do
+ begin
+ OldValue := BVal.FVal1;
+ NewValue := tmpp;
+ end;
+ BVal.FVal1 := tmpc;
+ end;
+ if BVal.FVal2.ClassType = TPSValueNil then
+ begin
+ tmpp := AllocStackReg(GetTypeNo(BlockInfo, BVal.FVal1));
+ if not MakeNil(BVal.FVal2.Pos, BVal.FVal2.Row, BVal.FVal2.Col, tmpp) then
+ begin
+ tmpp.Free;;
+ Result := False;
+ exit;
+ end;
+ tmpc := TPSValueReplace.Create;
+ with TPSValueReplace(tmpc) do
+ begin
+ OldValue := BVal.FVal2;
+ NewValue := tmpp;
+ end;
+ BVal.FVal2 := tmpc;
+ end;
+ if GetTypeNo(BlockInfo, BVal.FVal1).BaseType = btExtClass then
+ begin
+ if not TPSUndefinedClassType(GetTypeNo(BlockInfo, BVal.FVal1)).ExtClass.CompareClass(GetTypeNo(BlockInfo, Bval.FVal2), ProcNo) then
+ begin
+ Result := False;
+ exit;
+ end;
+ tmpp := TPSValueProcNo.Create;
+ with TPSValueProcNo(tmpp) do
+ begin
+ ResultType := at2ut(FDefaultBoolType);
+ Parameters := TPSParameters.Create;
+ ProcNo := procno;
+ Pos := BVal.Pos;
+ Col := BVal.Col;
+ Row := BVal.Row;
+ with parameters.Add do
+ begin
+ Val := BVal.FVal1;
+ ExpectedType := GetTypeNo(BlockInfo, Val);
+ end;
+ with parameters.Add do
+ begin
+ Val := BVal.FVal2;
+ ExpectedType := GetTypeNo(BlockInfo, Val);
+ end;
+ end;
+ if Bval.Operator = otNotEqual then
+ begin
+ tmpc := TPSUnValueOp.Create;
+ TPSUnValueOp(tmpc).Operator := otNot;
+ TPSUnValueOp(tmpc).Val1 := tmpp;
+ TPSUnValueOp(tmpc).aType := GetTypeNo(BlockInfo, tmpp);
+ end else tmpc := tmpp;
+ Result := WriteCalculation(tmpc, Output);
+ with TPSValueProcNo(tmpp) do
+ begin
+ Parameters[0].Val := nil;
+ Parameters[1].Val := nil;
+ end;
+ tmpc.Free;
+ if BVal.Val1.ClassType = TPSValueReplace then
+ begin
+ tmpp := TPSValueReplace(BVal.Val1).OldValue;
+ BVal.Val1.Free;
+ BVal.Val1 := tmpp;
+ end;
+ if BVal.Val2.ClassType = TPSValueReplace then
+ begin
+ tmpp := TPSValueReplace(BVal.Val2).OldValue;
+ BVal.Val2.Free;
+ BVal.Val2 := tmpp;
+ end;
+ exit;
+ end;
+ if not (PreWriteOutRec(Output, nil) and PreWriteOutRec(BVal.FVal1, GetTypeNo(BlockInfo, BVal.FVal2)) and PreWriteOutRec(BVal.FVal2, GetTypeNo(BlockInfo, BVal.FVal1))) then
+ begin
+ Result := False;
+ exit;
+ end;
+ BlockWriteByte(BlockInfo, CM_CO);
+ case BVal.Operator of
+ otGreaterEqual: BlockWriteByte(BlockInfo, 0);
+ otLessEqual: BlockWriteByte(BlockInfo, 1);
+ otGreater: BlockWriteByte(BlockInfo, 2);
+ otLess: BlockWriteByte(BlockInfo, 3);
+ otEqual: BlockWriteByte(BlockInfo, 5);
+ otNotEqual: BlockWriteByte(BlockInfo, 4);
+ otIn: BlockWriteByte(BlockInfo, 6);
+ otIs: BlockWriteByte(BlockInfo, 7);
+ end;
+
+ if not (WriteOutRec(Output, False) and writeOutRec(BVal.FVal1, True) and writeOutRec(BVal.FVal2, True)) then
+ begin
+ Result := False;
+ exit;
+ end;
+ AfterWriteOutrec(BVal.FVal1);
+ AfterWriteOutrec(BVal.FVal2);
+ AfterWriteOutrec(Output);
+ if BVal.Val1.ClassType = TPSValueReplace then
+ begin
+ tmpp := TPSValueReplace(BVal.Val1).OldValue;
+ BVal.Val1.Free;
+ BVal.Val1 := tmpp;
+ end;
+ if BVal.Val2.ClassType = TPSValueReplace then
+ begin
+ tmpp := TPSValueReplace(BVal.Val2).OldValue;
+ BVal.Val2.Free;
+ BVal.Val2 := tmpp;
+ end;
+ end else begin
+ if not PreWriteOutRec(Output, nil) then
+ begin
+ Result := False;
+ exit;
+ end;
+ if not SameReg(Output, BVal.Val1) then
+ begin
+ if not WriteCalculation(BVal.FVal1, Output) then
+ begin
+ Result := False;
+ exit;
+ end;
+ end;
+ if (FBooleanShortCircuit) and (IsBoolean(BVal.aType)) then
+ begin
+ if BVal.Operator = otAnd then
+ begin
+ BlockWriteByte(BlockInfo, Cm_CNG);
+ jover := Length(BlockInfo.Proc.FData);
+ BlockWriteLong(BlockInfo, 0);
+ WriteOutRec(Output, True);
+ jend := Length(BlockInfo.Proc.FData);
+ end else if BVal.Operator = otOr then
+ begin
+ BlockWriteByte(BlockInfo, Cm_CG);
+ jover := Length(BlockInfo.Proc.FData);
+ BlockWriteLong(BlockInfo, 0);
+ WriteOutRec(Output, True);
+ jend := Length(BlockInfo.Proc.FData);
+ end else
+ begin
+ jover := 0;
+ jend := 0;
+ end;
+ end else
+ begin
+ jover := 0;
+ jend := 0;
+ end;
+ if not PreWriteOutrec(BVal.FVal2, GetTypeNo(BlockInfo, Output)) then
+ begin
+ Result := False;
+ exit;
+ end;
+ BlockWriteByte(BlockInfo, Cm_CA);
+ BlockWriteByte(BlockInfo, Ord(BVal.Operator));
+ if not (WriteOutRec(Output, False) and WriteOutRec(BVal.FVal2, True)) then
+ begin
+ Result := False;
+ exit;
+ end;
+ AfterWriteOutRec(BVal.FVal2);
+ if FBooleanShortCircuit and (IsBoolean(BVal.aType)) and (JOver <> JEnd) then
+ begin
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ unaligned(Cardinal((@BlockInfo.Proc.FData[jover+1])^)) := Cardinal(Length(BlockInfo.Proc.FData)) - jend;
+ {$else}
+ Cardinal((@BlockInfo.Proc.FData[jover+1])^) := Cardinal(Length(BlockInfo.Proc.FData)) - jend;
+ {$endif}
+ end;
+ AfterWriteOutRec(Output);
+ end;
+ Result := True;
+ end;
+
+ function DoUnCalc(Val: TPSUnValueOp; Output: TPSValue): Boolean;
+ var
+ Tmp: TPSValue;
+ begin
+ if not PreWriteOutRec(Output, nil) then
+ begin
+ Result := False;
+ exit;
+ end;
+ case Val.Operator of
+ otNot:
+ begin
+ if not SameReg(Val.FVal1, Output) then
+ begin
+ if not WriteCalculation(Val.FVal1, Output) then
+ begin
+ Result := False;
+ exit;
+ end;
+ end;
+ if IsBoolean(GetTypeNo(BlockInfo, Val)) then
+ BlockWriteByte(BlockInfo, cm_bn)
+ else
+ BlockWriteByte(BlockInfo, cm_in);
+ if not WriteOutRec(Output, True) then
+ begin
+ Result := False;
+ exit;
+ end;
+ end;
+ otMinus:
+ begin
+ if not SameReg(Val.FVal1, Output) then
+ begin
+ if not WriteCalculation(Val.FVal1, Output) then
+ begin
+ Result := False;
+ exit;
+ end;
+ end;
+ BlockWriteByte(BlockInfo, cm_vm);
+ if not WriteOutRec(Output, True) then
+ begin
+ Result := False;
+ exit;
+ end;
+ end;
+ otCast:
+ begin
+ if ((Val.aType.BaseType = btChar) and (Val.aType.BaseType <> btU8)) {$IFNDEF PS_NOWIDESTRING}or
+ ((Val.aType.BaseType = btWideChar) and (Val.aType.BaseType <> btU16)){$ENDIF} then
+ begin
+ Tmp := AllocStackReg(Val.aType);
+ end else
+ Tmp := Output;
+ if not (PreWriteOutRec(Val.FVal1, GetTypeNo(BlockInfo, Tmp)) and PreWriteOutRec(Tmp, GetTypeNo(BlockInfo, Tmp))) then
+ begin
+ Result := False;
+ if tmp <> Output then Tmp.Free;
+ exit;
+ end;
+ BlockWriteByte(BlockInfo, CM_A);
+ if not (WriteOutRec(Tmp, False) and WriteOutRec(Val.FVal1, True)) then
+ begin
+ Result := false;
+ if tmp <> Output then Tmp.Free;
+ exit;
+ end;
+ AfterWriteOutRec(val.Fval1);
+ if Tmp <> Output then
+ begin
+ if not WriteCalculation(Tmp, Output) then
+ begin
+ Result := false;
+ Tmp.Free;
+ exit;
+ end;
+ end;
+ AfterWriteOutRec(Tmp);
+ if Tmp <> Output then
+ Tmp.Free;
+ end;
+ {else donothing}
+ end;
+ AfterWriteOutRec(Output);
+ Result := True;
+ end;
+
+
+ function GetAddress(Val: TPSValue): Cardinal;
+ begin
+ if Val.ClassType = TPSValueGlobalVar then
+ Result := TPSValueGlobalVar(val).GlobalVarNo
+ else if Val.ClassType = TPSValueLocalVar then
+ Result := PSAddrStackStart + TPSValueLocalVar(val).LocalVarNo + 1
+ else if Val.ClassType = TPSValueParamVar then
+ Result := PSAddrStackStart - TPSValueParamVar(val).ParamNo -1
+ else if Val.ClassType = TPSValueAllocatedStackVar then
+ Result := PSAddrStackStart + TPSValueAllocatedStackVar(val).LocalVarNo + 1
+ else
+ Result := InvalidVal;
+ end;
+
+
+ function PreWriteOutRec(var X: TPSValue; FArrType: TPSType): Boolean;
+ var
+ rr: TPSSubItem;
+ tmpp,
+ tmpc: TPSValue;
+ i: Longint;
+ function MakeSet(SetType: TPSSetType; arr: TPSValueArray): Boolean;
+ var
+ c, i: Longint;
+ dataval: TPSValueData;
+ mType: TPSType;
+ begin
+ Result := True;
+ dataval := TPSValueData.Create;
+ dataval.Data := NewVariant(FarrType);
+ for i := 0 to arr.count -1 do
+ begin
+ mType := GetTypeNo(BlockInfo, arr.Item[i]);
+ if mType <> SetType.SetType then
+ begin
+ with MakeError('', ecTypeMismatch, '') do
+ begin
+ FCol := arr.item[i].Col;
+ FRow := arr.item[i].Row;
+ FPosition := arr.item[i].Pos;
+ end;
+ DataVal.Free;
+ Result := False;
+ exit;
+ end;
+ if arr.Item[i] is TPSValueData then
+ begin
+ c := GetInt(TPSValueData(arr.Item[i]).Data, Result);
+ if not Result then
+ begin
+ dataval.Free;
+ exit;
+ end;
+ Set_MakeMember(c, dataval.Data.tstring);
+ end else
+ begin
+ DataVal.Free;
+ MakeError('', ecTypeMismatch, '');
+ Result := False;
+ exit;
+ end;
+ end;
+ tmpc := TPSValueReplace.Create;
+ with TPSValueReplace(tmpc) do
+ begin
+ OldValue := x;
+ NewValue := dataval;
+ PreWriteAllocated := True;
+ end;
+ x := tmpc;
+ end;
+ begin
+ Result := True;
+ if x.ClassType = TPSValueReplace then
+ begin
+ if TPSValueReplace(x).PreWriteAllocated then
+ begin
+ inc(TPSValueReplace(x).FReplaceTimes);
+ end;
+ end else
+ if x.ClassType = TPSValueProcPtr then
+ begin
+ if FArrType = nil then
+ begin
+ MakeError('', ecTypeMismatch, '');
+ Result := False;
+ Exit;
+ end;
+ tmpp := TPSValueData.Create;
+ TPSValueData(tmpp).Data := NewVariant(FArrType);
+ TPSValueData(tmpp).Data.tu32 := TPSValueProcPtr(x).ProcPtr;
+ tmpc := TPSValueReplace.Create;
+ with TPSValueReplace(tmpc) do
+ begin
+ PreWriteAllocated := True;
+ OldValue := x;
+ NewValue := tmpp;
+ end;
+ x := tmpc;
+ end else
+ if x.ClassType = TPSValueNil then
+ begin
+ if FArrType = nil then
+ begin
+ MakeError('', ecTypeMismatch, '');
+ Result := False;
+ Exit;
+ end;
+ tmpp := AllocStackReg(FArrType);
+ if not MakeNil(x.Pos, x.Row, x.Col, tmpp) then
+ begin
+ tmpp.Free;
+ Result := False;
+ exit;
+ end;
+ tmpc := TPSValueReplace.Create;
+ with TPSValueReplace(tmpc) do
+ begin
+ PreWriteAllocated := True;
+ OldValue := x;
+ NewValue := tmpp;
+ end;
+ x := tmpc;
+ end else
+ if x.ClassType = TPSValueArray then
+ begin
+ if FArrType = nil then
+ begin
+ MakeError('', ecTypeMismatch, '');
+ Result := False;
+ Exit;
+ end;
+ if TPSType(FArrType).BaseType = btSet then
+ begin
+ Result := MakeSet(TPSSetType(FArrType), TPSValueArray(x));
+ exit;
+ end;
+ if TPSType(FarrType).BaseType = btVariant then
+ FArrType := FindAndAddType(self, '', 'array of variant');
+ if TPSType(FarrType).BaseType <> btArray then
+ FArrType := FindAndAddType(self, '', 'array of variant');
+
+ tmpp := AllocStackReg(FArrType);
+ tmpc := AllocStackReg(FindBaseType(bts32));
+ BlockWriteByte(BlockInfo, CM_A);
+ WriteOutrec(tmpc, False);
+ BlockWriteByte(BlockInfo, 1);
+ BlockWriteLong(BlockInfo, FindBaseType(bts32).FinalTypeNo);
+ BlockWriteLong(BlockInfo, TPSValueArray(x).Count);
+ BlockWriteByte(BlockInfo, CM_PV);
+ WriteOutrec(tmpp, False);
+ BlockWriteByte(BlockInfo, CM_C);
+ BlockWriteLong(BlockInfo, FindProc('SETARRAYLENGTH'));
+ BlockWriteByte(BlockInfo, CM_PO);
+ tmpc.Free;
+ rr := TPSSubNumber.Create;
+ rr.aType := TPSArrayType(FArrType).ArrayTypeNo;
+ TPSValueVar(tmpp).RecAdd(rr);
+ for i := 0 to TPSValueArray(x).Count -1 do
+ begin
+ TPSSubNumber(rr).SubNo := i;
+ tmpc := TPSValueArray(x).Item[i];
+ if not PreWriteOutRec(tmpc, GetTypeNo(BlockInfo, tmpc)) then
+ begin
+ tmpp.Free;
+ Result := false;
+ exit;
+ end;
+ if TPSArrayType(FArrType).ArrayTypeNo.BaseType = btPointer then
+ BlockWriteByte(BlockInfo, cm_spc)
+ else
+ BlockWriteByte(BlockInfo, cm_a);
+ if not (WriteOutrec(tmpp, False) and WriteOutRec(tmpc, True)) then
+ begin
+ Tmpp.Free;
+ Result := false;
+ exit;
+ end;
+ AfterWriteOutRec(tmpc);
+ end;
+ TPSValueVar(tmpp).RecDelete(0);
+ tmpc := TPSValueReplace.Create;
+ with TPSValueReplace(tmpc) do
+ begin
+ PreWriteAllocated := True;
+ OldValue := x;
+ NewValue := tmpp;
+ end;
+ x := tmpc;
+ end else if (x.ClassType = TPSUnValueOp) then
+ begin
+ tmpp := AllocStackReg(GetTypeNo(BlockInfo, x));
+ if not DoUnCalc(TPSUnValueOp(x), tmpp) then
+ begin
+ Result := False;
+ exit;
+ end;
+ tmpc := TPSValueReplace.Create;
+ with TPSValueReplace(tmpc) do
+ begin
+ PreWriteAllocated := True;
+ OldValue := x;
+ NewValue := tmpp;
+ end;
+ x := tmpc;
+ end else if (x.ClassType = TPSBinValueOp) then
+ begin
+ tmpp := AllocStackReg(GetTypeNo(BlockInfo, x));
+ if not DoBinCalc(TPSBinValueOp(x), tmpp) then
+ begin
+ tmpp.Free;
+ Result := False;
+ exit;
+ end;
+ tmpc := TPSValueReplace.Create;
+ with TPSValueReplace(tmpc) do
+ begin
+ PreWriteAllocated := True;
+ OldValue := x;
+ NewValue := tmpp;
+ end;
+ x := tmpc;
+ end else if x is TPSValueProc then
+ begin
+ tmpp := AllocStackReg(TPSValueProc(x).ResultType);
+ if not WriteCalculation(x, tmpp) then
+ begin
+ tmpp.Free;
+ Result := False;
+ exit;
+ end;
+ tmpc := TPSValueReplace.Create;
+ with TPSValueReplace(tmpc) do
+ begin
+ PreWriteAllocated := True;
+ OldValue := x;
+ NewValue := tmpp;
+ end;
+ x := tmpc;
+ end else if (x is TPSValueVar) and (TPSValueVar(x).RecCount <> 0) then
+ begin
+ if TPSValueVar(x).RecCount = 1 then
+ begin
+ rr := TPSValueVar(x).RecItem[0];
+ if rr.ClassType <> TPSSubValue then
+ exit; // there is no need pre-calculate anything
+ if (TPSSubValue(rr).SubNo is TPSValueVar) and (TPSValueVar(TPSSubValue(rr).SubNo).RecCount = 0) then
+ exit;
+ end; //if
+ tmpp := AllocPointer(GetTypeNo(BlockInfo, x));
+ BlockWriteByte(BlockInfo, cm_sp);
+ WriteOutRec(tmpp, True);
+ BlockWriteByte(BlockInfo, 0);
+ BlockWriteLong(BlockInfo, GetAddress(x));
+ for i := 0 to TPSValueVar(x).RecCount - 1 do
+ begin
+ rr := TPSValueVar(x).RecItem[I];
+ if rr.ClassType = TPSSubNumber then
+ begin
+ BlockWriteByte(BlockInfo, cm_sp);
+ WriteOutRec(tmpp, false);
+ BlockWriteByte(BlockInfo, 2);
+ BlockWriteLong(BlockInfo, GetAddress(tmpp));
+ BlockWriteLong(BlockInfo, TPSSubNumber(rr).SubNo);
+ end else begin // if rr.classtype = TPSSubValue then begin
+ tmpc := AllocStackReg(FindBaseType(btU32));
+ if not WriteCalculation(TPSSubValue(rr).SubNo, tmpc) then
+ begin
+ tmpc.Free;
+ tmpp.Free;
+ Result := False;
+ exit;
+ end; //if
+ BlockWriteByte(BlockInfo, cm_sp);
+ WriteOutRec(tmpp, false);
+ BlockWriteByte(BlockInfo, 3);
+ BlockWriteLong(BlockInfo, GetAddress(tmpp));
+ BlockWriteLong(BlockInfo, GetAddress(tmpc));
+ tmpc.Free;
+ end;
+ end; // for
+ tmpc := TPSValueReplace.Create;
+ with TPSValueReplace(tmpc) do
+ begin
+ OldValue := x;
+ NewValue := tmpp;
+ PreWriteAllocated := True;
+ end;
+ x := tmpc;
+ end;
+
+ end;
+
+ procedure AfterWriteOutRec(var x: TPSValue);
+ var
+ tmp: TPSValue;
+ begin
+ if (x.ClassType = TPSValueReplace) and (TPSValueReplace(x).PreWriteAllocated) then
+ begin
+ Dec(TPSValueReplace(x).FReplaceTimes);
+ if TPSValueReplace(x).ReplaceTimes = 0 then
+ begin
+ tmp := TPSValueReplace(x).OldValue;
+ x.Free;
+ x := tmp;
+ end;
+ end;
+ end; //afterwriteoutrec
+
+ function WriteOutRec(x: TPSValue; AllowData: Boolean): Boolean;
+ var
+ rr: TPSSubItem;
+ begin
+ Result := True;
+ if x.ClassType = TPSValueReplace then
+ Result := WriteOutRec(TPSValueReplace(x).NewValue, AllowData)
+ else if x is TPSValueVar then
+ begin
+ if TPSValueVar(x).RecCount = 0 then
+ begin
+ BlockWriteByte(BlockInfo, 0);
+ BlockWriteLong(BlockInfo, GetAddress(x));
+ end
+ else
+ begin
+ rr := TPSValueVar(x).RecItem[0];
+ if rr.ClassType = TPSSubNumber then
+ begin
+ BlockWriteByte(BlockInfo, 2);
+ BlockWriteLong(BlockInfo, GetAddress(x));
+ BlockWriteLong(BlockInfo, TPSSubNumber(rr).SubNo);
+ end
+ else
+ begin
+ BlockWriteByte(BlockInfo, 3);
+ BlockWriteLong(BlockInfo, GetAddress(x));
+ BlockWriteLong(BlockInfo, GetAddress(TPSSubValue(rr).SubNo));
+ end;
+ end;
+ end else if x.ClassType = TPSValueData then
+ begin
+ if AllowData then
+ begin
+ BlockWriteByte(BlockInfo, 1);
+ BlockWriteVariant(BlockInfo, TPSValueData(x).Data)
+ end
+ else
+ begin
+ Result := False;
+ exit;
+ end;
+ end else
+ Result := False;
+ end;
+
+ function ReadParameters(IsProperty: Boolean; Dest: TPSParameters): Boolean; forward;
+{$IFNDEF PS_NOIDISPATCH}
+ function ReadIDispatchParameters(const ProcName: tbtString; aVariantType: TPSVariantType; FSelf: TPSValue): TPSValue; forward;
+{$ENDIF}
+ function ReadProcParameters(ProcNo: Cardinal; FSelf: TPSValue): TPSValue; forward;
+ function ReadVarParameters(ProcNoVar: TPSValue): TPSValue; forward;
+
+ function calc(endOn: TPSPasToken): TPSValue; forward;
+ procedure CheckNotificationVariant(var Val: TPSValue);
+ var
+ aType: TPSType;
+ Call: TPSValueProcNo;
+ tmp: TPSValue;
+ begin
+ if not (Val is TPSValueGlobalVar) then exit;
+ aType := GetTypeNo(BlockInfo, Val);
+ if (AType = nil) or (AType.BaseType <> btNotificationVariant) then exit;
+ if FParser.CurrTokenId = CSTI_Assignment then
+ begin
+ Call := TPSValueProcNo.Create;
+ Call.ResultType := nil;
+ Call.SetParserPos(FParser);
+ Call.ProcNo := FindProc('!NOTIFICATIONVARIANTSET');;
+ Call.SetParserPos(FParser);
+ Call.Parameters := TPSParameters.Create;
+ Tmp := TPSValueData.Create;
+ TPSVAlueData(tmp).Data := NewVariant(at2ut(FindBaseType(btString)));
+ tbtString(TPSValueData(tmp).Data.tstring) := TPSVar(FVars[TPSValueGlobalVar(Val).GlobalVarNo]).OrgName;
+ with call.Parameters.Add do
+ begin
+ Val := tmp;
+ ExpectedType := TPSValueData(tmp).Data.FType;
+ end;
+ FParser.Next;
+ tmp := Calc(CSTI_SemiColon);
+ if tmp = nil then
+ begin
+ Val.Free;
+ Val := nil;
+ exit;
+ end;
+ with Call.Parameters.Add do
+ begin
+ Val := tmp;
+ ExpectedType := at2ut(FindBaseType(btVariant));
+ end;
+ Val.Free;
+ Val := Call;
+ end else begin
+ Call := TPSValueProcNo.Create;
+ Call.ResultType := AT2UT(FindBaseType(btVariant));
+ Call.SetParserPos(FParser);
+ Call.ProcNo := FindProc('!NOTIFICATIONVARIANTGET');
+ Call.SetParserPos(FParser);
+ Call.Parameters := TPSParameters.Create;
+ Tmp := TPSValueData.Create;
+ TPSVAlueData(tmp).Data := NewVariant(at2ut(FindBaseType(btString)));
+ tbtString(TPSValueData(tmp).Data.tstring) := TPSVar(FVars[TPSValueGlobalVar(Val).GlobalVarNo]).OrgName;
+ with call.Parameters.Add do
+ begin
+ Val := tmp;
+ ExpectedType := TPSValueData(tmp).Data.FType;
+ end;
+ Val.Free;
+ Val := Call;
+ end;
+ end;
+
+
+ function GetIdentifier(const FType: Byte): TPSValue;
+ {
+ FType:
+ 0 = Anything
+ 1 = Only variables
+ 2 = Not constants
+ }
+
+ procedure CheckProcCall(var x: TPSValue);
+ var
+ aType: TPSType;
+ begin
+ if FParser.CurrTokenId in [CSTI_Dereference, CSTI_OpenRound] then
+ begin
+ aType := GetTypeNo(BlockInfo, x);
+ if (aType = nil) or (aType.BaseType <> btProcPtr) then
+ begin
+ MakeError('', ecTypeMismatch, '');
+ x.Free;
+ x := nil;
+ Exit;
+ end;
+ if FParser.CurrTokenId = CSTI_Dereference then
+ FParser.Next;
+ x := ReadVarParameters(x);
+ end;
+ end;
+
+ procedure CheckFurther(var x: TPSValue; ImplicitPeriod: Boolean);
+ var
+ t: Cardinal;
+ rr: TPSSubItem;
+ L: Longint;
+ u: TPSType;
+ Param: TPSParameter;
+ tmp, tmpn: TPSValue;
+ tmp3: TPSValueProcNo;
+ tmp2: Boolean;
+
+ function FindSubR(const n: tbtString; FType: TPSType): Cardinal;
+ var
+ h, I: Longint;
+ rvv: PIFPSRecordFieldTypeDef;
+ begin
+ h := MakeHash(n);
+ for I := 0 to TPSRecordType(FType).RecValCount - 1 do
+ begin
+ rvv := TPSRecordType(FType).RecVal(I);
+ if (rvv.FieldNameHash = h) and (rvv.FieldName = n) then
+ begin
+ Result := I;
+ exit;
+ end;
+ end;
+ Result := InvalidVal;
+ end;
+
+ begin
+(* if not (x is TPSValueVar) then
+ Exit;*)
+ u := GetTypeNo(BlockInfo, x);
+ if u = nil then exit;
+ while True do
+ begin
+ if (u.BaseType = btClass) {$IFNDEF PS_NOINTERFACES}or (u.BaseType = btInterface){$ENDIF}
+ {$IFNDEF PS_NOIDISPATCH}or ((u.BaseType = btVariant) or (u.BaseType = btNotificationVariant)){$ENDIF} or (u.BaseType = btExtClass) then exit;
+ if FParser.CurrTokenId = CSTI_OpenBlock then
+ begin
+ if (u.BaseType = btString) {$IFNDEF PS_NOWIDESTRING} or (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) {$ENDIF} then
+ begin
+ FParser.Next;
+ tmp := Calc(CSTI_CloseBlock);
+ if tmp = nil then
+ begin
+ x.Free;
+ x := nil;
+ exit;
+ end;
+ if not IsIntType(GetTypeNo(BlockInfo, tmp).BaseType) then
+ begin
+ MakeError('', ecTypeMismatch, '');
+ tmp.Free;
+ x.Free;
+ x := nil;
+ exit;
+ end;
+ FParser.Next;
+ if FParser.CurrTokenId = CSTI_Assignment then
+ begin
+ if not (x is TPSValueVar) then begin
+ MakeError('', ecVariableExpected, '');
+ tmp.Free;
+ x.Free;
+ x := nil;
+ exit;
+ end;
+ {$IFNDEF PS_NOWIDESTRING}
+ if (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) then
+ l := FindProc('WSTRSET')
+ else
+ {$ENDIF}
+ l := FindProc('STRSET');
+ if l = -1 then
+ begin
+ MakeError('', ecUnknownIdentifier, 'StrSet');
+ tmp.Free;
+ x.Free;
+ x := nil;
+ exit;
+ end;
+ tmp3 := TPSValueProcNo.Create;
+ tmp3.ResultType := nil;
+ tmp3.SetParserPos(FParser);
+ tmp3.ProcNo := L;
+ tmp3.SetParserPos(FParser);
+ tmp3.Parameters := TPSParameters.Create;
+ param := tmp3.Parameters.Add;
+ with tmp3.Parameters.Add do
+ begin
+ Val := tmp;
+ ExpectedType := GetTypeNo(BlockInfo, tmp);
+{$IFDEF DEBUG}
+ if not ExpectedType.Used then asm int 3; end;
+{$ENDIF}
+ end;
+ with tmp3.Parameters.Add do
+ begin
+ Val := x;
+ ExpectedType := GetTypeNo(BlockInfo, x);
+{$IFDEF DEBUG}
+ if not ExpectedType.Used then asm int 3; end;
+{$ENDIF}
+ ParamMode := pmInOut;
+ end;
+ x := tmp3;
+ FParser.Next;
+ tmp := Calc(CSTI_SemiColon);
+ if tmp = nil then
+ begin
+ x.Free;
+ x := nil;
+ exit;
+ end;
+ if (GetTypeNo(BlockInfo, Tmp).BaseType <> btChar)
+ {$IFNDEF PS_NOWIDESTRING} and (GetTypeno(BlockInfo, Tmp).BaseType <> btWideChar) {$ENDIF} then
+ begin
+ x.Free;
+ x := nil;
+ Tmp.Free;
+ MakeError('', ecTypeMismatch, '');
+ exit;
+
+ end;
+ param.Val := tmp;
+ Param.ExpectedType := GetTypeNo(BlockInfo, tmp);
+{$IFDEF DEBUG}
+ if not Param.ExpectedType.Used then asm int 3; end;
+{$ENDIF}
+ end else begin
+ {$IFNDEF PS_NOWIDESTRING}
+ if (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) then
+ l := FindProc('WSTRGET')
+ else
+ {$ENDIF}
+ l := FindProc('STRGET');
+ if l = -1 then
+ begin
+ MakeError('', ecUnknownIdentifier, 'StrGet');
+ tmp.Free;
+ x.Free;
+ x := nil;
+ exit;
+ end;
+ tmp3 := TPSValueProcNo.Create;
+ {$IFNDEF PS_NOWIDESTRING}
+ if (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) then
+ tmp3.ResultType := FindBaseType(btWideChar)
+ else
+ {$ENDIF}
+ tmp3.ResultType := FindBaseType(btChar);
+ tmp3.ProcNo := L;
+ tmp3.SetParserPos(FParser);
+ tmp3.Parameters := TPSParameters.Create;
+ with tmp3.Parameters.Add do
+ begin
+ Val := x;
+ ExpectedType := GetTypeNo(BlockInfo, x);
+{$IFDEF DEBUG}
+ if not ExpectedType.Used then asm int 3; end;
+{$ENDIF}
+
+ if x is TPSValueVar then
+ ParamMode := pmInOut
+ else
+ parammode := pmIn;
+ end;
+ with tmp3.Parameters.Add do
+ begin
+ Val := tmp;
+ ExpectedType := GetTypeNo(BlockInfo, tmp);
+{$IFDEF DEBUG}
+ if not ExpectedType.Used then asm int 3; end;
+{$ENDIF}
+ end;
+ x := tmp3;
+ end;
+ Break;
+ end else if ((u.BaseType = btArray) or (u.BaseType = btStaticArray)) and (x is TPSValueVar) then
+ begin
+ FParser.Next;
+ tmp := calc(CSTI_CloseBlock);
+ if tmp = nil then
+ begin
+ x.Free;
+ x := nil;
+ exit;
+ end;
+ if not IsIntType(GetTypeNo(BlockInfo, tmp).BaseType) then
+ begin
+ MakeError('', ecTypeMismatch, '');
+ tmp.Free;
+ x.Free;
+ x := nil;
+ exit;
+ end;
+ if (tmp.ClassType = TPSValueData) then
+ begin
+ rr := TPSSubNumber.Create;
+ TPSValueVar(x).RecAdd(rr);
+ if (u.BaseType = btStaticArray) then
+ TPSSubNumber(rr).SubNo := Cardinal(GetInt(TPSValueData(tmp).Data, tmp2) - TPSStaticArrayType(u).StartOffset)
+ else
+ TPSSubNumber(rr).SubNo := GetUInt(TPSValueData(tmp).Data, tmp2);
+ tmp.Free;
+ rr.aType := TPSArrayType(u).ArrayTypeNo;
+ u := rr.aType;
+ end
+ else
+ begin
+ if (u.BaseType = btStaticArray) then
+ begin
+ tmpn := TPSBinValueOp.Create;
+ TPSBinValueOp(tmpn).Operator := otSub;
+ TPSBinValueOp(tmpn).Val1 := tmp;
+ tmp := TPSValueData.Create;
+ TPSValueData(tmp).Data := NewVariant(FindBaseType(btS32));
+ TPSValueData(tmp).Data.ts32 := TPSStaticArrayType(u).StartOffset;
+ TPSBinValueOp(tmpn).Val2 := tmp;
+ TPSBinValueOp(tmpn).aType := FindBaseType(btS32);
+ tmp := tmpn;
+ end;
+ rr := TPSSubValue.Create;
+ TPSValueVar(x).recAdd(rr);
+ TPSSubValue(rr).SubNo := tmp;
+ rr.aType := TPSArrayType(u).ArrayTypeNo;
+ u := rr.aType;
+ end;
+ if FParser.CurrTokenId <> CSTI_CloseBlock then
+ begin
+ MakeError('', ecCloseBlockExpected, '');
+ x.Free;
+ x := nil;
+ exit;
+ end;
+ Fparser.Next;
+ end else begin
+ MakeError('', ecSemicolonExpected, '');
+ x.Free;
+ x := nil;
+ exit;
+ end;
+ end
+ else if (FParser.CurrTokenId = CSTI_Period) or (ImplicitPeriod) then
+ begin
+ if not ImplicitPeriod then
+ FParser.Next;
+ if u.BaseType = btRecord then
+ begin
+ t := FindSubR(FParser.GetToken, u);
+ if t = InvalidVal then
+ begin
+ if ImplicitPeriod then exit;
+ MakeError('', ecUnknownIdentifier, FParser.GetToken);
+ x.Free;
+ x := nil;
+ exit;
+ end;
+ if (x is TPSValueProcNo) then
+ begin
+ ImplicitPeriod := False;
+ FParser.Next;
+
+ tmp := AllocStackReg(u);
+ WriteCalculation(x,tmp);
+ TPSVar(BlockInfo.Proc.FProcVars[TPSValueAllocatedStackVar(tmp).LocalVarNo]).Use;
+
+ rr := TPSSubNumber.Create;
+ TPSValueVar(tmp).RecAdd(rr);
+ TPSSubNumber(rr).SubNo := t;
+ rr.aType := TPSRecordType(u).RecVal(t).FType;
+ u := rr.aType;
+
+ tmpn := TPSValueReplace.Create;
+ with TPSValueReplace(tmpn) do
+ begin
+ FreeOldValue := true;
+ FreeNewValue := true;
+ OldValue := tmp;
+ NewValue := AllocStackReg(u);
+ PreWriteAllocated := true;
+ end;
+
+ if not WriteCalculation(tmp,TPSValueReplace(tmpn).NewValue) then
+ begin
+ {MakeError('',ecInternalError,'');}
+ x.Free;
+ x := nil;
+ exit;
+ end;
+ x.Free;
+ x := tmpn;
+ end else
+ begin
+ if not (x is TPSValueVar) then begin
+ MakeError('', ecVariableExpected, FParser.GetToken);
+ x.Free;
+ x := nil;
+ exit;
+ end;
+ ImplicitPeriod := False;
+ FParser.Next;
+ rr := TPSSubNumber.Create;
+ TPSValueVar(x).RecAdd(rr);
+ TPSSubNumber(rr).SubNo := t;
+ rr.aType := TPSRecordType(u).RecVal(t).FType;
+ u := rr.aType;
+ end;
+ end
+ else
+ begin
+ x.Free;
+ MakeError('', ecSemicolonExpected, '');
+ x := nil;
+ exit;
+ end;
+ end
+ else
+ break;
+ end;
+ end;
+
+
+
+ procedure CheckClassArrayProperty(var P: TPSValue; const VarType: TPSVariableType; VarNo: Cardinal);
+ var
+ Tempp: TPSValue;
+ aType: TPSClassType;
+ procno: Cardinal;
+ Idx: IPointer;
+ Decl: TPSParametersDecl;
+ begin
+ if p = nil then exit;
+ if (GetTypeNo(BlockInfo, p) = nil) or (GetTypeNo(BlockInfo, p).BaseType <> btClass) then exit;
+ aType := TPSClassType(GetTypeNo(BlockInfo, p));
+ if FParser.CurrTokenID = CSTI_OpenBlock then
+ begin
+ if not TPSClassType(aType).Cl.Property_Find('', Idx) then
+ begin
+ MakeError('', ecPeriodExpected, '');
+ p.Free;
+ p := nil;
+ exit;
+ end;
+ if VarNo <> InvalidVal then
+ begin
+ if @FOnUseVariable <> nil then
+ FOnUseVariable(Self, VarType, VarNo, BlockInfo.ProcNo, FParser.CurrTokenPos, '[Default]');
+ end;
+ Decl := TPSParametersDecl.Create;
+ TPSClassType(aType).Cl.Property_GetHeader(Idx, Decl);
+ tempp := p;
+ P := TPSValueProcNo.Create;
+ with TPSValueProcNo(P) do
+ begin
+ Parameters := TPSParameters.Create;
+ Parameters.Add;
+ end;
+ if not (ReadParameters(True, TPSValueProc(P).Parameters) and
+ ValidateParameters(BlockInfo, TPSValueProc(P).Parameters, Decl)) then
+ begin
+ tempp.Free;
+ Decl.Free;
+ p.Free;
+ p := nil;
+ exit;
+ end;
+ with TPSValueProcNo(p).Parameters[0] do
+ begin
+ Val := tempp;
+ ExpectedType := GetTypeNo(BlockInfo, tempp);
+ end;
+ if FParser.CurrTokenId = CSTI_Assignment then
+ begin
+ FParser.Next;
+ TempP := Calc(CSTI_SemiColon);
+ if TempP = nil then
+ begin
+ Decl.Free;
+ P.Free;
+ p := nil;
+ exit;
+ end;
+ with TPSValueProc(p).Parameters.Add do
+ begin
+ Val := Tempp;
+ ExpectedType := at2ut(Decl.Result);
+ end;
+ if not TPSClassType(aType).Cl.Property_Set(Idx, procno) then
+ begin
+ Decl.Free;
+ MakeError('', ecReadOnlyProperty, '');
+ p.Free;
+ p := nil;
+ exit;
+ end;
+ TPSValueProcNo(p).ProcNo := procno;
+ TPSValueProcNo(p).ResultType := nil;
+ end
+ else
+ begin
+ if not TPSClassType(aType).Cl.Property_Get(Idx, procno) then
+ begin
+ Decl.Free;
+ MakeError('', ecWriteOnlyProperty, '');
+ p.Free;
+ p := nil;
+ exit;
+ end;
+ TPSValueProcNo(p).ProcNo := procno;
+ TPSValueProcNo(p).ResultType := TPSExternalProcedure(FProcs[procno]).RegProc.Decl.Result;
+ end; // if FParser.CurrTokenId = CSTI_Assign
+ Decl.Free;
+ end;
+ end;
+
+ procedure CheckExtClass(var P: TPSValue; const VarType: TPSVariableType; VarNo: Cardinal; ImplicitPeriod: Boolean);
+ var
+ Temp, Idx: Cardinal;
+ FType: TPSType;
+ s: tbtString;
+
+ begin
+ FType := GetTypeNo(BlockInfo, p);
+ if FType = nil then Exit;
+ if FType.BaseType <> btExtClass then Exit;
+ while (FParser.CurrTokenID = CSTI_Period) or (ImplicitPeriod) do
+ begin
+ if not ImplicitPeriod then
+ FParser.Next;
+ if FParser.CurrTokenID <> CSTI_Identifier then
+ begin
+ if ImplicitPeriod then exit;
+ MakeError('', ecIdentifierExpected, '');
+ p.Free;
+ P := nil;
+ Exit;
+ end;
+ s := FParser.GetToken;
+ if TPSUndefinedClassType(FType).ExtClass.Func_Find(s, Idx) then
+ begin
+ FParser.Next;
+ TPSUndefinedClassType(FType).ExtClass.Func_Call(Idx, Temp);
+ P := ReadProcParameters(Temp, P);
+ if p = nil then
+ begin
+ Exit;
+ end;
+ end else
+ begin
+ if ImplicitPeriod then exit;
+ MakeError('', ecUnknownIdentifier, s);
+ p.Free;
+ P := nil;
+ Exit;
+ end;
+ ImplicitPeriod := False;
+ FType := GetTypeNo(BlockInfo, p);
+ if (FType = nil) or (FType.BaseType <> btExtClass) then Exit;
+ end; {while}
+ end;
+
+ procedure CheckClass(var P: TPSValue; const VarType: TPSVariableType; VarNo: Cardinal; ImplicitPeriod: Boolean);
+ var
+ Procno: Cardinal;
+ Idx: IPointer;
+ FType: TPSType;
+ TempP: TPSValue;
+ Decl: TPSParametersDecl;
+ s: tbtString;
+
+ pinfo, pinfonew: tbtString;
+ ppos: Cardinal;
+
+ begin
+ FType := GetTypeNo(BlockInfo, p);
+ if FType = nil then exit;
+ pinfo := '';
+ if (FType.BaseType <> btClass) then Exit;
+ while (FParser.CurrTokenID = CSTI_Period) or (ImplicitPeriod) do
+ begin
+ if not ImplicitPeriod then
+ FParser.Next;
+ if FParser.CurrTokenID <> CSTI_Identifier then
+ begin
+ if ImplicitPeriod then exit;
+ MakeError('', ecIdentifierExpected, '');
+ p.Free;
+ P := nil;
+ Exit;
+ end;
+ s := FParser.GetToken;
+ if TPSClassType(FType).Cl.Func_Find(s, Idx) then
+ begin
+ FParser.Next;
+ VarNo := InvalidVal;
+ TPSClassType(FType).cl.Func_Call(Idx, Procno);
+ P := ReadProcParameters(Procno, P);
+ if p = nil then
+ begin
+ Exit;
+ end;
+ end else if TPSClassType(FType).cl.Property_Find(s, Idx) then
+ begin
+ ppos := FParser.CurrTokenPos;
+ pinfonew := FParser.OriginalToken;
+ FParser.Next;
+ if VarNo <> InvalidVal then
+ begin
+ if pinfo = '' then
+ pinfo := pinfonew
+ else
+ pinfo := pinfo + '.' + pinfonew;
+ if @FOnUseVariable <> nil then
+ FOnUseVariable(Self, VarType, VarNo, BlockInfo.ProcNo, ppos, pinfo);
+ end;
+ Decl := TPSParametersDecl.Create;
+ TPSClassType(FType).cl.Property_GetHeader(Idx, Decl);
+ TempP := P;
+ p := TPSValueProcNo.Create;
+ with TPSValueProcNo(p) do
+ begin
+ Parameters := TPSParameters.Create;
+ Parameters.Add;
+ Pos := FParser.CurrTokenPos;
+ row := FParser.Row;
+ Col := FParser.Col;
+ end;
+ if Decl.ParamCount <> 0 then
+ begin
+ if not (ReadParameters(True, TPSValueProc(P).Parameters) and
+ ValidateParameters(BlockInfo, TPSValueProc(P).Parameters, Decl)) then
+ begin
+ Tempp.Free;
+ Decl.Free;
+ p.Free;
+ P := nil;
+ exit;
+ end;
+ end; // if
+ with TPSValueProcNo(p).Parameters[0] do
+ begin
+ Val := TempP;
+ ExpectedType := at2ut(GetTypeNo(BlockInfo, TempP));
+ end;
+ if FParser.CurrTokenId = CSTI_Assignment then
+ begin
+ FParser.Next;
+ TempP := Calc(CSTI_SemiColon);
+ if TempP = nil then
+ begin
+ Decl.Free;
+ P.Free;
+ p := nil;
+ exit;
+ end;
+ with TPSValueProc(p).Parameters.Add do
+ begin
+ Val := Tempp;
+ ExpectedType := at2ut(Decl.Result);
+{$IFDEF DEBUG}
+ if not ExpectedType.Used then asm int 3; end;
+{$ENDIF}
+ end;
+
+ if not TPSClassType(FType).cl.Property_Set(Idx, Procno) then
+ begin
+ MakeError('', ecReadOnlyProperty, '');
+ Decl.Free;
+ p.Free;
+ p := nil;
+ exit;
+ end;
+ TPSValueProcNo(p).ProcNo := Procno;
+ TPSValueProcNo(p).ResultType := nil;
+ Decl.Free;
+ Exit;
+ end else begin
+ if not TPSClassType(FType).cl.Property_Get(Idx, Procno) then
+ begin
+ MakeError('', ecWriteOnlyProperty, '');
+ Decl.Free;
+ p.Free;
+ p := nil;
+ exit;
+ end;
+ TPSValueProcNo(p).ProcNo := ProcNo;
+ TPSValueProcNo(p).ResultType := TPSExternalProcedure(FProcs[ProcNo]).RegProc.Decl.Result;
+ end; // if FParser.CurrTokenId = CSTI_Assign
+ Decl.Free;
+ end else
+ begin
+ if ImplicitPeriod then exit;
+ MakeError('', ecUnknownIdentifier, s);
+ p.Free;
+ P := nil;
+ Exit;
+ end;
+ ImplicitPeriod := False;
+ FType := GetTypeNo(BlockInfo, p);
+ if (FType = nil) or (FType.BaseType <> btClass) then Exit;
+ end; {while}
+ end;
+{$IFNDEF PS_NOIDISPATCH}
+ procedure CheckIntf(var P: TPSValue; const VarType: TPSVariableType; VarNo: Cardinal; ImplicitPeriod: Boolean);
+ var
+ Procno, Idx: Cardinal;
+ FType: TPSType;
+ s: tbtString;
+
+ CheckArrayProperty,HasArrayProperty:boolean;
+ begin
+ FType := GetTypeNo(BlockInfo, p);
+ if FType = nil then exit;
+ if (FType.BaseType <> btInterface) and (Ftype.BaseType <> BtVariant) and (FType.BaseType = btNotificationVariant) then Exit;
+
+ CheckArrayProperty:=(FParser.CurrTokenID=CSTI_OpenBlock)and
+ (Ftype.BaseType = BtVariant);
+ while (FParser.CurrTokenID = CSTI_Period)
+ or (ImplicitPeriod)or (CheckArrayProperty) do begin
+
+ HasArrayProperty:=CheckArrayProperty;
+ if CheckArrayProperty then begin
+ CheckArrayProperty:=false;
+ end else begin
+ if not ImplicitPeriod then
+ FParser.Next;
+ end;
+ if FParser.CurrTokenID <> CSTI_Identifier then
+ begin
+ if ImplicitPeriod then exit;
+ if not HasArrayProperty then begin
+ MakeError('', ecIdentifierExpected, '');
+ p.Free;
+ P := nil;
+ Exit;
+ end;
+ end;
+ if (FType.BaseType = btVariant) or (FType.BaseType = btNotificationVariant) then
+ begin
+ if HasArrayProperty then begin
+ s:='';
+ end else begin
+ s := FParser.OriginalToken;
+ FParser.Next;
+ end;
+ ImplicitPeriod := False;
+ FType := GetTypeNo(BlockInfo, p);
+ p := ReadIDispatchParameters(s, TPSVariantType(FType), p);
+ if (FType = nil) or (FType.BaseType <> btInterface) then Exit;
+ end else
+ begin
+ s := FParser.GetToken;
+ if (FType is TPSInterfaceType) and (TPSInterfaceType(FType).Intf.Func_Find(s, Idx)) then
+ begin
+ FParser.Next;
+ TPSInterfaceType(FType).Intf.Func_Call(Idx, Procno);
+ P := ReadProcParameters(Procno, P);
+ if p = nil then
+ begin
+ Exit;
+ end;
+ end else
+ begin
+ if ImplicitPeriod then exit;
+ MakeError('', ecUnknownIdentifier, s);
+ p.Free;
+ P := nil;
+ Exit;
+ end;
+ ImplicitPeriod := False;
+ FType := GetTypeNo(BlockInfo, p);
+ if (FType = nil) or ((FType.BaseType <> btInterface) and (Ftype.BaseType <> btVariant) and (Ftype.BaseType <> btNotificationVariant)) then Exit;
+ end;
+ end; {while}
+ end;
+ {$ENDIF}
+ function ExtCheckClassType(FType: TPSType; const ParserPos: Cardinal): TPSValue;
+ var
+ FType2: TPSType;
+ ProcNo, Idx: Cardinal;
+ Temp, ResV: TPSValue;
+ begin
+ if FParser.CurrTokenID = CSTI_OpenRound then
+ begin
+ FParser.Next;
+ Temp := Calc(CSTI_CloseRound);
+ if Temp = nil then
+ begin
+ Result := nil;
+ exit;
+ end;
+ if FParser.CurrTokenID <> CSTI_CloseRound then
+ begin
+ temp.Free;
+ MakeError('', ecCloseRoundExpected, '');
+ Result := nil;
+ exit;
+ end;
+ FType2 := GetTypeNo(BlockInfo, Temp);
+ if (FType.basetype = BtClass) and (ftype2.BaseType = btClass) and (ftype <> ftype2) then
+ begin
+ if not TPSUndefinedClassType(FType2).ExtClass.CastToType(AT2UT(FType), ProcNo) then
+ begin
+ temp.Free;
+ MakeError('', ecTypeMismatch, '');
+ Result := nil;
+ exit;
+ end;
+ Result := TPSValueProcNo.Create;
+ TPSValueProcNo(Result).Parameters := TPSParameters.Create;
+ TPSValueProcNo(Result).ResultType := at2ut(FType);
+ TPSValueProcNo(Result).ProcNo := ProcNo;
+ with TPSValueProcNo(Result).Parameters.Add do
+ begin
+ Val := Temp;
+ ExpectedType := GetTypeNo(BlockInfo, temp);
+ end;
+ with TPSValueProcNo(Result).Parameters.Add do
+ begin
+ ExpectedType := at2ut(FindBaseType(btu32));
+ Val := TPSValueData.Create;
+ with TPSValueData(val) do
+ begin
+ SetParserPos(FParser);
+ Data := NewVariant(ExpectedType);
+ Data.tu32 := at2ut(FType).FinalTypeNo;
+ end;
+ end;
+ FParser.Next;
+ Exit;
+ end;
+ if not IsCompatibleType(FType, FType2, True) then
+ begin
+ temp.Free;
+ MakeError('', ecTypeMismatch, '');
+ Result := nil;
+ exit;
+ end;
+ FParser.Next;
+ Result := TPSUnValueOp.Create;
+ with TPSUnValueOp(Result) do
+ begin
+ Operator := otCast;
+ Val1 := Temp;
+ SetParserPos(FParser);
+ aType := AT2UT(FType);
+ end;
+ exit;
+ end;
+ if FParser.CurrTokenId <> CSTI_Period then
+ begin
+ Result := nil;
+ MakeError('', ecPeriodExpected, '');
+ Exit;
+ end;
+ if FType.BaseType <> btExtClass then
+ begin
+ Result := nil;
+ MakeError('', ecClassTypeExpected, '');
+ Exit;
+ end;
+ FParser.Next;
+ if not TPSUndefinedClassType(FType).ExtClass.ClassFunc_Find(FParser.GetToken, Idx) then
+ begin
+ Result := nil;
+ MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
+ Exit;
+ end;
+ FParser.Next;
+ TPSUndefinedClassType(FType).ExtClass.ClassFunc_Call(Idx, ProcNo);
+ Temp := TPSValueData.Create;
+ with TPSValueData(Temp) do
+ begin
+ Data := NewVariant(at2ut(FindBaseType(btu32)));
+ Data.tu32 := at2ut(FType).FinalTypeNo;
+ end;
+ ResV := ReadProcParameters(ProcNo, Temp);
+ if ResV <> nil then
+ begin
+ TPSValueProc(Resv).ResultType := at2ut(FType);
+ Result := Resv;
+ end else begin
+ Result := nil;
+ end;
+ end;
+
+ function CheckClassType(TypeNo: TPSType; const ParserPos: Cardinal): TPSValue;
+ var
+ FType2: TPSType;
+ ProcNo: Cardinal;
+ Idx: IPointer;
+ Temp, ResV: TPSValue;
+ dta: PIfRVariant;
+ begin
+ if typeno.BaseType = btExtClass then
+ begin
+ Result := ExtCheckClassType(TypeNo, PArserPos);
+ exit;
+ end;
+ if FParser.CurrTokenID = CSTI_OpenRound then
+ begin
+ FParser.Next;
+ Temp := Calc(CSTI_CloseRound);
+ if Temp = nil then
+ begin
+ Result := nil;
+ exit;
+ end;
+ if FParser.CurrTokenID <> CSTI_CloseRound then
+ begin
+ temp.Free;
+ MakeError('', ecCloseRoundExpected, '');
+ Result := nil;
+ exit;
+ end;
+ FType2 := GetTypeNo(BlockInfo, Temp);
+ if ((typeno.BaseType = btClass){$IFNDEF PS_NOINTERFACES} or (TypeNo.basetype = btInterface){$ENDIF}) and
+ ((ftype2.BaseType = btClass){$IFNDEF PS_NOINTERFACES} or (ftype2.BaseType = btInterface){$ENDIF}) and (TypeNo <> ftype2) then
+ begin
+{$IFNDEF PS_NOINTERFACES}
+ if FType2.basetype = btClass then
+ begin
+{$ENDIF}
+ if not TPSClassType(FType2).Cl.CastToType(AT2UT(TypeNo), ProcNo) then
+ begin
+ temp.Free;
+ MakeError('', ecTypeMismatch, '');
+ Result := nil;
+ exit;
+ end;
+{$IFNDEF PS_NOINTERFACES}
+ end else begin
+ if not TPSInterfaceType(FType2).Intf.CastToType(AT2UT(TypeNo), ProcNo) then
+ begin
+ temp.Free;
+ MakeError('', ecTypeMismatch, '');
+ Result := nil;
+ exit;
+ end;
+ end;
+{$ENDIF}
+ Result := TPSValueProcNo.Create;
+ TPSValueProcNo(Result).Parameters := TPSParameters.Create;
+ TPSValueProcNo(Result).ResultType := at2ut(TypeNo);
+ TPSValueProcNo(Result).ProcNo := ProcNo;
+ with TPSValueProcNo(Result).Parameters.Add do
+ begin
+ Val := Temp;
+ ExpectedType := GetTypeNo(BlockInfo, temp);
+{$IFDEF DEBUG}
+ if not ExpectedType.Used then asm int 3; end;
+{$ENDIF}
+ end;
+ with TPSValueProcNo(Result).Parameters.Add do
+ begin
+ ExpectedType := at2ut(FindBaseType(btu32));
+{$IFDEF DEBUG}
+ if not ExpectedType.Used then asm int 3; end;
+{$ENDIF}
+ Val := TPSValueData.Create;
+ with TPSValueData(val) do
+ begin
+ SetParserPos(FParser);
+ Data := NewVariant(ExpectedType);
+ Data.tu32 := at2ut(TypeNo).FinalTypeNo;
+ end;
+ end;
+ FParser.Next;
+ Exit;
+ end;
+ if not IsCompatibleType(TypeNo, FType2, True) then
+ begin
+ temp.Free;
+ MakeError('', ecTypeMismatch, '');
+ Result := nil;
+ exit;
+ end;
+ FParser.Next;
+ Result := TPSUnValueOp.Create;
+ with TPSUnValueOp(Result) do
+ begin
+ Operator := otCast;
+ Val1 := Temp;
+ SetParserPos(FParser);
+ aType := AT2UT(TypeNo);
+ end;
+
+ exit;
+ end else
+ if FParser.CurrTokenId <> CSTI_Period then
+ begin
+ Result := TPSValueData.Create;
+ Result.SetParserPos(FParser);
+ New(dta);
+ TPSValueData(Result).Data := dta;
+ InitializeVariant(dta, at2ut(FindBaseType(btType)));
+ dta.ttype := at2ut(TypeNo);
+ Exit;
+ end;
+ if TypeNo.BaseType <> btClass then
+ begin
+ Result := nil;
+ MakeError('', ecClassTypeExpected, '');
+ Exit;
+ end;
+ FParser.Next;
+ if not TPSClassType(TypeNo).Cl.ClassFunc_Find(FParser.GetToken, Idx) then
+ begin
+ Result := nil;
+ MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
+ Exit;
+ end;
+ FParser.Next;
+ TPSClassType(TypeNo).Cl.ClassFunc_Call(Idx, ProcNo);
+ Temp := TPSValueData.Create;
+ with TPSValueData(Temp) do
+ begin
+ Data := NewVariant(at2ut(FindBaseType(btu32)));
+ Data.tu32 := at2ut(TypeNo).FinalTypeNo;
+ end;
+ ResV := ReadProcParameters(ProcNo, Temp);
+ if ResV <> nil then
+ begin
+ TPSValueProc(Resv).ResultType := at2ut(TypeNo);
+ Result := Resv;
+ end else begin
+ Result := nil;
+ end;
+ end;
+
+ var
+ vt: TPSVariableType;
+ vno: Cardinal;
+ TWith, Temp: TPSValue;
+ l, h: Longint;
+ s, u: tbtString;
+ t: TPSConstant;
+ Temp1: TPSType;
+ temp2: CArdinal;
+ bi: TPSBlockInfo;
+ lOldRecCount: Integer;
+
+ begin
+ s := FParser.GetToken;
+
+ if FType <> 1 then
+ begin
+ bi := BlockInfo;
+ while bi <> nil do
+ begin
+ for l := bi.WithList.Count -1 downto 0 do
+ begin
+ TWith := TPSValueAllocatedStackVar.Create;
+ TPSValueAllocatedStackVar(TWith).LocalVarNo := TPSValueAllocatedStackVar(TPSValueReplace(bi.WithList[l]).NewValue).LocalVarNo;
+ Temp := TWith;
+ VNo := TPSValueAllocatedStackVar(Temp).LocalVarNo;
+ lOldRecCount := TPSValueVar(TWith).GetRecCount;
+ vt := ivtVariable;
+ if Temp = TWith then CheckFurther(TWith, True);
+ if Temp = TWith then CheckClass(TWith, vt, vno, True);
+ if Temp = TWith then CheckExtClass(TWith, vt, vno, True);
+ if (Temp <> TWith) or (Cardinal(lOldRecCount) <> TPSValueVar(TWith).GetRecCount) then
+ begin
+ repeat
+ Temp := TWith;
+ if TWith <> nil then CheckFurther(TWith, False);
+ if TWith <> nil then CheckClass(TWith, vt, vno, False);
+ if TWith <> nil then CheckExtClass(TWith, vt, vno, False);
+{$IFNDEF PS_NOIDISPATCH}if TWith <> nil then CheckIntf(TWith, vt, vno, False);{$ENDIF}
+ if TWith <> nil then CheckProcCall(TWith);
+ if TWith <> nil then CheckClassArrayProperty(TWith, vt, vno);
+ vno := InvalidVal;
+ until (TWith = nil) or (Temp = TWith);
+ Result := TWith;
+ Exit;
+ end;
+ TWith.Free;
+ end;
+ bi := bi.FOwner;
+ end;
+ end;
+
+ if s = 'RESULT' then
+ begin
+ if BlockInfo.proc.Decl.Result = nil then
+ begin
+ Result := nil;
+ MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
+ end
+ else
+ begin
+ BlockInfo.Proc.ResultUse;
+ Result := TPSValueParamVar.Create;
+ with TPSValueParamVar(Result) do
+ begin
+ SetParserPos(FParser);
+ ParamNo := 0;
+ end;
+ vno := 0;
+ vt := ivtParam;
+ if @FOnUseVariable <> nil then
+ FOnUseVariable(Self, vt, vno, BlockInfo.ProcNo, FParser.CurrTokenPos, '');
+ FParser.Next;
+ repeat
+ Temp := Result;
+ if Result <> nil then CheckFurther(Result, False);
+ if Result <> nil then CheckClass(Result, vt, vno, False);
+ if Result <> nil then CheckExtClass(Result, vt, vno, False);
+{$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF}
+ if Result <> nil then CheckProcCall(Result);
+ if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
+ vno := InvalidVal;
+ until (Result = nil) or (Temp = Result);
+ end;
+ exit;
+ end;
+ if BlockInfo.Proc.Decl.Result = nil then
+ l := 0
+ else
+ l := 1;
+ for h := 0 to BlockInfo.proc.Decl.ParamCount -1 do
+ begin
+ if BlockInfo.proc.Decl.Params[h].Name = s then
+ begin
+ Result := TPSValueParamVar.Create;
+ with TPSValueParamVar(Result) do
+ begin
+ SetParserPos(FParser);
+ ParamNo := l;
+ end;
+ vt := ivtParam;
+ vno := L;
+ if @FOnUseVariable <> nil then
+ FOnUseVariable(Self, vt, vno, BlockInfo.ProcNo, FParser.CurrTokenPos, '');
+ FParser.Next;
+ repeat
+ Temp := Result;
+ if Result <> nil then CheckFurther(Result, False);
+ if Result <> nil then CheckClass(Result, vt, vno, False);
+ if Result <> nil then CheckExtClass(Result, vt, vno, False);
+{$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF}
+ if Result <> nil then CheckProcCall(Result);
+ if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
+ vno := InvalidVal;
+ until (Result = nil) or (Temp = Result);
+ exit;
+ end;
+ Inc(l);
+ GRFW(u);
+ end;
+
+ h := MakeHash(s);
+
+ for l := 0 to BlockInfo.Proc.ProcVars.Count - 1 do
+ begin
+ if (PIFPSProcVar(BlockInfo.Proc.ProcVars[l]).NameHash = h) and
+ (PIFPSProcVar(BlockInfo.Proc.ProcVars[l]).Name = s) then
+ begin
+ PIFPSProcVar(BlockInfo.Proc.ProcVars[l]).Use;
+ vno := l;
+ vt := ivtVariable;
+ if @FOnUseVariable <> nil then
+ FOnUseVariable(Self, vt, vno, BlockInfo.ProcNo, FParser.CurrTokenPos, '');
+ Result := TPSValueLocalVar.Create;
+ with TPSValueLocalVar(Result) do
+ begin
+ LocalVarNo := l;
+ SetParserPos(FParser);
+ end;
+ FParser.Next;
+ repeat
+ Temp := Result;
+ if Result <> nil then CheckFurther(Result, False);
+ if Result <> nil then CheckClass(Result, vt, vno, False);
+ if Result <> nil then CheckExtClass(Result, vt, vno, False);
+{$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF}
+ if Result <> nil then CheckProcCall(Result);
+ if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
+ vno := InvalidVal;
+ until (Result = nil) or (Temp = Result);
+
+ exit;
+ end;
+ end;
+
+ for l := 0 to FVars.Count - 1 do
+ begin
+ if (TPSVar(FVars[l]).NameHash = h) and
+ (TPSVar(FVars[l]).Name = s) then
+ begin
+ TPSVar(FVars[l]).Use;
+ Result := TPSValueGlobalVar.Create;
+ with TPSValueGlobalVar(Result) do
+ begin
+ SetParserPos(FParser);
+ GlobalVarNo := l;
+
+ end;
+ vt := ivtGlobal;
+ vno := l;
+ if @FOnUseVariable <> nil then
+ FOnUseVariable(Self, vt, vno, BlockInfo.ProcNo, FParser.CurrTokenPos, '');
+ FParser.Next;
+ repeat
+ Temp := Result;
+ if Result <> nil then CheckNotificationVariant(Result);
+ if Result <> nil then CheckFurther(Result, False);
+ if Result <> nil then CheckClass(Result, vt, vno, False);
+ if Result <> nil then CheckExtClass(Result, vt, vno, False);
+{$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF}
+ if Result <> nil then CheckProcCall(Result);
+ if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
+ vno := InvalidVal;
+ until (Result = nil) or (Temp = Result);
+ exit;
+ end;
+ end;
+ Temp1 := FindType(FParser.GetToken);
+ if Temp1 <> nil then
+ begin
+ l := FParser.CurrTokenPos;
+ if FType = 1 then
+ begin
+ Result := nil;
+ MakeError('', ecVariableExpected, FParser.OriginalToken);
+ exit;
+ end;
+ vt := ivtGlobal;
+ vno := InvalidVal;
+ FParser.Next;
+ Result := CheckClassType(Temp1, l);
+ repeat
+ Temp := Result;
+ if Result <> nil then CheckFurther(Result, False);
+ if Result <> nil then CheckClass(Result, vt, vno, False);
+ if Result <> nil then CheckExtClass(Result, vt, vno, False);
+{$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF}
+ if Result <> nil then CheckProcCall(Result);
+ if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
+ vno := InvalidVal;
+ until (Result = nil) or (Temp = Result);
+
+ exit;
+ end;
+ Temp2 := FindProc(FParser.GetToken);
+ if Temp2 <> InvalidVal then
+ begin
+ if FType = 1 then
+ begin
+ Result := nil;
+ MakeError('', ecVariableExpected, FParser.OriginalToken);
+ exit;
+ end;
+ FParser.Next;
+ Result := ReadProcParameters(Temp2, nil);
+ if Result = nil then
+ exit;
+ Result.SetParserPos(FParser);
+ vt := ivtGlobal;
+ vno := InvalidVal;
+ repeat
+ Temp := Result;
+ if Result <> nil then CheckFurther(Result, False);
+ if Result <> nil then CheckClass(Result, vt, vno, False);
+ if Result <> nil then CheckExtClass(Result, vt, vno, False);
+{$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF}
+ if Result <> nil then CheckProcCall(Result);
+ if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
+ vno := InvalidVal;
+ until (Result = nil) or (Temp = Result);
+ exit;
+ end;
+ for l := 0 to FConstants.Count -1 do
+ begin
+ t := TPSConstant(FConstants[l]);
+ if (t.NameHash = h) and (t.Name = s) then
+ begin
+ if FType <> 0 then
+ begin
+ Result := nil;
+ MakeError('', ecVariableExpected, FParser.OriginalToken);
+ exit;
+ end;
+ fparser.next;
+ Result := TPSValueData.Create;
+ with TPSValueData(Result) do
+ begin
+ SetParserPos(FParser);
+ Data := NewVariant(at2ut(t.Value.FType));
+ CopyVariantContents(t.Value, Data);
+ end;
+ vt := ivtGlobal;
+ vno := InvalidVal;
+ repeat
+ Temp := Result;
+ if Result <> nil then CheckFurther(Result, False);
+ if Result <> nil then CheckClass(Result, vt, vno, False);
+ if Result <> nil then CheckExtClass(Result, vt, vno, False);
+{$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF}
+ if Result <> nil then CheckProcCall(Result);
+ if Result <> nil then CheckClassArrayProperty(Result, vt, vno);
+ vno := InvalidVal;
+ until (Result = nil) or (Temp = Result);
+ exit;
+ end;
+ end;
+ Result := nil;
+ MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
+ end;
+
+ function calc(endOn: TPSPasToken): TPSValue;
+ function TryEvalConst(var P: TPSValue): Boolean; forward;
+
+
+ function ReadExpression: TPSValue; forward;
+ function ReadTerm: TPSValue; forward;
+ function ReadFactor: TPSValue;
+ var
+ NewVar: TPSValue;
+ NewVarU: TPSUnValueOp;
+ Proc: TPSProcedure;
+ function ReadArray: Boolean;
+ var
+ tmp: TPSValue;
+ begin
+ FParser.Next;
+ NewVar := TPSValueArray.Create;
+ NewVar.SetParserPos(FParser);
+ if FParser.CurrTokenID <> CSTI_CloseBlock then
+ begin
+ while True do
+ begin
+ tmp := nil;
+ Tmp := ReadExpression();
+ if Tmp = nil then
+ begin
+ Result := False;
+ NewVar.Free;
+ exit;
+ end;
+ if not TryEvalConst(tmp) then
+ begin
+ tmp.Free;
+ NewVar.Free;
+ Result := False;
+ exit;
+ end;
+ TPSValueArray(NewVar).Add(tmp);
+ if FParser.CurrTokenID = CSTI_CloseBlock then Break;
+ if FParser.CurrTokenID <> CSTI_Comma then
+ begin
+ MakeError('', ecCloseBlockExpected, '');
+ NewVar.Free;
+ Result := False;
+ exit;
+ end;
+ FParser.Next;
+ end;
+ end;
+ FParser.Next;
+ Result := True;
+ end;
+
+ function CallAssigned(P: TPSValue): TPSValue;
+ var
+ temp: TPSValueProcNo;
+ begin
+ temp := TPSValueProcNo.Create;
+ temp.ProcNo := FindProc('!ASSIGNED');
+ temp.ResultType := at2ut(FDefaultBoolType);
+ temp.Parameters := TPSParameters.Create;
+ with Temp.Parameters.Add do
+ begin
+ Val := p;
+ ExpectedType := GetTypeNo(BlockInfo, p);
+{$IFDEF DEBUG}
+ if not ExpectedType.Used then asm int 3; end;
+{$ENDIF}
+ FParamMode := pmIn;
+ end;
+ Result := Temp;
+ end;
+
+ function CallSucc(P: TPSValue): TPSValue;
+ var
+ temp: TPSBinValueOp;
+ begin
+ temp := TPSBinValueOp.Create;
+ temp.SetParserPos(FParser);
+ temp.FOperator := otAdd;
+ temp.FVal2 := TPSValueData.Create;
+ TPSValueData(Temp.FVal2).Data := NewVariant(FindBaseType(bts32));
+ TPSValueData(Temp.FVal2).Data.ts32 := 1;
+ temp.FVal1 := p;
+ Temp.FType := GetTypeNo(BlockInfo, P);
+ result := temp;
+ end;
+
+ function CallPred(P: TPSValue): TPSValue;
+ var
+ temp: TPSBinValueOp;
+ begin
+ temp := TPSBinValueOp.Create;
+ temp.SetParserPos(FParser);
+ temp.FOperator := otSub;
+ temp.FVal2 := TPSValueData.Create;
+ TPSValueData(Temp.FVal2).Data := NewVariant(FindBaseType(bts32));
+ TPSValueData(Temp.FVal2).Data.ts32 := 1;
+ temp.FVal1 := p;
+ Temp.FType := GetTypeNo(BlockInfo, P);
+ result := temp;
+ end;
+
+ begin
+ case fParser.CurrTokenID of
+ CSTI_OpenBlock:
+ begin
+ if not ReadArray then
+ begin
+ Result := nil;
+ exit;
+ end;
+ end;
+ CSTII_Not:
+ begin
+ FParser.Next;
+ NewVar := ReadFactor;
+ if NewVar = nil then
+ begin
+ Result := nil;
+ exit;
+ end;
+ NewVarU := TPSUnValueOp.Create;
+ NewVarU.SetParserPos(FParser);
+ NewVarU.aType := GetTypeNo(BlockInfo, NewVar);
+ NewVarU.Operator := otNot;
+ NewVarU.Val1 := NewVar;
+ NewVar := NewVarU;
+ end;
+ CSTI_Plus:
+ begin
+ FParser.Next;
+ NewVar := ReadTerm;
+ if NewVar = nil then
+ begin
+ Result := nil;
+ exit;
+ end;
+ end;
+ CSTI_Minus:
+ begin
+ FParser.Next;
+ NewVar := ReadTerm;
+ if NewVar = nil then
+ begin
+ Result := nil;
+ exit;
+ end;
+ NewVarU := TPSUnValueOp.Create;
+ NewVarU.SetParserPos(FParser);
+ NewVarU.aType := GetTypeNo(BlockInfo, NewVar);
+ NewVarU.Operator := otMinus;
+ NewVarU.Val1 := NewVar;
+ NewVar := NewVarU;
+ end;
+ CSTII_Nil:
+ begin
+ FParser.Next;
+ NewVar := TPSValueNil.Create;
+ NewVar.SetParserPos(FParser);
+ end;
+ CSTI_AddressOf:
+ begin
+ FParser.Next;
+ if FParser.CurrTokenID <> CSTI_Identifier then
+ begin
+ MakeError('', ecIdentifierExpected, '');
+ Result := nil;
+ exit;
+ end;
+ NewVar := TPSValueProcPtr.Create;
+ NewVar.SetParserPos(FParser);
+ TPSValueProcPtr(NewVar).ProcPtr := FindProc(FParser.GetToken);
+ if TPSValueProcPtr(NewVar).ProcPtr = InvalidVal then
+ begin
+ MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
+ NewVar.Free;
+ Result := nil;
+ exit;
+ end;
+ Proc := FProcs[TPSValueProcPtr(NewVar).ProcPtr];
+ if Proc.ClassType <> TPSInternalProcedure then
+ begin
+ MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
+ NewVar.Free;
+ Result := nil;
+ exit;
+ end;
+ FParser.Next;
+ end;
+ CSTI_OpenRound:
+ begin
+ FParser.Next;
+ NewVar := ReadExpression();
+ if NewVar = nil then
+ begin
+ Result := nil;
+ exit;
+ end;
+ if FParser.CurrTokenId <> CSTI_CloseRound then
+ begin
+ NewVar.Free;
+ Result := nil;
+ MakeError('', ecCloseRoundExpected, '');
+ exit;
+ end;
+ FParser.Next;
+ end;
+ CSTI_Char, CSTI_String:
+ begin
+ NewVar := TPSValueData.Create;
+ NewVar.SetParserPos(FParser);
+ TPSValueData(NewVar).Data := ReadString;
+ if TPSValueData(NewVar).Data = nil then
+ begin
+ NewVar.Free;
+ Result := nil;
+ exit;
+ end;
+ end;
+ CSTI_HexInt, CSTI_Integer:
+ begin
+ NewVar := TPSValueData.Create;
+ NewVar.SetParserPos(FParser);
+ TPSValueData(NewVar).Data := ReadInteger(FParser.GetToken);
+ FParser.Next;
+ end;
+ CSTI_Real:
+ begin
+ NewVar := TPSValueData.Create;
+ NewVar.SetParserPos(FParser);
+ TPSValueData(NewVar).Data := ReadReal(FParser.GetToken);
+ FParser.Next;
+ end;
+ CSTII_Ord:
+ begin
+ FParser.Next;
+ if fParser.Currtokenid <> CSTI_OpenRound then
+ begin
+ Result := nil;
+ MakeError('', ecOpenRoundExpected, '');
+ exit;
+ end;
+ FParser.Next;
+ NewVar := ReadExpression();
+ if NewVar = nil then
+ begin
+ Result := nil;
+ exit;
+ end;
+ if FParser.CurrTokenId <> CSTI_CloseRound then
+ begin
+ NewVar.Free;
+ Result := nil;
+ MakeError('', ecCloseRoundExpected, '');
+ exit;
+ end;
+ if not ((GetTypeNo(BlockInfo, NewVar).BaseType = btChar) or
+ {$IFNDEF PS_NOWIDESTRING} (GetTypeNo(BlockInfo, NewVar).BaseType = btWideChar) or{$ENDIF}
+ (GetTypeNo(BlockInfo, NewVar).BaseType = btEnum) or (IsIntType(GetTypeNo(BlockInfo, NewVar).BaseType))) then
+ begin
+ NewVar.Free;
+ Result := nil;
+ MakeError('', ecTypeMismatch, '');
+ exit;
+ end;
+ NewVarU := TPSUnValueOp.Create;
+ NewVarU.SetParserPos(FParser);
+ NewVarU.Operator := otCast;
+ NewVarU.FType := at2ut(FindBaseType(btu32));
+ NewVarU.Val1 := NewVar;
+ NewVar := NewVarU;
+ FParser.Next;
+ end;
+ CSTII_Chr:
+ begin
+ FParser.Next;
+ if fParser.Currtokenid <> CSTI_OpenRound then
+ begin
+ Result := nil;
+ MakeError('', ecOpenRoundExpected, '');
+ exit;
+ end;
+ FParser.Next;
+ NewVar := ReadExpression();
+ if NewVar = nil then
+ begin
+ Result := nil;
+ exit;
+ end;
+ if FParser.CurrTokenId <> CSTI_CloseRound then
+ begin
+ NewVar.Free;
+ Result := nil;
+ MakeError('', ecCloseRoundExpected, '');
+ exit;
+ end;
+ if not (IsIntType(GetTypeNo(BlockInfo, NewVar).BaseType)) then
+ begin
+ NewVar.Free;
+ Result := nil;
+ MakeError('', ecTypeMismatch, '');
+ exit;
+ end;
+ NewVarU := TPSUnValueOp.Create;
+ NewVarU.SetParserPos(FParser);
+ NewVarU.Operator := otCast;
+ NewVarU.FType := at2ut(FindBaseType(btChar));
+ NewVarU.Val1 := NewVar;
+ NewVar := NewVarU;
+ FParser.Next;
+ end;
+ CSTI_Identifier:
+ begin
+ if FParser.GetToken = 'SUCC' then
+ begin
+ FParser.Next;
+ if FParser.CurrTokenID <> CSTI_OpenRound then
+ begin
+ Result := nil;
+ MakeError('', ecOpenRoundExpected, '');
+ exit;
+ end;
+ FParser.Next;
+ NewVar := ReadExpression;
+ if NewVar = nil then
+ begin
+ result := nil;
+ exit;
+ end;
+ if (GetTypeNo(BlockInfo, NewVar) = nil) or (not IsIntType(GetTypeNo(BlockInfo, NewVar).BaseType) and
+ (GetTypeNo(BlockInfo, NewVar).BaseType <> btEnum)) then
+ begin
+ NewVar.Free;
+ Result := nil;
+ MakeError('', ecTypeMismatch, '');
+ exit;
+ end;
+ if FParser.CurrTokenID <> CSTI_CloseRound then
+ begin
+ NewVar.Free;
+ Result := nil;
+ MakeError('', eccloseRoundExpected, '');
+ exit;
+ end;
+ NewVar := CallSucc(NewVar);
+ FParser.Next;
+ end else
+ if FParser.GetToken = 'PRED' then
+ begin
+ FParser.Next;
+ if FParser.CurrTokenID <> CSTI_OpenRound then
+ begin
+ Result := nil;
+ MakeError('', ecOpenRoundExpected, '');
+ exit;
+ end;
+ FParser.Next;
+ NewVar := ReadExpression;
+ if NewVar = nil then
+ begin
+ result := nil;
+ exit;
+ end;
+ if (GetTypeNo(BlockInfo, NewVar) = nil) or (not IsIntType(GetTypeNo(BlockInfo, NewVar).BaseType) and
+ (GetTypeNo(BlockInfo, NewVar).BaseType <> btEnum)) then
+ begin
+ NewVar.Free;
+ Result := nil;
+ MakeError('', ecTypeMismatch, '');
+ exit;
+ end;
+ if FParser.CurrTokenID <> CSTI_CloseRound then
+ begin
+ NewVar.Free;
+ Result := nil;
+ MakeError('', eccloseRoundExpected, '');
+ exit;
+ end;
+ NewVar := CallPred(NewVar);
+ FParser.Next;
+ end else
+ if FParser.GetToken = 'ASSIGNED' then
+ begin
+ FParser.Next;
+ if FParser.CurrTokenID <> CSTI_OpenRound then
+ begin
+ Result := nil;
+ MakeError('', ecOpenRoundExpected, '');
+ exit;
+ end;
+ FParser.Next;
+ NewVar := GetIdentifier(0);
+ if NewVar = nil then
+ begin
+ result := nil;
+ exit;
+ end;
+ if (GetTypeNo(BlockInfo, NewVar) = nil) or ((GetTypeNo(BlockInfo, NewVar).BaseType <> btClass) and
+ (GetTypeNo(BlockInfo, NewVar).BaseType <> btPChar) and
+ (GetTypeNo(BlockInfo, NewVar).BaseType <> btString)) then
+ begin
+ NewVar.Free;
+ Result := nil;
+ MakeError('', ecTypeMismatch, '');
+ exit;
+ end;
+ if FParser.CurrTokenID <> CSTI_CloseRound then
+ begin
+ NewVar.Free;
+ Result := nil;
+ MakeError('', eccloseRoundExpected, '');
+ exit;
+ end;
+ NewVar := CallAssigned(NewVar);
+ FParser.Next;
+ end else
+ begin
+ NewVar := GetIdentifier(0);
+ if NewVar = nil then
+ begin
+ Result := nil;
+ exit;
+ end;
+ end;
+ end;
+ else
+ begin
+ MakeError('', ecSyntaxError, '');
+ Result := nil;
+ exit;
+ end;
+ end; {case}
+ Result := NewVar;
+ end; // ReadFactor
+
+ function GetResultType(p1, P2: TPSValue; Cmd: TPSBinOperatorType): TPSType;
+ var
+ pp, t1, t2: PIFPSType;
+ begin
+ t1 := GetTypeNo(BlockInfo, p1);
+ t2 := GetTypeNo(BlockInfo, P2);
+ if (t1 = nil) or (t2 = nil) then
+ begin
+ if ((p1.ClassType = TPSValueNil) or (p2.ClassType = TPSValueNil)) and ((t1 <> nil) or (t2 <> nil)) then
+ begin
+ if p1.ClassType = TPSValueNil then
+ pp := t2
+ else
+ pp := t1;
+ if (pp.BaseType = btPchar) or (pp.BaseType = btString) or (pp.BaseType = btClass) {$IFNDEF PS_NOINTERFACES}or (pp.BaseType =btInterface){$ENDIF} or (pp.BaseType = btProcPtr) then
+ Result := AT2UT(FDefaultBoolType)
+ else
+ Result := nil;
+ exit;
+ end;
+ Result := nil;
+ exit;
+ end;
+ case Cmd of
+ otAdd: {plus}
+ begin
+ if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and (
+ ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or
+ (t2.BaseType = btString) or
+ {$IFNDEF PS_NOWIDESTRING}
+ (t2.BaseType = btwideString) or
+ (t2.BaseType = btUnicodestring) or
+ (t2.BaseType = btwidechar) or
+ {$ENDIF}
+ (t2.BaseType = btPchar) or
+ (t2.BaseType = btChar) or
+ (isIntRealType(t2.BaseType))) then
+ Result := t1
+ else
+ if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and (
+ ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or
+ (t1.BaseType = btString) or
+ {$IFNDEF PS_NOWIDESTRING}
+ (t1.BaseType = btUnicodestring) or
+ (t1.BaseType = btwideString) or
+ (t1.BaseType = btwidechar) or
+ {$ENDIF}
+ (t1.BaseType = btPchar) or
+ (t1.BaseType = btChar) or
+ (isIntRealType(t1.BaseType))) then
+ Result := t2
+ else if ((t1.BaseType = btSet) and (t2.BaseType = btSet)) and (t1 = t2) then
+ Result := t1
+ else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then
+ Result := t1
+ else if IsIntRealType(t1.BaseType) and
+ IsIntRealType(t2.BaseType) then
+ begin
+ if IsRealType(t1.BaseType) then
+ Result := t1
+ else
+ Result := t2;
+ end
+ else if (t1.basetype = btSet) and (t2.Name = 'TVARIANTARRAY') then
+ Result := t1
+ else if (t2.basetype = btSet) and (t1.Name = 'TVARIANTARRAY') then
+ Result := t2
+ else if ((t1.BaseType = btPchar) or(t1.BaseType = btString) or (t1.BaseType = btChar)) and ((t2.BaseType = btPchar) or(t2.BaseType = btString) or (t2.BaseType = btChar)) then
+ Result := at2ut(FindBaseType(btString))
+ {$IFNDEF PS_NOWIDESTRING}
+ else if ((t1.BaseType = btString) or (t1.BaseType = btChar) or (t1.BaseType = btPchar)or (t1.BaseType = btWideString) or (t1.BaseType = btWideChar) or (t1.BaseType = btUnicodeString)) and
+ ((t2.BaseType = btString) or (t2.BaseType = btChar) or (t2.BaseType = btPchar) or (t2.BaseType = btWideString) or (t2.BaseType = btWideChar) or (t2.BaseType = btUnicodeString)) then
+ Result := at2ut(FindBaseType(btWideString))
+ {$ENDIF}
+ else
+ Result := nil;
+ end;
+ otSub, otMul, otDiv: { - * / }
+ begin
+ if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and (
+ ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or
+ (isIntRealType(t2.BaseType))) then
+ Result := t1
+ else if ((t1.BaseType = btSet) and (t2.BaseType = btSet)) and (t1 = t2) and ((cmd = otSub) or (cmd = otMul)) then
+ Result := t1
+ else if (t1.basetype = btSet) and (t2.Name = 'TVARIANTARRAY') and ((cmd = otSub) or (cmd = otMul)) then
+ Result := t1
+ else if (t2.basetype = btSet) and (t1.Name = 'TVARIANTARRAY') and ((cmd = otSub) or (cmd = otMul)) then
+ Result := t2
+ else
+ if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and (
+ ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or
+ (isIntRealType(t1.BaseType))) then
+ Result := t2
+ else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then
+ Result := t1
+ else if IsIntRealType(t1.BaseType) and
+ IsIntRealType(t2.BaseType) then
+ begin
+ if IsRealType(t1.BaseType) then
+ Result := t1
+ else
+ Result := t2;
+ end
+ else
+ Result := nil;
+ end;
+ otAnd, otOr, otXor: {and,or,xor}
+ begin
+ if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and (
+ ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or
+ (isIntType(t2.BaseType))) then
+ Result := t1
+ else
+ if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and (
+ ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or
+ (isIntType(t1.BaseType))) then
+ Result := t2
+ else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then
+ Result := t1
+ else if (IsBoolean(t1)) and ((t2 = t1) or ((t2.BaseType = btVariant)
+ or (t2.BaseType = btNotificationVariant))) then
+ begin
+ Result := t1;
+ if ((p1.ClassType = TPSValueData) or (p2.ClassType = TPSValueData)) then
+ begin
+ if cmd = otAnd then {and}
+ begin
+ if p1.ClassType = TPSValueData then
+ begin
+ if (TPSValueData(p1).FData^.tu8 <> 0) then
+ begin
+ with MakeWarning('', ewIsNotNeeded, '"True and"') do
+ begin
+ FRow := p1.Row;
+ FCol := p1.Col;
+ FPosition := p1.Pos;
+ end;
+ end else
+ begin
+ with MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'False') do
+ begin
+ FRow := p1.Row;
+ FCol := p1.Col;
+ FPosition := p1.Pos;
+ end;
+ end;
+ end else begin
+ if (TPSValueData(p2).Data.tu8 <> 0) then
+ begin
+ with MakeWarning('', ewIsNotNeeded, '"and True"') do
+ begin
+ FRow := p1.Row;
+ FCol := p1.Col;
+ FPosition := p1.Pos;
+ end;
+ end
+ else
+ begin
+ with MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'False') do
+ begin
+ FRow := p1.Row;
+ FCol := p1.Col;
+ FPosition := p1.Pos;
+ end;
+ end;
+ end;
+ end else if cmd = otOr then {or}
+ begin
+ if p1.ClassType = TPSValueData then
+ begin
+ if (TPSValueData(p1).Data.tu8 <> 0) then
+ begin
+ with MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'True') do
+ begin
+ FRow := p1.Row;
+ FCol := p1.Col;
+ FPosition := p1.Pos;
+ end;
+ end
+ else
+ begin
+ with MakeWarning('', ewIsNotNeeded, '"False or"') do
+ begin
+ FRow := p1.Row;
+ FCol := p1.Col;
+ FPosition := p1.Pos;
+ end;
+ end
+ end else begin
+ if (TPSValueData(p2).Data.tu8 <> 0) then
+ begin
+ with MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'True') do
+ begin
+ FRow := p1.Row;
+ FCol := p1.Col;
+ FPosition := p1.Pos;
+ end;
+ end
+ else
+ begin
+ with MakeWarning('', ewIsNotNeeded, '"or False"') do
+ begin
+ FRow := p1.Row;
+ FCol := p1.Col;
+ FPosition := p1.Pos;
+ end;
+ end
+ end;
+ end;
+ end;
+ end else
+ Result := nil;
+ end;
+ otMod, otShl, otShr: {mod,shl,shr}
+ begin
+ if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and (
+ ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or
+ (isIntType(t2.BaseType))) then
+ Result := t1
+ else
+ if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and (
+ ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or
+ (isIntType(t1.BaseType))) then
+ Result := t2
+ else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then
+ Result := t1
+ else
+ Result := nil;
+ end;
+ otGreater, otLess, otGreaterEqual, otLessEqual: { >=, <=, >, <}
+ begin
+ if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and (
+ ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or
+ (t2.BaseType = btString) or
+ (t2.BaseType = btPchar) or
+ (t2.BaseType = btChar) or
+ (isIntRealType(t2.BaseType))) then
+ Result := FDefaultBoolType
+ else if ((t1.BaseType = btSet) and (t2.BaseType = btSet)) and (t1 = t2) and ((cmd = otGreaterEqual) or (cmd = otLessEqual)) then
+ Result := FDefaultBoolType
+ else
+ if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and (
+ ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or
+ (t1.BaseType = btString) or
+ (t1.BaseType = btPchar) or
+ (t1.BaseType = btChar) or
+ (isIntRealType(t1.BaseType))) then
+ Result := FDefaultBoolType
+ else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then
+ Result := FDefaultBoolType
+ else if IsIntRealType(t1.BaseType) and
+ IsIntRealType(t2.BaseType) then
+ Result := FDefaultBoolType
+ else if
+ ((t1.BaseType = btString) or (t1.BaseType = btChar) {$IFNDEF PS_NOWIDESTRING} or (t1.BaseType = btWideString) or (t1.BaseType = btWideChar) or (t1.BaseType = btUnicodestring){$ENDIF}) and
+ ((t2.BaseType = btString) or (t2.BaseType = btChar) {$IFNDEF PS_NOWIDESTRING} or (t2.BaseType = btWideString) or (t2.BaseType = btWideChar) or (t2.BaseType = btUnicodestring){$ENDIF}) then
+ Result := FDefaultBoolType
+ else if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) then
+ Result := FDefaultBoolType
+ else
+ Result := nil;
+ end;
+ otEqual, otNotEqual: {=, <>}
+ begin
+ if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and (
+ ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or
+ (t2.BaseType = btString) or
+ (t2.BaseType = btPchar) or
+ (t2.BaseType = btChar) or
+ (isIntRealType(t2.BaseType))) then
+ Result := FDefaultBoolType
+ else if ((t1.BaseType = btSet) and (t2.BaseType = btSet)) and (t1 = t2) then
+ Result := FDefaultBoolType
+ else
+ if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and (
+ ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or
+ (t1.BaseType = btString) or
+ (t1.BaseType = btPchar) or
+ (t1.BaseType = btChar) or
+ (isIntRealType(t1.BaseType))) then
+ Result := FDefaultBoolType
+ else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then
+ Result := FDefaultBoolType
+ else if IsIntRealType(t1.BaseType) and
+ IsIntRealType(t2.BaseType) then
+ Result := FDefaultBoolType
+ else if
+ ((t1.BaseType = btString) or (t1.BaseType = btChar) {$IFNDEF PS_NOWIDESTRING} or (t1.BaseType = btWideString) or (t1.BaseType = btWideChar) or (t1.BaseType = btUnicodestring){$ENDIF}) and
+ ((t2.BaseType = btString) or (t2.BaseType = btChar) {$IFNDEF PS_NOWIDESTRING} or (t2.BaseType = btWideString) or (t2.BaseType = btWideChar) or (t2.BaseType = btUnicodestring){$ENDIF}) then
+ Result := FDefaultBoolType
+ else if (t1.basetype = btSet) and (t2.Name = 'TVARIANTARRAY') then
+ Result := FDefaultBoolType
+ else if (t2.basetype = btSet) and (t1.Name = 'TVARIANTARRAY') then
+ Result := FDefaultBoolType
+ else if (t1.BaseType = btEnum) and (t1 = t2) then
+ Result := FDefaultBoolType
+ else if (t1.BaseType = btClass) and (t2.BaseType = btClass) then
+ Result := FDefaultBoolType
+ else if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) then
+ Result := FDefaultBoolType
+ else Result := nil;
+ end;
+ otIn:
+ begin
+ if (t2.Name = 'TVARIANTARRAY') then
+ Result := FDefaultBoolType
+ else
+ if (t2.BaseType = btSet) and (TPSSetType(t2).SetType = t1) then
+ Result := FDefaultBoolType
+ else
+ Result := nil;
+ end;
+ otIs:
+ begin
+ if t2.BaseType = btType then
+ begin
+ Result := FDefaultBoolType
+ end else
+ Result := nil;
+ end;
+ otAs:
+ begin
+ if t2.BaseType = btType then
+ begin
+ Result := at2ut(TPSValueData(p2).Data.ttype);
+ end else
+ Result := nil;
+ end;
+ else
+ Result := nil;
+ end;
+ end;
+
+
+ function ReadTerm: TPSValue;
+ var
+ F1, F2: TPSValue;
+ F: TPSBinValueOp;
+ Token: TPSPasToken;
+ Op: TPSBinOperatorType;
+ begin
+ F1 := ReadFactor;
+ if F1 = nil then
+ begin
+ Result := nil;
+ exit;
+ end;
+ while FParser.CurrTokenID in [CSTI_Multiply, CSTI_Divide, CSTII_Div, CSTII_Mod, CSTII_And, CSTII_Shl, CSTII_Shr, CSTII_As] do
+ begin
+ Token := FParser.CurrTokenID;
+ FParser.Next;
+ F2 := ReadFactor;
+ if f2 = nil then
+ begin
+ f1.Free;
+ Result := nil;
+ exit;
+ end;
+ case Token of
+ CSTI_Multiply: Op := otMul;
+ CSTII_div, CSTI_Divide: Op := otDiv;
+ CSTII_mod: Op := otMod;
+ CSTII_and: Op := otAnd;
+ CSTII_shl: Op := otShl;
+ CSTII_shr: Op := otShr;
+ CSTII_As: Op := otAs;
+ else
+ Op := otAdd;
+ end;
+ F := TPSBinValueOp.Create;
+ f.Val1 := F1;
+ f.Val2 := F2;
+ f.Operator := Op;
+ f.aType := GetResultType(F1, F2, Op);
+ if f.aType = nil then
+ begin
+ MakeError('', ecTypeMismatch, '');
+ f.Free;
+ Result := nil;
+ exit;
+ end;
+ f1 := f;
+ end;
+ Result := F1;
+ end; // ReadTerm
+
+ function ReadSimpleExpression: TPSValue;
+ var
+ F1, F2: TPSValue;
+ F: TPSBinValueOp;
+ Token: TPSPasToken;
+ Op: TPSBinOperatorType;
+ begin
+ F1 := ReadTerm;
+ if F1 = nil then
+ begin
+ Result := nil;
+ exit;
+ end;
+ while FParser.CurrTokenID in [CSTI_Plus, CSTI_Minus, CSTII_Or, CSTII_Xor] do
+ begin
+ Token := FParser.CurrTokenID;
+ FParser.Next;
+ F2 := ReadTerm;
+ if f2 = nil then
+ begin
+ f1.Free;
+ Result := nil;
+ exit;
+ end;
+ case Token of
+ CSTI_Plus: Op := otAdd;
+ CSTI_Minus: Op := otSub;
+ CSTII_or: Op := otOr;
+ CSTII_xor: Op := otXor;
+ else
+ Op := otAdd;
+ end;
+ F := TPSBinValueOp.Create;
+ f.Val1 := F1;
+ f.Val2 := F2;
+ f.Operator := Op;
+ f.aType := GetResultType(F1, F2, Op);
+ if f.aType = nil then
+ begin
+ MakeError('', ecTypeMismatch, '');
+ f.Free;
+ Result := nil;
+ exit;
+ end;
+ f1 := f;
+ end;
+ Result := F1;
+ end; // ReadSimpleExpression
+
+
+ function ReadExpression: TPSValue;
+ var
+ F1, F2: TPSValue;
+ F: TPSBinValueOp;
+ Token: TPSPasToken;
+ Op: TPSBinOperatorType;
+ begin
+ F1 := ReadSimpleExpression;
+ if F1 = nil then
+ begin
+ Result := nil;
+ exit;
+ end;
+ while FParser.CurrTokenID in [ CSTI_GreaterEqual, CSTI_LessEqual, CSTI_Greater, CSTI_Less, CSTI_Equal, CSTI_NotEqual, CSTII_in, CSTII_is] do
+ begin
+ Token := FParser.CurrTokenID;
+ FParser.Next;
+ F2 := ReadSimpleExpression;
+ if f2 = nil then
+ begin
+ f1.Free;
+ Result := nil;
+ exit;
+ end;
+ case Token of
+ CSTI_GreaterEqual: Op := otGreaterEqual;
+ CSTI_LessEqual: Op := otLessEqual;
+ CSTI_Greater: Op := otGreater;
+ CSTI_Less: Op := otLess;
+ CSTI_Equal: Op := otEqual;
+ CSTI_NotEqual: Op := otNotEqual;
+ CSTII_in: Op := otIn;
+ CSTII_is: Op := otIs;
+ else
+ Op := otAdd;
+ end;
+ F := TPSBinValueOp.Create;
+ f.Val1 := F1;
+ f.Val2 := F2;
+ f.Operator := Op;
+ f.aType := GetResultType(F1, F2, Op);
+ if f.aType = nil then
+ begin
+ MakeError('', ecTypeMismatch, '');
+ f.Free;
+ Result := nil;
+ exit;
+ end;
+ f1 := f;
+ end;
+ Result := F1;
+ end; // ReadExpression
+
+ function TryEvalConst(var P: TPSValue): Boolean;
+ var
+ preplace: TPSValue;
+ begin
+ if p is TPSBinValueOp then
+ begin
+ if not (TryEvalConst(TPSBinValueOp(p).FVal1) and TryEvalConst(TPSBinValueOp(p).FVal2)) then
+ begin
+ Result := False;
+ exit;
+ end;
+ if (TPSBinValueOp(p).FVal1.ClassType = TPSValueData) and (TPSBinValueOp(p).FVal2.ClassType = TPSValueData) then
+ begin
+ if not PreCalc(True, 0, TPSValueData(TPSBinValueOp(p).Val1).Data, 0, TPSValueData(TPSBinValueOp(p).Val2).Data, TPSBinValueOp(p).Operator, p.Pos, p.Row, p.Col) then
+ begin
+ Result := False;
+ exit;
+ end;
+ preplace := TPSValueData.Create;
+ preplace.Pos := p.Pos;
+ preplace.Row := p.Row;
+ preplace.Col := p.Col;
+ TPSValueData(preplace).Data := TPSValueData(TPSBinValueOp(p).Val1).Data;
+ TPSValueData(TPSBinValueOp(p).Val1).Data := nil;
+ p.Free;
+ p := preplace;
+ end;
+ end else if p is TPSUnValueOp then
+ begin
+ if not TryEvalConst(TPSUnValueOp(p).FVal1) then
+ begin
+ Result := False;
+ exit;
+ end;
+ if TPSUnValueOp(p).FVal1.ClassType = TPSValueData then
+ begin
+//
+ case TPSUnValueOp(p).Operator of
+ otNot:
+ begin
+ case TPSValueData(TPSUnValueOp(p).FVal1).Data^.FType.BaseType of
+ btEnum:
+ begin
+ if IsBoolean(TPSValueData(TPSUnValueOp(p).FVal1).Data^.FType) then
+ begin
+ TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8 := (not TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8) and 1;
+ end else
+ begin
+ MakeError('', ecTypeMismatch, '');
+ Result := False;
+ exit;
+ end;
+ end;
+ btU8: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
+ btU16: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
+ btU32: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu32 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu32;
+ bts8: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts8 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts8;
+ bts16: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts16 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts16;
+ bts32: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts32 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts32;
+ {$IFNDEF PS_NOINT64}
+ bts64: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
+ {$ENDIF}
+ else
+ begin
+ MakeError('', ecTypeMismatch, '');
+ Result := False;
+ exit;
+ end;
+ end;
+ preplace := TPSUnValueOp(p).Val1;
+ TPSUnValueOp(p).Val1 := nil;
+ p.Free;
+ p := preplace;
+ end;
+ otMinus:
+ begin
+ case TPSValueData(TPSUnValueOp(p).FVal1).Data^.FType.BaseType of
+ btU8: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
+ btU16: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
+ btU32: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu32 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu32;
+ bts8: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts8 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts8;
+ bts16: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts16 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts16;
+ bts32: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts32 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts32;
+ {$IFNDEF PS_NOINT64}
+ bts64: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
+ {$ENDIF}
+ btSingle: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tsingle := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tsingle;
+ btDouble: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tdouble := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tdouble;
+ btExtended: TPSValueData(TPSUnValueOp(p).FVal1).Data^.textended := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.textended;
+ btCurrency: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tcurrency := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tcurrency;
+ else
+ begin
+ MakeError('', ecTypeMismatch, '');
+ Result := False;
+ exit;
+ end;
+ end;
+ preplace := TPSUnValueOp(p).Val1;
+ TPSUnValueOp(p).Val1 := nil;
+ p.Free;
+ p := preplace;
+ end;
+ otCast:
+ begin
+ preplace := TPSValueData.Create;
+ TPSValueData(preplace).Data := NewVariant(TPSUnValueOp(p).FType);
+ case TPSUnValueOp(p).FType.BaseType of
+ btU8:
+ begin
+ case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
+ btchar: TPSValueData(preplace).Data.tu8 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar);
+ {$IFNDEF PS_NOWIDESTRING}
+ btwidechar: TPSValueData(preplace).Data.tu8 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar);
+ {$ENDIF}
+ btU8: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
+ btS8: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8;
+ btU16: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
+ btS16: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16;
+ btU32: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32;
+ btS32: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32;
+ {$IFNDEF PS_NOINT64}
+ btS64: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
+ {$ENDIF}
+ else
+ begin
+ MakeError('', ecTypeMismatch, '');
+ preplace.Free;
+ Result := False;
+ exit;
+ end;
+ end;
+ end;
+ btS8:
+ begin
+ case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
+ btchar: TPSValueData(preplace).Data.ts8 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar);
+ {$IFNDEF PS_NOWIDESTRING}
+ btwidechar: TPSValueData(preplace).Data.ts8 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar);
+ {$ENDIF}
+ btU8: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
+ btS8: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8;
+ btU16: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
+ btS16: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16;
+ btU32: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32;
+ btS32: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32;
+ {$IFNDEF PS_NOINT64}
+ btS64: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
+ {$ENDIF}
+ else
+ begin
+ MakeError('', ecTypeMismatch, '');
+ preplace.Free;
+ Result := False;
+ exit;
+ end;
+ end;
+ end;
+ btU16:
+ begin
+ case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
+ btchar: TPSValueData(preplace).Data.tu16 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar);
+ {$IFNDEF PS_NOWIDESTRING}
+ btwidechar: TPSValueData(preplace).Data.tu16 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar);
+ {$ENDIF}
+ btU8: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
+ btS8: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8;
+ btU16: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
+ btS16: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16;
+ btU32: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32;
+ btS32: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32;
+ {$IFNDEF PS_NOINT64}
+ btS64: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
+ {$ENDIF}
+ else
+ begin
+ MakeError('', ecTypeMismatch, '');
+ preplace.Free;
+ Result := False;
+ exit;
+ end;
+ end;
+ end;
+ bts16:
+ begin
+ case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
+ btchar: TPSValueData(preplace).Data.ts16 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar);
+ {$IFNDEF PS_NOWIDESTRING}
+ btwidechar: TPSValueData(preplace).Data.ts16 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar);
+ {$ENDIF}
+ btU8: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
+ btS8: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8;
+ btU16: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
+ btS16: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16;
+ btU32: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32;
+ btS32: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32;
+ {$IFNDEF PS_NOINT64}
+ btS64: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
+ {$ENDIF}
+ else
+ begin
+ MakeError('', ecTypeMismatch, '');
+ preplace.Free;
+ Result := False;
+ exit;
+ end;
+ end;
+ end;
+ btU32:
+ begin
+ case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
+ btchar: TPSValueData(preplace).Data.tu32 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar);
+ {$IFNDEF PS_NOWIDESTRING}
+ btwidechar: TPSValueData(preplace).Data.tu32 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar);
+ {$ENDIF}
+ btU8: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
+ btS8: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8;
+ btU16: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
+ btS16: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16;
+ btU32: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32;
+ btS32: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32;
+ {$IFNDEF PS_NOINT64}
+ btS64: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
+ {$ENDIF}
+ else
+ begin
+ MakeError('', ecTypeMismatch, '');
+ preplace.Free;
+ Result := False;
+ exit;
+ end;
+ end;
+ end;
+ btS32:
+ begin
+ case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
+ btchar: TPSValueData(preplace).Data.ts32 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar);
+ {$IFNDEF PS_NOWIDESTRING}
+ btwidechar: TPSValueData(preplace).Data.ts32 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar);
+ {$ENDIF}
+ btU8: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
+ btS8: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8;
+ btU16: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
+ btS16: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16;
+ btU32: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32;
+ btS32: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32;
+ {$IFNDEF PS_NOINT64}
+ btS64: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
+ {$ENDIF}
+ else
+ begin
+ MakeError('', ecTypeMismatch, '');
+ preplace.Free;
+ Result := False;
+ exit;
+ end;
+ end;
+ end;
+ {$IFNDEF PS_NOINT64}
+ btS64:
+ begin
+ case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
+ btchar: TPSValueData(preplace).Data.ts64 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar);
+ {$IFNDEF PS_NOWIDESTRING}
+ btwidechar: TPSValueData(preplace).Data.ts64 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar);
+ {$ENDIF}
+ btU8: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8;
+ btS8: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8;
+ btU16: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16;
+ btS16: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16;
+ btU32: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32;
+ btS32: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32;
+ btS64: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64;
+ else
+ begin
+ MakeError('', ecTypeMismatch, '');
+ preplace.Free;
+ Result := False;
+ exit;
+ end;
+ end;
+ end;
+ {$ENDIF}
+ btChar:
+ begin
+ case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of
+ btchar: TPSValueData(preplace).Data.tchar := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar;
+ btU8: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8);
+ btS8: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8);
+ btU16: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16);
+ btS16: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16);
+ btU32: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32);
+ btS32: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32);
+ {$IFNDEF PS_NOINT64}
+ btS64: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64);
+ {$ENDIF}
+ else
+ begin
+ MakeError('', ecTypeMismatch, '');
+ Result := False;
+ preplace.Free;
+ exit;
+ end;
+ end;
+ end;
+ else
+ begin
+ MakeError('', ecTypeMismatch, '');
+ Result := False;
+ preplace.Free;
+ exit;
+ end;
+ end;
+ p.Free;
+ p := preplace;
+ end;
+ else
+ begin
+ MakeError('', ecTypeMismatch, '');
+ Result := False;
+ exit;
+ end;
+ end; // case
+ end; // if
+ end;
+ Result := True;
+ end;
+
+ var
+ Val: TPSValue;
+
+begin
+ Val := ReadExpression;
+ if Val = nil then
+ begin
+ Result := nil;
+ exit;
+ end;
+ if not TryEvalConst(Val) then
+ begin
+ Val.Free;
+ Result := nil;
+ exit;
+ end;
+ Result := Val;
+ end;
+
+ function ReadParameters(IsProperty: Boolean; Dest: TPSParameters): Boolean;
+ var
+ sr,cr: TPSPasToken;
+ begin
+ if IsProperty then
+ begin
+ sr := CSTI_OpenBlock;
+ cr := CSTI_CloseBlock;
+ end else begin
+ sr := CSTI_OpenRound;
+ cr := CSTI_CloseRound;
+ end;
+ if FParser.CurrTokenId = sr then
+ begin
+ FParser.Next;
+ if FParser.CurrTokenId = cr then
+ begin
+ FParser.Next;
+ Result := True;
+ exit;
+ end;
+ end else
+ begin
+ result := True;
+ exit;
+ end;
+ repeat
+ with Dest.Add do
+ begin
+ Val := calc(CSTI_CloseRound);
+ if Val = nil then
+ begin
+ result := false;
+ exit;
+ end;
+ end;
+ if FParser.CurrTokenId = cr then
+ begin
+ FParser.Next;
+ Break;
+ end;
+ if FParser.CurrTokenId <> CSTI_Comma then
+ begin
+ MakeError('', ecCommaExpected, '');
+ Result := false;
+ exit;
+ end; {if}
+ FParser.Next;
+ until False;
+ Result := true;
+ end;
+
+ function ReadProcParameters(ProcNo: Cardinal; FSelf: TPSValue): TPSValue;
+ var
+ Decl: TPSParametersDecl;
+ begin
+ if TPSProcedure(FProcs[ProcNo]).ClassType = TPSInternalProcedure then
+ Decl := TPSInternalProcedure(FProcs[ProcNo]).Decl
+ else
+ Decl := TPSExternalProcedure(FProcs[ProcNo]).RegProc.Decl;
+ UseProc(Decl);
+ Result := TPSValueProcNo.Create;
+ TPSValueProcNo(Result).ProcNo := ProcNo;
+ TPSValueProcNo(Result).ResultType := Decl.Result;
+ with TPSValueProcNo(Result) do
+ begin
+ SetParserPos(FParser);
+ Parameters := TPSParameters.Create;
+ if FSelf <> nil then
+ begin
+ Parameters.Add;
+ end;
+ end;
+
+ if not ReadParameters(False, TPSValueProc(Result).Parameters) then
+ begin
+ FSelf.Free;
+ Result.Free;
+ Result := nil;
+ exit;
+ end;
+
+ if not ValidateParameters(BlockInfo, TPSValueProc(Result).Parameters, Decl) then
+ begin
+ FSelf.Free;
+ Result.Free;
+ Result := nil;
+ exit;
+ end;
+ if FSelf <> nil then
+ begin
+ with TPSValueProcNo(Result).Parameters[0] do
+ begin
+ Val := FSelf;
+ ExpectedType := GetTypeNo(BlockInfo, FSelf);
+ end;
+ end;
+ end;
+ {$IFNDEF PS_NOIDISPATCH}
+
+ function ReadIDispatchParameters(const ProcName: tbtString; aVariantType: TPSVariantType; FSelf: TPSValue): TPSValue;
+ var
+ Par: TPSParameters;
+ PropSet: Boolean;
+ i: Longint;
+ Temp: TPSValue;
+ begin
+ Par := TPSParameters.Create;
+ try
+ if not ReadParameters(FParser.CurrTokenID = CSTI_OpenBlock, Par) then
+ begin
+ FSelf.Free;
+ Result := nil;
+ exit;
+ end;
+
+ if FParser.CurrTokenID = CSTI_Assignment then
+ begin
+ FParser.Next;
+ PropSet := True;
+ Temp := calc(CSTI_SemiColon);
+ if temp = nil then
+ begin
+ FSelf.Free;
+ Result := nil;
+ exit;
+ end;
+ with par.Add do
+ begin
+ FValue := Temp;
+ end;
+ end else
+ begin
+ PropSet := False;
+ end;
+
+ Result := TPSValueProcNo.Create;
+ TPSValueProcNo(Result).ResultType := aVariantType;
+ with TPSValueProcNo(Result) do
+ begin
+ SetParserPos(FParser);
+ Parameters := TPSParameters.Create;
+ if FSelf <> nil then
+ begin
+ with Parameters.Add do
+ begin
+ Val := FSelf;
+ ExpectedType := aVariantType.GetDynIvokeSelfType(Self);
+ end;
+ with Parameters.Add do
+ begin
+ Val := TPSValueData.Create;
+ TPSValueData(Val).Data := NewVariant(FDefaultBoolType);
+ TPSValueData(Val).Data.tu8 := Ord(PropSet);
+ ExpectedType := FDefaultBoolType;
+ end;
+
+ with Parameters.Add do
+ begin
+ Val := TPSValueData.Create;
+ TPSValueData(Val).Data := NewVariant(FindBaseType(btString));
+ tbtString(TPSValueData(Val).data.tString) := Procname;
+ ExpectedType := FindBaseType(btString);
+ end;
+
+ with Parameters.Add do
+ begin
+ val := TPSValueArray.Create;
+ ExpectedType := aVariantType.GetDynInvokeParamType(Self);
+ temp := Val;
+ end;
+ for i := 0 to Par.Count -1 do
+ begin
+ TPSValueArray(Temp).Add(par.Item[i].Val);
+ par.Item[i].val := nil;
+ end;
+ end;
+ end;
+ TPSValueProcNo(Result).ProcNo := aVariantType.GetDynInvokeProcNo(Self, ProcName, TPSValueProcNo(Result).Parameters);
+ finally
+ Par.Free;
+ end;
+
+ end;
+
+ {$ENDIF}
+
+ function ReadVarParameters(ProcNoVar: TPSValue): TPSValue;
+ var
+ Decl: TPSParametersDecl;
+ begin
+ Decl := TPSProceduralType(GetTypeNo(BlockInfo, ProcnoVar)).ProcDef;
+ UseProc(Decl);
+
+ Result := TPSValueProcVal.Create;
+
+ with TPSValueProcVal(Result) do
+ begin
+ ResultType := Decl.Result;
+ ProcNo := ProcNoVar;
+ Parameters := TPSParameters.Create;
+ end;
+
+ if not ReadParameters(False, TPSValueProc(Result).Parameters) then
+ begin
+ Result.Free;
+ Result := nil;
+ exit;
+ end;
+
+ if not ValidateParameters(BlockInfo, TPSValueProc(Result).Parameters, Decl) then
+ begin
+ Result.Free;
+ Result := nil;
+ exit;
+ end;
+ end;
+
+
+ function WriteCalculation(InData, OutReg: TPSValue): Boolean;
+
+ function CheckOutreg(Where, Outreg: TPSValue; aRoot: Boolean): Boolean;
+ var
+ i: Longint;
+ begin
+ Result := False;
+ if Outreg is TPSValueReplace
+ then Outreg:=TPSValueReplace(Outreg).OldValue;
+ if Where is TPSValueVar then begin
+ if TPSValueVar(Where).GetRecCount > 0 then result := true;
+ if SAmeReg(Where, OutReg) and not aRoot then
+ result := true;
+ end else
+ if Where.ClassType = TPSUnValueOp then
+ begin
+ if CheckOutReg(TPSUnValueOp(Where).Val1, OutReg, aRoot) then
+ Result := True;
+ end else if Where.ClassType = TPSBinValueOp then
+ begin
+ if CheckOutreg(TPSBinValueOp(Where).Val1, OutReg, aRoot) or CheckOutreg(TPSBinValueOp(Where).Val2, OutReg, False) then
+ Result := True;
+ end else if Where is TPSValueVar then
+ begin
+ if SameReg(Where, OutReg) then
+ Result := True;
+ end else if Where is TPSValueProc then
+ begin
+ for i := 0 to TPSValueProc(Where).Parameters.Count -1 do
+ begin
+ if Checkoutreg(TPSValueProc(Where).Parameters[i].Val, Outreg, false) then
+ begin
+ Result := True;
+ break;
+ end;
+ end;
+ end;
+ end;
+ begin
+ if not CheckCompatType(Outreg, InData) then
+ begin
+ MakeError('', ecTypeMismatch, '');
+ Result := False;
+ exit;
+ end;
+ if SameReg(OutReg, InData) then
+ begin
+ Result := True;
+ exit;
+ end;
+ if InData is TPSValueProc then
+ begin
+ Result := _ProcessFunction(TPSValueProc(indata), OutReg)
+ end else begin
+ if not PreWriteOutRec(OutReg, nil) then
+ begin
+ Result := False;
+ exit;
+ end;
+ if (not CheckOutReg(InData, OutReg, true)) and (InData is TPSBinValueOp) or (InData is TPSUnValueOp) then
+ begin
+ if InData is TPSBinValueOp then
+ begin
+ if not DoBinCalc(TPSBinValueOp(InData), OutReg) then
+ begin
+ AfterWriteOutRec(OutReg);
+ Result := False;
+ exit;
+ end;
+ end else
+ begin
+ if not DoUnCalc(TPSUnValueOp(InData), OutReg) then
+ begin
+ AfterWriteOutRec(OutReg);
+ Result := False;
+ exit;
+ end;
+ end;
+ end else if (InData is TPSBinValueOp) and (not CheckOutReg(TPSBinValueOp(InData).Val2, OutReg, false)) then
+ begin
+ if not DoBinCalc(TPSBinValueOp(InData), OutReg) then
+ begin
+ AfterWriteOutRec(OutReg);
+ Result := False;
+ exit;
+ end;
+ end else begin
+ if not PreWriteOutRec(InData, GetTypeNo(BlockInfo, OutReg)) then
+ begin
+ Result := False;
+ exit;
+ end;
+ BlockWriteByte(BlockInfo, CM_A);
+ if not (WriteOutRec(OutReg, False) and WriteOutRec(InData, True)) then
+ begin
+ Result := False;
+ exit;
+ end;
+ AfterWriteOutRec(InData);
+ end;
+ AfterWriteOutRec(OutReg);
+ Result := True;
+ end;
+ end; {WriteCalculation}
+
+
+ function _ProcessFunction(ProcCall: TPSValueProc; ResultRegister: TPSValue): Boolean;
+ var
+ res: TPSType;
+ tmp: TPSParameter;
+ lTv: TPSValue;
+ resreg: TPSValue;
+ l: Longint;
+
+ function Cleanup: Boolean;
+ var
+ i: Longint;
+ begin
+ for i := 0 to ProcCall.Parameters.Count -1 do
+ begin
+ if ProcCall.Parameters[i].TempVar <> nil then
+ ProcCall.Parameters[i].TempVar.Free;
+ ProcCall.Parameters[i].TempVar := nil;
+ end;
+ if ProcCall is TPSValueProcVal then
+ AfterWriteOutRec(TPSValueProcVal(ProcCall).fProcNo);
+ if ResReg <> nil then
+ AfterWriteOutRec(resreg);
+ if ResReg <> nil then
+ begin
+ if ResReg <> ResultRegister then
+ begin
+ if ResultRegister <> nil then
+ begin
+ if not WriteCalculation(ResReg, ResultRegister) then
+ begin
+ Result := False;
+ resreg.Free;
+ exit;
+ end;
+ end;
+ resreg.Free;
+ end;
+ end;
+ Result := True;
+ end;
+
+ begin
+ Res := ProcCall.ResultType;
+ Result := False;
+ if (res = nil) and (ResultRegister <> nil) then
+ begin
+ MakeError('', ecNoResult, '');
+ exit;
+ end
+ else if (res <> nil) then
+ begin
+ if (ResultRegister = nil) or (Res <> GetTypeNo(BlockInfo, ResultRegister)) then
+ begin
+ resreg := AllocStackReg(res);
+
+ end else resreg := ResultRegister;
+ end
+ else
+ resreg := nil;
+ if ResReg <> nil then
+ begin
+ if not PreWriteOutRec(resreg, nil) then
+ begin
+ Cleanup;
+ exit;
+ end;
+ end;
+ if Proccall is TPSValueProcVal then
+ begin
+ if not PreWriteOutRec(TPSValueProcVal(ProcCall).fProcNo, nil) then
+ begin
+ Cleanup;
+ exit;
+ end;
+ end;
+ for l := ProcCall.Parameters.Count - 1 downto 0 do
+ begin
+ Tmp := ProcCall.Parameters[l];
+ if (Tmp.ParamMode <> pmIn) then
+ begin
+ if IsVarInCompatible(GetTypeNo(BlockInfo, tmp.Val), tmp.ExpectedType) then
+ begin
+ with MakeError('', ecTypeMismatch, '') do
+ begin
+ pos := tmp.Val.Pos;
+ row := tmp.Val.row;
+ col := tmp.Val.col;
+ end;
+ Cleanup;
+ exit;
+ end;
+ if Copy(tmp.ExpectedType.Name, 1, 10) = '!OPENARRAY' then begin
+ tmp.TempVar := AllocPointer(tmp.ExpectedType);
+ lTv := AllocStackReg(tmp.ExpectedType);
+ if not PreWriteOutRec(Tmp.FValue, nil) then
+ begin
+ cleanup;
+ exit;
+ end;
+ BlockWriteByte(BlockInfo, CM_A);
+ WriteOutRec(lTv, False);
+ WriteOutRec(Tmp.FValue, False);
+ AfterWriteOutRec(Tmp.FValue);
+
+ BlockWriteByte(BlockInfo, cm_sp);
+ WriteOutRec(tmp.TempVar, False);
+ WriteOutRec(lTv, False);
+
+ lTv.Free;
+// BlockWriteByte(BlockInfo, CM_PO); // pop the temp var
+
+ end else begin
+ tmp.TempVar := AllocPointer(GetTypeNo(BlockInfo, Tmp.FValue));
+ if not PreWriteOutRec(Tmp.FValue, nil) then
+ begin
+ cleanup;
+ exit;
+ end;
+ BlockWriteByte(BlockInfo, cm_sp);
+ WriteOutRec(tmp.TempVar, False);
+ WriteOutRec(Tmp.FValue, False);
+ AfterWriteOutRec(Tmp.FValue);
+ end;
+ end
+ else
+ begin
+ if Tmp.ExpectedType = nil then
+ Tmp.ExpectedType := GetTypeNo(BlockInfo, tmp.Val);
+ if Tmp.ExpectedType.BaseType = btPChar then
+ begin
+ Tmp.TempVar := AllocStackReg(at2ut(FindBaseType(btstring)))
+ end else
+ begin
+ Tmp.TempVar := AllocStackReg(Tmp.ExpectedType);
+ end;
+ if not WriteCalculation(Tmp.Val, Tmp.TempVar) then
+ begin
+ Cleanup;
+ exit;
+ end;
+ end;
+ end; {for}
+ if res <> nil then
+ begin
+ BlockWriteByte(BlockInfo, CM_PV);
+
+ if not WriteOutRec(resreg, False) then
+ begin
+ Cleanup;
+ MakeError('', ecInternalError, '00015');
+ exit;
+ end;
+ end;
+ if ProcCall is TPSValueProcVal then
+ begin
+ BlockWriteByte(BlockInfo, Cm_cv);
+ WriteOutRec(TPSValueProcVal(ProcCall).ProcNo, True);
+ end else begin
+ BlockWriteByte(BlockInfo, CM_C);
+ BlockWriteLong(BlockInfo, TPSValueProcNo(ProcCall).ProcNo);
+ end;
+ if res <> nil then
+ BlockWriteByte(BlockInfo, CM_PO);
+ if not Cleanup then
+ begin
+ Result := False;
+ exit;
+ end;
+ Result := True;
+ end; {ProcessVarFunction}
+
+ function HasInvalidJumps(StartPos, EndPos: Cardinal): Boolean;
+ var
+ I, J: Longint;
+ Ok: LongBool;
+ FLabelsInBlock: TIfStringList;
+ s: tbtString;
+ begin
+ FLabelsInBlock := TIfStringList.Create;
+ for i := 0 to BlockInfo.Proc.FLabels.Count -1 do
+ begin
+ s := BlockInfo.Proc.FLabels[I];
+ if (Cardinal((@s[1])^) >= StartPos) and (Cardinal((@s[1])^) <= EndPos) then
+ begin
+ Delete(s, 1, 8);
+ FLabelsInBlock.Add(s);
+ end;
+ end;
+ for i := 0 to BlockInfo.Proc.FGotos.Count -1 do
+ begin
+ s := BlockInfo.Proc.FGotos[I];
+ if (Cardinal((@s[1])^) >= StartPos) and (Cardinal((@s[1])^) <= EndPos) then
+ begin
+ Delete(s, 1, 4);
+ s := BlockInfo.Proc.FLabels[Cardinal((@s[1])^)];
+ Delete(s,1,8);
+ OK := False;
+ for J := 0 to FLabelsInBlock.Count -1 do
+ begin
+ if FLabelsInBlock[J] = s then
+ begin
+ Ok := True;
+ Break;
+ end;
+ end;
+ if not Ok then
+ begin
+ MakeError('', ecInvalidJump, '');
+ Result := True;
+ FLabelsInBlock.Free;
+ exit;
+ end;
+ end else begin
+ Delete(s, 1, 4);
+ s := BlockInfo.Proc.FLabels[Cardinal((@s[1])^)];
+ Delete(s,1,8);
+ OK := True;
+ for J := 0 to FLabelsInBlock.Count -1 do
+ begin
+ if FLabelsInBlock[J] = s then
+ begin
+ Ok := False;
+ Break;
+ end;
+ end;
+ if not Ok then
+ begin
+ MakeError('', ecInvalidJump, '');
+ Result := True;
+ FLabelsInBlock.Free;
+ exit;
+ end;
+ end;
+ end;
+ FLabelsInBlock.Free;
+ Result := False;
+ end;
+
+ function ProcessFor: Boolean;
+ { Process a for x := y to z do }
+ var
+ VariableVar: TPSValue;
+ TempBool,
+ InitVal,
+ finVal: TPSValue;
+ Block: TPSBlockInfo;
+ Backwards: Boolean;
+ FPos, NPos, EPos, RPos: Longint;
+ OldCO, OldBO: TPSList;
+ I: Longint;
+ iOldWithCount: Integer;
+ iOldTryCount: Integer;
+ iOldExFnlCount: Integer;
+ lType: TPSType;
+ begin
+ Debug_WriteLine(BlockInfo);
+ Result := False;
+ FParser.Next;
+ if FParser.CurrTokenId <> CSTI_Identifier then
+ begin
+ MakeError('', ecIdentifierExpected, '');
+ exit;
+ end;
+ VariableVar := GetIdentifier(1);
+ if VariableVar = nil then
+ exit;
+ lType := GetTypeNo(BlockInfo, VariableVar);
+ if lType = nil then begin
+ MakeError('', ecTypeMismatch, '');
+ VariableVar.Free;
+ exit;
+ end;
+ case lType.BaseType of
+ btU8, btS8, btU16, btS16, btU32, btS32, {$IFNDEF PS_NOINT64} btS64, {$ENDIF} btVariant: ;
+ else
+ begin
+ MakeError('', ecTypeMismatch, '');
+ VariableVar.Free;
+ exit;
+ end;
+ end;
+ if FParser.CurrTokenId <> CSTI_Assignment then
+ begin
+ MakeError('', ecAssignmentExpected, '');
+ VariableVar.Free;
+ exit;
+ end;
+ FParser.Next;
+ InitVal := calc(CSTII_DownTo);
+ if InitVal = nil then
+ begin
+ VariableVar.Free;
+ exit;
+ end;
+ if FParser.CurrTokenId = CSTII_To then
+ Backwards := False
+ else if FParser.CurrTokenId = CSTII_DownTo then
+ Backwards := True
+ else
+ begin
+ MakeError('', ecToExpected, '');
+ VariableVar.Free;
+ InitVal.Free;
+ exit;
+ end;
+ FParser.Next;
+ finVal := calc(CSTII_do);
+ if finVal = nil then
+ begin
+ VariableVar.Free;
+ InitVal.Free;
+ exit;
+ end;
+ lType := GetTypeNo(BlockInfo, finVal);
+ if lType = nil then begin
+ MakeError('', ecTypeMismatch, '');
+ VariableVar.Free;
+ InitVal.Free;
+ exit;
+ end;
+ case lType.BaseType of
+ btVariant, btU8, btS8, btU16, btS16, btU32, btS32: ;
+ else
+ begin
+ MakeError('', ecTypeMismatch, '');
+ VariableVar.Free;
+ InitVal.Free;
+ exit;
+ end;
+ end;
+ if FParser.CurrTokenId <> CSTII_do then
+ begin
+ MakeError('', ecDoExpected, '');
+ finVal.Free;
+ InitVal.Free;
+ VariableVar.Free;
+ exit;
+ end;
+ FParser.Next;
+ if not WriteCalculation(InitVal, VariableVar) then
+ begin
+ VariableVar.Free;
+ InitVal.Free;
+ finVal.Free;
+ exit;
+ end;
+ InitVal.Free;
+ TempBool := AllocStackReg(at2ut(FDefaultBoolType));
+ NPos := Length(BlockInfo.Proc.Data);
+ if not (PreWriteOutRec(VariableVar, nil) and PreWriteOutRec(finVal, nil)) then
+ begin
+ TempBool.Free;
+ VariableVar.Free;
+ finVal.Free;
+ exit;
+ end;
+ BlockWriteByte(BlockInfo, CM_CO);
+ if Backwards then
+ begin
+ BlockWriteByte(BlockInfo, 0); { >= }
+ end
+ else
+ begin
+ BlockWriteByte(BlockInfo, 1); { <= }
+ end;
+ if not (WriteOutRec(TempBool, False) and WriteOutRec(VariableVar, True) and WriteOutRec(finVal, True)) then
+ begin
+ TempBool.Free;
+ VariableVar.Free;
+ finVal.Free;
+ exit;
+ end;
+ AfterWriteOutRec(finVal);
+ AfterWriteOutRec(VariableVar);
+ finVal.Free;
+ BlockWriteByte(BlockInfo, Cm_CNG);
+ EPos := Length(BlockInfo.Proc.Data);
+ BlockWriteLong(BlockInfo, $12345678);
+ WriteOutRec(TempBool, False);
+ RPos := Length(BlockInfo.Proc.Data);
+ OldCO := FContinueOffsets;
+ FContinueOffsets := TPSList.Create;
+ OldBO := FBreakOffsets;
+ FBreakOffsets := TPSList.Create;
+ Block := TPSBlockInfo.Create(BlockInfo);
+ Block.SubType := tOneLiner;
+
+ iOldWithCount := FWithCount;
+ FWithCount := 0;
+ iOldTryCount := FTryCount;
+ FTryCount := 0;
+ iOldExFnlCount := FExceptFinallyCount;
+ FExceptFinallyCount := 0;
+
+ if not ProcessSub(Block) then
+ begin
+ Block.Free;
+ TempBool.Free;
+ VariableVar.Free;
+ FBreakOffsets.Free;
+ FContinueOffsets.Free;
+ FContinueOffsets := OldCO;
+ FBreakOffsets := OldBo;
+
+ FWithCount := iOldWithCount;
+ FTryCount := iOldTryCount;
+ FExceptFinallyCount := iOldExFnlCount;
+
+ exit;
+ end;
+ Block.Free;
+ FPos := Length(BlockInfo.Proc.Data);
+ if not PreWriteOutRec(VariableVar, nil) then
+ begin
+ TempBool.Free;
+ VariableVar.Free;
+ FBreakOffsets.Free;
+ FContinueOffsets.Free;
+ FContinueOffsets := OldCO;
+ FBreakOffsets := OldBo;
+
+ FWithCount := iOldWithCount;
+ FTryCount := iOldTryCount;
+ FExceptFinallyCount := iOldExFnlCount;
+
+ exit;
+ end;
+ if Backwards then
+ BlockWriteByte(BlockInfo, cm_dec)
+ else
+ BlockWriteByte(BlockInfo, cm_inc);
+ if not WriteOutRec(VariableVar, False) then
+ begin
+ TempBool.Free;
+ VariableVar.Free;
+ FBreakOffsets.Free;
+ FContinueOffsets.Free;
+ FContinueOffsets := OldCO;
+ FBreakOffsets := OldBo;
+
+ FWithCount := iOldWithCount;
+ FTryCount := iOldTryCount;
+ FExceptFinallyCount := iOldExFnlCount;
+
+ exit;
+ end;
+ AfterWriteOutRec(VariableVar);
+ BlockWriteByte(BlockInfo, Cm_G);
+ BlockWriteLong(BlockInfo, Longint(NPos - Length(BlockInfo.Proc.Data) - 4));
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ unaligned(Longint((@BlockInfo.Proc.Data[EPos + 1])^)) := Length(BlockInfo.Proc.Data) - RPos;
+ {$else}
+ Longint((@BlockInfo.Proc.Data[EPos + 1])^) := Length(BlockInfo.Proc.Data) - RPos;
+ {$endif}
+ for i := 0 to FBreakOffsets.Count -1 do
+ begin
+ EPos := IPointer(FBreakOffsets[I]);
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(EPos);
+ {$else}
+ Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos);
+ {$endif}
+ end;
+ for i := 0 to FContinueOffsets.Count -1 do
+ begin
+ EPos := IPointer(FContinueOffsets[I]);
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Longint(FPos) - Longint(EPos);
+ {$else}
+ Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(FPos) - Longint(EPos);
+ {$endif}
+ end;
+ FBreakOffsets.Free;
+ FContinueOffsets.Free;
+ FContinueOffsets := OldCO;
+ FBreakOffsets := OldBo;
+
+ FWithCount := iOldWithCount;
+ FTryCount := iOldTryCount;
+ FExceptFinallyCount := iOldExFnlCount;
+
+ TempBool.Free;
+ VariableVar.Free;
+ if HasInvalidJumps(RPos, Length(BlockInfo.Proc.Data)) then
+ begin
+ Result := False;
+ exit;
+ end;
+ Result := True;
+ end; {ProcessFor}
+
+ function ProcessWhile: Boolean;
+ var
+ vin, vout: TPSValue;
+ SPos, EPos: Cardinal;
+ OldCo, OldBO: TPSList;
+ I: Longint;
+ Block: TPSBlockInfo;
+
+ iOldWithCount: Integer;
+ iOldTryCount: Integer;
+ iOldExFnlCount: Integer;
+
+ begin
+ Result := False;
+ Debug_WriteLine(BlockInfo);
+ FParser.Next;
+ vout := calc(CSTII_do);
+ if vout = nil then
+ exit;
+ if FParser.CurrTokenId <> CSTII_do then
+ begin
+ vout.Free;
+ MakeError('', ecDoExpected, '');
+ exit;
+ end;
+ vin := AllocStackReg(at2ut(FDefaultBoolType));
+ SPos := Length(BlockInfo.Proc.Data); // start position
+ OldCo := FContinueOffsets;
+ FContinueOffsets := TPSList.Create;
+ OldBO := FBreakOffsets;
+ FBreakOffsets := TPSList.Create;
+ if not WriteCalculation(vout, vin) then
+ begin
+ vout.Free;
+ vin.Free;
+ FBreakOffsets.Free;
+ FContinueOffsets.Free;
+ FContinueOffsets := OldCO;
+ FBreakOffsets := OldBo;
+ exit;
+ end;
+ vout.Free;
+ FParser.Next; // skip DO
+ BlockWriteByte(BlockInfo, Cm_CNG); // only goto if expression is false
+ BlockWriteLong(BlockInfo, $12345678);
+ EPos := Length(BlockInfo.Proc.Data);
+ if not WriteOutRec(vin, False) then
+ begin
+ MakeError('', ecInternalError, '00017');
+ vin.Free;
+ FBreakOffsets.Free;
+ FContinueOffsets.Free;
+ FContinueOffsets := OldCO;
+ FBreakOffsets := OldBo;
+ exit;
+ end;
+ Block := TPSBlockInfo.Create(BlockInfo);
+ Block.SubType := tOneLiner;
+
+ iOldWithCount := FWithCount;
+ FWithCount := 0;
+ iOldTryCount := FTryCount;
+ FTryCount := 0;
+ iOldExFnlCount := FExceptFinallyCount;
+ FExceptFinallyCount := 0;
+
+ if not ProcessSub(Block) then
+ begin
+ Block.Free;
+ vin.Free;
+ FBreakOffsets.Free;
+ FContinueOffsets.Free;
+ FContinueOffsets := OldCO;
+ FBreakOffsets := OldBo;
+
+ FWithCount := iOldWithCount;
+ FTryCount := iOldTryCount;
+ FExceptFinallyCount := iOldExFnlCount;
+
+ exit;
+ end;
+ Block.Free;
+ Debug_WriteLine(BlockInfo);
+ BlockWriteByte(BlockInfo, Cm_G);
+ BlockWriteLong(BlockInfo, Longint(SPos) - Length(BlockInfo.Proc.Data) - 4);
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(EPos) - 5;
+ {$else}
+ Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos) - 5;
+ {$endif}
+ for i := 0 to FBreakOffsets.Count -1 do
+ begin
+ EPos := Cardinal(FBreakOffsets[I]);
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(EPos);
+ {$else}
+ Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos);
+ {$endif}
+ end;
+ for i := 0 to FContinueOffsets.Count -1 do
+ begin
+ EPos := Cardinal(FContinueOffsets[I]);
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Longint(SPos) - Longint(EPos);
+ {$else}
+ Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(SPos) - Longint(EPos);
+ {$endif}
+ end;
+ FBreakOffsets.Free;
+ FContinueOffsets.Free;
+ FContinueOffsets := OldCO;
+ FBreakOffsets := OldBo;
+
+ FWithCount := iOldWithCount;
+ FTryCount := iOldTryCount;
+ FExceptFinallyCount := iOldExFnlCount;
+
+ vin.Free;
+ if HasInvalidJumps(EPos, Length(BlockInfo.Proc.Data)) then
+ begin
+ Result := False;
+ exit;
+ end;
+ Result := True;
+ end;
+
+ function ProcessRepeat: Boolean;
+ var
+ vin, vout: TPSValue;
+ CPos, SPos, EPos: Cardinal;
+ I: Longint;
+ OldCo, OldBO: TPSList;
+ Block: TPSBlockInfo;
+
+ iOldWithCount: Integer;
+ iOldTryCount: Integer;
+ iOldExFnlCount: Integer;
+
+ begin
+ Result := False;
+ Debug_WriteLine(BlockInfo);
+ FParser.Next;
+ OldCo := FContinueOffsets;
+ FContinueOffsets := TPSList.Create;
+ OldBO := FBreakOffsets;
+ FBreakOffsets := TPSList.Create;
+ vin := AllocStackReg(at2ut(FDefaultBoolType));
+ SPos := Length(BlockInfo.Proc.Data);
+ Block := TPSBlockInfo.Create(BlockInfo);
+ Block.SubType := tRepeat;
+
+ iOldWithCount := FWithCount;
+ FWithCount := 0;
+ iOldTryCount := FTryCount;
+ FTryCount := 0;
+ iOldExFnlCount := FExceptFinallyCount;
+ FExceptFinallyCount := 0;
+
+ if not ProcessSub(Block) then
+ begin
+ Block.Free;
+ FBreakOffsets.Free;
+ FContinueOffsets.Free;
+ FContinueOffsets := OldCO;
+ FBreakOffsets := OldBo;
+
+ FWithCount := iOldWithCount;
+ FTryCount := iOldTryCount;
+ FExceptFinallyCount := iOldExFnlCount;
+
+ vin.Free;
+ exit;
+ end;
+ Block.Free;
+ FParser.Next; //cstii_until
+ vout := calc(CSTI_Semicolon);
+ if vout = nil then
+ begin
+ FBreakOffsets.Free;
+ FContinueOffsets.Free;
+ FContinueOffsets := OldCO;
+ FBreakOffsets := OldBo;
+
+ FWithCount := iOldWithCount;
+ FTryCount := iOldTryCount;
+ FExceptFinallyCount := iOldExFnlCount;
+
+ vin.Free;
+ exit;
+ end;
+ CPos := Length(BlockInfo.Proc.Data);
+ if not WriteCalculation(vout, vin) then
+ begin
+ vout.Free;
+ vin.Free;
+ FBreakOffsets.Free;
+ FContinueOffsets.Free;
+ FContinueOffsets := OldCO;
+ FBreakOffsets := OldBo;
+
+ FWithCount := iOldWithCount;
+ FTryCount := iOldTryCount;
+ FExceptFinallyCount := iOldExFnlCount;
+
+ exit;
+ end;
+ vout.Free;
+ BlockWriteByte(BlockInfo, Cm_CNG);
+ BlockWriteLong(BlockInfo, $12345678);
+ EPos := Length(BlockInfo. Proc.Data);
+ if not WriteOutRec(vin, False) then
+ begin
+ MakeError('', ecInternalError, '00016');
+ vin.Free;
+ FBreakOffsets.Free;
+ FContinueOffsets.Free;
+ FContinueOffsets := OldCO;
+ FBreakOffsets := OldBo;
+
+ FWithCount := iOldWithCount;
+ FTryCount := iOldTryCount;
+ FExceptFinallyCount := iOldExFnlCount;
+
+ exit;
+ end;
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Longint(SPos) -
+ Length(BlockInfo.Proc.Data);
+ {$else}
+ Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(SPos) -
+ Length(BlockInfo.Proc.Data);
+ {$endif}
+ for i := 0 to FBreakOffsets.Count -1 do
+ begin
+ EPos := Cardinal(FBreakOffsets[I]);
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Length(BlockInfo. Proc.Data) - Longint(EPos);
+ {$else}
+ Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo. Proc.Data) - Longint(EPos);
+ {$endif}
+ end;
+ for i := 0 to FContinueOffsets.Count -1 do
+ begin
+ EPos := Cardinal(FContinueOffsets[I]);
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Longint(CPos) - Longint(EPos);
+ {$else}
+ Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(CPos) - Longint(EPos);
+ {$endif}
+ end;
+ FBreakOffsets.Free;
+ FContinueOffsets.Free;
+ FContinueOffsets := OldCO;
+ FBreakOffsets := OldBo;
+
+ FWithCount := iOldWithCount;
+ FTryCount := iOldTryCount;
+ FExceptFinallyCount := iOldExFnlCount;
+
+ vin.Free;
+ if HasInvalidJumps(SPos, Length(BlockInfo. Proc.Data)) then
+ begin
+ Result := False;
+ exit;
+ end;
+ Result := True;
+ end; {ProcessRepeat}
+
+ function ProcessIf: Boolean;
+ var
+ vout, vin: TPSValue;
+ SPos, EPos: Cardinal;
+ Block: TPSBlockInfo;
+ begin
+ Result := False;
+ Debug_WriteLine(BlockInfo);
+ FParser.Next;
+ vout := calc(CSTII_Then);
+ if vout = nil then
+ exit;
+ if FParser.CurrTokenId <> CSTII_Then then
+ begin
+ vout.Free;
+ MakeError('', ecThenExpected, '');
+ exit;
+ end;
+ vin := AllocStackReg(at2ut(FDefaultBoolType));
+ if not WriteCalculation(vout, vin) then
+ begin
+ vout.Free;
+ vin.Free;
+ exit;
+ end;
+ vout.Free;
+ BlockWriteByte(BlockInfo, cm_sf);
+ if not WriteOutRec(vin, False) then
+ begin
+ MakeError('', ecInternalError, '00018');
+ vin.Free;
+ exit;
+ end;
+ BlockWriteByte(BlockInfo, 1);
+ vin.Free;
+ BlockWriteByte(BlockInfo, cm_fg);
+ BlockWriteLong(BlockInfo, $12345678);
+ SPos := Length(BlockInfo.Proc.Data);
+ FParser.Next; // skip then
+ Block := TPSBlockInfo.Create(BlockInfo);
+ Block.SubType := tifOneliner;
+ if not ProcessSub(Block) then
+ begin
+ Block.Free;
+ exit;
+ end;
+ Block.Free;
+ if FParser.CurrTokenId = CSTII_Else then
+ begin
+ BlockWriteByte(BlockInfo, Cm_G);
+ BlockWriteLong(BlockInfo, $12345678);
+ EPos := Length(BlockInfo.Proc.Data);
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ unaligned(Longint((@BlockInfo.Proc.Data[SPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(SPos);
+ {$else}
+ Longint((@BlockInfo.Proc.Data[SPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(SPos);
+ {$endif}
+ FParser.Next;
+ Block := TPSBlockInfo.Create(BlockInfo);
+ Block.SubType := tOneLiner;
+ if not ProcessSub(Block) then
+ begin
+ Block.Free;
+ exit;
+ end;
+ Block.Free;
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(EPos);
+ {$else}
+ Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos);
+ {$endif}
+ end
+ else
+ begin
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ unaligned(Longint((@BlockInfo.Proc.Data[SPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(SPos) + 5 - 5;
+ {$else}
+ Longint((@BlockInfo.Proc.Data[SPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(SPos) + 5 - 5;
+ {$endif}
+ end;
+ Result := True;
+ end; {ProcessIf}
+
+ function _ProcessLabel: Longint; {0 = failed; 1 = successful; 2 = no label}
+ var
+ I, H: Longint;
+ s: tbtString;
+ begin
+ h := MakeHash(FParser.GetToken);
+ for i := 0 to BlockInfo.Proc.FLabels.Count -1 do
+ begin
+ s := BlockInfo.Proc.FLabels[I];
+ delete(s, 1, 4);
+ if Longint((@s[1])^) = h then
+ begin
+ delete(s, 1, 4);
+ if s = FParser.GetToken then
+ begin
+ s := BlockInfo.Proc.FLabels[I];
+ Cardinal((@s[1])^) := Length(BlockInfo.Proc.Data);
+ BlockInfo.Proc.FLabels[i] := s;
+ FParser.Next;
+ if fParser.CurrTokenId = CSTI_Colon then
+ begin
+ Result := 1;
+ FParser.Next;
+ exit;
+ end else begin
+ MakeError('', ecColonExpected, '');
+ Result := 0;
+ Exit;
+ end;
+ end;
+ end;
+ end;
+ result := 2;
+ end;
+
+ function ProcessIdentifier: Boolean;
+ var
+ vin, vout: TPSValue;
+ begin
+ Result := False;
+ Debug_WriteLine(BlockInfo);
+ vin := GetIdentifier(2);
+ if vin <> nil then
+ begin
+ if vin is TPSValueVar then
+ begin // assignment needed
+ if FParser.CurrTokenId <> CSTI_Assignment then
+ begin
+ MakeError('', ecAssignmentExpected, '');
+ vin.Free;
+ exit;
+ end;
+ FParser.Next;
+ vout := calc(CSTI_Semicolon);
+ if vout = nil then
+ begin
+ vin.Free;
+ exit;
+ end;
+ if not WriteCalculation(vout, vin) then
+ begin
+ vin.Free;
+ vout.Free;
+ exit;
+ end;
+ vin.Free;
+ vout.Free;
+ end else if vin is TPSValueProc then
+ begin
+ Result := _ProcessFunction(TPSValueProc(vin), nil);
+ vin.Free;
+ Exit;
+ end else
+ begin
+ MakeError('', ecInternalError, '20');
+ vin.Free;
+ REsult := False;
+ exit;
+ end;
+ end
+ else
+ begin
+ Result := False;
+ exit;
+ end;
+ Result := True;
+ end; {ProcessIdentifier}
+
+ function ProcessCase: Boolean;
+ var
+ V1, V2, TempRec, Val, CalcItem: TPSValue;
+ p: TPSBinValueOp;
+ SPos, CurrP: Cardinal;
+ I: Longint;
+ EndReloc: TPSList;
+ Block: TPSBlockInfo;
+
+ function NewRec(val: TPSValue): TPSValueReplace;
+ begin
+ Result := TPSValueReplace.Create;
+ Result.SetParserPos(FParser);
+ Result.FNewValue := Val;
+ Result.FreeNewValue := False;
+ end;
+
+ function Combine(v1, v2: TPSValue; Op: TPSBinOperatorType): TPSValue;
+ begin
+ if V1 = nil then
+ begin
+ Result := v2;
+ end else if v2 = nil then
+ begin
+ Result := V1;
+ end else
+ begin
+ Result := TPSBinValueOp.Create;
+ TPSBinValueOp(Result).FType := FDefaultBoolType;
+ TPSBinValueOp(Result).Operator := Op;
+ Result.SetParserPos(FParser);
+ TPSBinValueOp(Result).FVal1 := V1;
+ TPSBinValueOp(Result).FVal2 := V2;
+ end;
+ end;
+
+
+ begin
+ Debug_WriteLine(BlockInfo);
+ FParser.Next;
+ Val := calc(CSTII_of);
+ if Val = nil then
+ begin
+ ProcessCase := False;
+ exit;
+ end; {if}
+ if FParser.CurrTokenId <> CSTII_Of then
+ begin
+ MakeError('', ecOfExpected, '');
+ val.Free;
+ ProcessCase := False;
+ exit;
+ end; {if}
+ FParser.Next;
+ TempRec := AllocStackReg(GetTypeNo(BlockInfo, Val));
+ if not WriteCalculation(Val, TempRec) then
+ begin
+ TempRec.Free;
+ val.Free;
+ ProcessCase := False;
+ exit;
+ end; {if}
+ val.Free;
+ EndReloc := TPSList.Create;
+ CalcItem := AllocStackReg(at2ut(FDefaultBoolType));
+ SPos := Length(BlockInfo.Proc.Data);
+ repeat
+ V1 := nil;
+ while true do
+ begin
+ Val := calc(CSTI_Colon);
+ if (Val = nil) then
+ begin
+ V1.Free;
+ CalcItem.Free;
+ TempRec.Free;
+ EndReloc.Free;
+ ProcessCase := False;
+ exit;
+ end; {if}
+ if fParser.CurrTokenID = CSTI_TwoDots then begin
+ FParser.Next;
+ V2 := Calc(CSTI_colon);
+ if V2 = nil then begin
+ V1.Free;
+ CalcItem.Free;
+ TempRec.Free;
+ EndReloc.Free;
+ ProcessCase := False;
+ Val.Free;
+ exit;
+ end;
+ p := TPSBinValueOp.Create;
+ p.SetParserPos(FParser);
+ p.Operator := otGreaterEqual;
+ p.aType := at2ut(FDefaultBoolType);
+ p.Val2 := Val;
+ p.Val1 := NewRec(TempRec);
+ Val := p;
+ p := TPSBinValueOp.Create;
+ p.SetParserPos(FParser);
+ p.Operator := otLessEqual;
+ p.aType := at2ut(FDefaultBoolType);
+ p.Val2 := V2;
+ p.Val1 := NewRec(TempRec);
+ P := TPSBinValueOp(Combine(Val,P, otAnd));
+ end else begin
+ p := TPSBinValueOp.Create;
+ p.SetParserPos(FParser);
+ p.Operator := otEqual;
+ p.aType := at2ut(FDefaultBoolType);
+ p.Val1 := Val;
+ p.Val2 := NewRec(TempRec);
+ end;
+ V1 := Combine(V1, P, otOr);
+ if FParser.CurrTokenId = CSTI_Colon then Break;
+ if FParser.CurrTokenID <> CSTI_Comma then
+ begin
+ MakeError('', ecColonExpected, '');
+ V1.Free;
+ CalcItem.Free;
+ TempRec.Free;
+ EndReloc.Free;
+ ProcessCase := False;
+ exit;
+ end;
+ FParser.Next;
+ end;
+ FParser.Next;
+ if not WriteCalculation(V1, CalcItem) then
+ begin
+ CalcItem.Free;
+ v1.Free;
+ EndReloc.Free;
+ ProcessCase := False;
+ exit;
+ end;
+ v1.Free;
+ BlockWriteByte(BlockInfo, Cm_CNG);
+ BlockWriteLong(BlockInfo, $12345678);
+ CurrP := Length(BlockInfo.Proc.Data);
+ WriteOutRec(CalcItem, False);
+ Block := TPSBlockInfo.Create(BlockInfo);
+ Block.SubType := tifOneliner;
+ if not ProcessSub(Block) then
+ begin
+ Block.Free;
+ CalcItem.Free;
+ TempRec.Free;
+ EndReloc.Free;
+ ProcessCase := False;
+ exit;
+ end;
+ Block.Free;
+ BlockWriteByte(BlockInfo, Cm_G);
+ BlockWriteLong(BlockInfo, $12345678);
+ EndReloc.Add(Pointer(Length(BlockInfo.Proc.Data)));
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ unaligned(Cardinal((@BlockInfo.Proc.Data[CurrP - 3])^)) := Cardinal(Length(BlockInfo.Proc.Data)) - CurrP - 5;
+ {$else}
+ Cardinal((@BlockInfo.Proc.Data[CurrP - 3])^) := Cardinal(Length(BlockInfo.Proc.Data)) - CurrP - 5;
+ {$endif}
+ if FParser.CurrTokenID = CSTI_Semicolon then FParser.Next;
+ if FParser.CurrTokenID = CSTII_Else then
+ begin
+ FParser.Next;
+ Block := TPSBlockInfo.Create(BlockInfo);
+ Block.SubType := tOneliner;
+ if not ProcessSub(Block) then
+ begin
+ Block.Free;
+ CalcItem.Free;
+ TempRec.Free;
+ EndReloc.Free;
+ ProcessCase := False;
+ exit;
+ end;
+ Block.Free;
+ if FParser.CurrTokenID = CSTI_Semicolon then FParser.Next;
+ if FParser.CurrtokenId <> CSTII_End then
+ begin
+ MakeError('', ecEndExpected, '');
+ CalcItem.Free;
+ TempRec.Free;
+ EndReloc.Free;
+ ProcessCase := False;
+ exit;
+ end;
+ end;
+ until FParser.CurrTokenID = CSTII_End;
+ FParser.Next;
+ for i := 0 to EndReloc.Count -1 do
+ begin
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ unaligned(Cardinal((@BlockInfo.Proc.Data[Cardinal(EndReloc[I])- 3])^)) := Cardinal(Length(BlockInfo.Proc.Data)) - Cardinal(EndReloc[I]);
+ {$else}
+ Cardinal((@BlockInfo.Proc.Data[Cardinal(EndReloc[I])- 3])^) := Cardinal(Length(BlockInfo.Proc.Data)) - Cardinal(EndReloc[I]);
+ {$endif}
+ end;
+ CalcItem.Free;
+ TempRec.Free;
+ EndReloc.Free;
+ if FContinueOffsets <> nil then
+ begin
+ for i := 0 to FContinueOffsets.Count -1 do
+ begin
+ if Cardinal(FContinueOffsets[i]) >= SPos then
+ begin
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ unaligned(Byte((@BlockInfo.Proc.Data[Longint(FContinueOffsets[i]) - 4])^)) := Cm_P2G;
+ {$else}
+ Byte((@BlockInfo.Proc.Data[Longint(FContinueOffsets[i]) - 4])^) := Cm_P2G;
+ {$endif}
+ end;
+ end;
+ end;
+ if FBreakOffsets <> nil then
+ begin
+ for i := 0 to FBreakOffsets.Count -1 do
+ begin
+ if Cardinal(FBreakOffsets[i]) >= SPos then
+ begin
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ unaligned(Byte((@BlockInfo.Proc.Data[Longint(FBreakOffsets[i]) - 4])^)) := Cm_P2G;
+ {$else}
+ Byte((@BlockInfo.Proc.Data[Longint(FBreakOffsets[i]) - 4])^) := Cm_P2G;
+ {$endif}
+ end;
+ end;
+ end;
+ if HasInvalidJumps(SPos, Length(BlockInfo.Proc.Data)) then
+ begin
+ Result := False;
+ exit;
+ end;
+ Result := True;
+ end; {ProcessCase}
+ function ProcessGoto: Boolean;
+ var
+ I, H: Longint;
+ s: tbtString;
+ begin
+ Debug_WriteLine(BlockInfo);
+ FParser.Next;
+ h := MakeHash(FParser.GetToken);
+ for i := 0 to BlockInfo.Proc.FLabels.Count -1 do
+ begin
+ s := BlockInfo.Proc.FLabels[I];
+ delete(s, 1, 4);
+ if Longint((@s[1])^) = h then
+ begin
+ delete(s, 1, 4);
+ if s = FParser.GetToken then
+ begin
+ FParser.Next;
+ BlockWriteByte(BlockInfo, Cm_G);
+ BlockWriteLong(BlockInfo, $12345678);
+ BlockInfo.Proc.FGotos.Add(PS_mi2s(length(BlockInfo.Proc.Data))+PS_mi2s(i));
+ Result := True;
+ exit;
+ end;
+ end;
+ end;
+ MakeError('', ecUnknownIdentifier, FParser.OriginalToken);
+ Result := False;
+ end; {ProcessGoto}
+
+ function ProcessWith: Boolean;
+ var
+ Block: TPSBlockInfo;
+ aVar, aReplace: TPSValue;
+ aType: TPSType;
+
+ iStartOffset: Integer;
+
+ tmp: TPSValue;
+ begin
+ Debug_WriteLine(BlockInfo);
+ Block := TPSBlockInfo.Create(BlockInfo);
+ Block.SubType := tOneLiner;
+
+ FParser.Next;
+ repeat
+ aVar := GetIdentifier(0);
+ if aVar = nil then
+ begin
+ block.Free;
+ Result := False;
+ exit;
+ end;
+ AType := GetTypeNo(BlockInfo, aVar);
+ if (AType = nil) or ((aType.BaseType <> btRecord) and (aType.BaseType <> btClass)) then
+ begin
+ MakeError('', ecClassTypeExpected, '');
+ Block.Free;
+ Result := False;
+ exit;
+ end;
+
+ aReplace := TPSValueReplace.Create;
+ aReplace.SetParserPos(FParser);
+ TPSValueReplace(aReplace).FreeOldValue := True;
+ TPSValueReplace(aReplace).FreeNewValue := True;
+ TPSValueReplace(aReplace).OldValue := aVar;
+
+ //if aVar.InheritsFrom(TPSVar) then TPSVar(aVar).Use;
+ tmp := AllocPointer(GetTypeNo(BlockInfo, aVar));
+ TPSProcVar(BlockInfo.Proc.ProcVars[TPSValueAllocatedStackVar(tmp).LocalVarNo]).Use;
+ PreWriteOutRec(tmp,GetTypeNo(BlockInfo, tmp));
+ PreWriteOutRec(aVar,GetTypeNo(BlockInfo, aVar));
+ BlockWriteByte(BlockInfo, cm_sp);
+ WriteOutRec(tmp, false);
+ WriteOutRec(aVar, false);
+ TPSValueReplace(aReplace).NewValue := tmp;
+
+
+
+ Block.WithList.Add(aReplace);
+
+ if FParser.CurrTokenID = CSTII_do then
+ begin
+ FParser.Next;
+ Break;
+ end else
+ if FParser.CurrTokenId <> CSTI_Comma then
+ begin
+ MakeError('', ecDoExpected, '');
+ Block.Free;
+ Result := False;
+ exit;
+ end;
+ FParser.Next;
+ until False;
+
+
+ inc(FWithCount);
+
+ iStartOffset := Length(Block.Proc.Data);
+
+ if not (ProcessSub(Block) and (not HasInvalidJumps(iStartOffset,Length(BlockInfo.Proc.Data) + 1)) ) then
+ begin
+ dec(FWithCount);
+ Block.Free;
+ Result := False;
+ exit;
+ end;
+ dec(FWithCount);
+
+ AfterWriteOutRec(aVar);
+ AfterWriteOutRec(tmp);
+ Block.Free;
+ Result := True;
+ end;
+
+ function ProcessTry: Boolean;
+ var
+ FStartOffset: Cardinal;
+ iBlockStartOffset: Integer;
+ Block: TPSBlockInfo;
+ begin
+ FParser.Next;
+ BlockWriteByte(BlockInfo, cm_puexh);
+ FStartOffset := Length(BlockInfo.Proc.Data) + 1;
+ BlockWriteLong(BlockInfo, InvalidVal);
+ BlockWriteLong(BlockInfo, InvalidVal);
+ BlockWriteLong(BlockInfo, InvalidVal);
+ BlockWriteLong(BlockInfo, InvalidVal);
+ Block := TPSBlockInfo.Create(BlockInfo);
+ Block.SubType := tTry;
+ inc(FTryCount);
+ if ProcessSub(Block) and (not HasInvalidJumps(FStartOffset,Length(BlockInfo.Proc.Data) + 1)) then
+ begin
+ dec(FTryCount);
+ Block.Free;
+ BlockWriteByte(BlockInfo, cm_poexh);
+ BlockWriteByte(BlockInfo, 0);
+ if FParser.CurrTokenID = CSTII_Except then
+ begin
+ FParser.Next;
+ Cardinal((@BlockInfo.Proc.Data[FStartOffset + 4])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15;
+ iBlockStartOffset := Length(BlockInfo.Proc.Data) ;
+ Block := TPSBlockInfo.Create(BlockInfo);
+ Block.SubType := tTryEnd;
+ inc(FExceptFinallyCount);
+ if ProcessSub(Block) and (not HasInvalidJumps(iBlockStartOffset,Length(BlockInfo.Proc.Data) + 1)) then
+ begin
+ dec(FExceptFinallyCount);
+ Block.Free;
+ BlockWriteByte(BlockInfo, cm_poexh);
+ BlockWriteByte(BlockInfo, 2);
+ if FParser.CurrTokenId = CSTII_Finally then
+ begin
+ Cardinal((@BlockInfo.Proc.Data[FStartOffset + 8])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15;
+ iBlockStartOffset := Length(BlockInfo.Proc.Data) ;
+ Block := TPSBlockInfo.Create(BlockInfo);
+ Block.SubType := tTryEnd;
+ FParser.Next;
+ inc(FExceptFinallyCount);
+ if ProcessSub(Block) and (not HasInvalidJumps(iBlockStartOffset,Length(BlockInfo.Proc.Data) + 1)) then
+ begin
+ dec(FExceptFinallyCount);
+ Block.Free;
+ if FParser.CurrTokenId = CSTII_End then
+ begin
+ BlockWriteByte(BlockInfo, cm_poexh);
+ BlockWriteByte(BlockInfo, 3);
+ end else begin
+ MakeError('', ecEndExpected, '');
+ Result := False;
+ exit;
+ end;
+ end else
+ begin
+ Block.Free;
+ Result := False;
+ dec(FExceptFinallyCount);
+ exit;
+ end;
+ end else if FParser.CurrTokenID <> CSTII_End then
+ begin
+ MakeError('', ecEndExpected, '');
+ Result := False;
+ exit;
+ end;
+ FParser.Next;
+ end else
+ begin
+ Block.Free;
+ Result := False;
+ dec(FExceptFinallyCount);
+ exit;
+ end;
+ end else if FParser.CurrTokenId = CSTII_Finally then
+ begin
+ FParser.Next;
+ Cardinal((@BlockInfo.Proc.Data[FStartOffset])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15;
+ iBlockStartOffset := Length(BlockInfo.Proc.Data) ;
+ Block := TPSBlockInfo.Create(BlockInfo);
+ Block.SubType := tTryEnd;
+ inc(FExceptFinallyCount);
+ if ProcessSub(Block) and (not HasInvalidJumps(iBlockStartOffset,Length(BlockInfo.Proc.Data) + 1)) then
+ begin
+ dec(FExceptFinallyCount);
+ Block.Free;
+ BlockWriteByte(BlockInfo, cm_poexh);
+ BlockWriteByte(BlockInfo, 1);
+ if FParser.CurrTokenId = CSTII_Except then
+ begin
+ Cardinal((@BlockInfo.Proc.Data[FStartOffset + 4])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15;
+ iBlockStartOffset := Length(BlockInfo.Proc.Data) ;
+ FParser.Next;
+ Block := TPSBlockInfo.Create(BlockInfo);
+ Block.SubType := tTryEnd;
+ inc(FExceptFinallyCount);
+ if ProcessSub(Block) and (not HasInvalidJumps(iBlockStartOffset,Length(BlockInfo.Proc.Data) + 1)) then
+ begin
+ dec(FExceptFinallyCount);
+ Block.Free;
+ if FParser.CurrTokenId = CSTII_End then
+ begin
+ BlockWriteByte(BlockInfo, cm_poexh);
+ BlockWriteByte(BlockInfo, 2);
+ end else begin
+ MakeError('', ecEndExpected, '');
+ Result := False;
+ exit;
+ end;
+ end else
+ begin
+ Block.Free;
+ Result := False;
+ dec(FExceptFinallyCount);
+ exit;
+ end;
+ end else if FParser.CurrTokenID <> CSTII_End then
+ begin
+ MakeError('', ecEndExpected, '');
+ Result := False;
+ exit;
+ end;
+ FParser.Next;
+ end else
+ begin
+ Block.Free;
+ Result := False;
+ dec(FExceptFinallyCount);
+ exit;
+ end;
+ end;
+ end else
+ begin
+ Block.Free;
+ Result := False;
+ dec(FTryCount);
+ exit;
+ end;
+ Cardinal((@BlockInfo.Proc.Data[FStartOffset + 12])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15;
+ Result := True;
+ end; {ProcessTry}
+
+var
+ i: Integer;
+ Block: TPSBlockInfo;
+
+begin
+ ProcessSub := False;
+ if (BlockInfo.SubType = tProcBegin) or (BlockInfo.SubType= tMainBegin) or
+{$IFDEF PS_USESSUPPORT}
+ (BlockInfo.SubType = tUnitInit) or (BlockInfo.SubType= tUnitFinish) or // NvdS
+{$endif}
+ (BlockInfo.SubType= tSubBegin) then
+ begin
+ FParser.Next; // skip CSTII_Begin
+ end;
+ while True do
+ begin
+ case FParser.CurrTokenId of
+ CSTII_Goto:
+ begin
+ if not ProcessGoto then
+ Exit;
+ if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
+ break;
+ end;
+ CSTII_With:
+ begin
+ if not ProcessWith then
+ Exit;
+ if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
+ break;
+ end;
+ CSTII_Try:
+ begin
+ if not ProcessTry then
+ Exit;
+ if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
+ break;
+ end;
+ CSTII_Finally, CSTII_Except:
+ begin
+ if (BlockInfo.SubType = tTry) or (BlockInfo.SubType = tTryEnd) then
+ Break
+ else
+ begin
+ MakeError('', ecEndExpected, '');
+ Exit;
+ end;
+ end;
+ CSTII_Begin:
+ begin
+ Block := TPSBlockInfo.Create(BlockInfo);
+ Block.SubType := tSubBegin;
+ if not ProcessSub(Block) then
+ begin
+ Block.Free;
+ Exit;
+ end;
+ Block.Free;
+
+ FParser.Next; // skip END
+ if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
+ break;
+ end;
+ CSTI_Semicolon:
+ begin
+
+ if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
+ break
+ else FParser.Next;
+ end;
+ CSTII_until:
+ begin
+ Debug_WriteLine(BlockInfo);
+ if BlockInfo.SubType = tRepeat then
+ begin
+ break;
+ end
+ else
+ begin
+ MakeError('', ecIdentifierExpected, '');
+ exit;
+ end;
+ if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
+ break;
+ end;
+ CSTII_Else:
+ begin
+ if BlockInfo.SubType = tifOneliner then
+ break
+ else
+ begin
+ MakeError('', ecIdentifierExpected, '');
+ exit;
+ end;
+ end;
+ CSTII_repeat:
+ begin
+ if not ProcessRepeat then
+ exit;
+ if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
+ break;
+ end;
+ CSTII_For:
+ begin
+ if not ProcessFor then
+ exit;
+ if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
+ break;
+ end;
+ CSTII_While:
+ begin
+ if not ProcessWhile then
+ exit;
+ if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
+ break;
+ end;
+ CSTII_Exit:
+ begin
+ Debug_WriteLine(BlockInfo);
+ BlockWriteByte(BlockInfo, Cm_R);
+ FParser.Next;
+ if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
+ break;
+ end;
+ CSTII_Case:
+ begin
+ if not ProcessCase then
+ exit;
+ if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
+ break;
+ end;
+ CSTII_If:
+ begin
+ if not ProcessIf then
+ exit;
+ if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
+ break;
+ end;
+ CSTI_Identifier:
+ begin
+ case _ProcessLabel of
+ 0: Exit;
+ 1: ;
+ else
+ begin
+ if FParser.GetToken = 'BREAK' then
+ begin
+ if FBreakOffsets = nil then
+ begin
+ MakeError('', ecNotInLoop, '');
+ exit;
+ end;
+ for i := 0 to FExceptFinallyCount - 1 do
+ begin
+ BlockWriteByte(BlockInfo, cm_poexh);
+ BlockWriteByte(BlockInfo, 1);
+ end;
+
+ for i := 0 to FTryCount - 1 do
+ begin
+ BlockWriteByte(BlockInfo, cm_poexh);
+ BlockWriteByte(BlockInfo, 0);
+ BlockWriteByte(BlockInfo, cm_poexh);
+ BlockWriteByte(BlockInfo, 1);
+ end;
+
+ for i := 0 to FWithCount - 1 do
+ BlockWriteByte(BlockInfo,cm_po);
+ BlockWriteByte(BlockInfo, Cm_G);
+ BlockWriteLong(BlockInfo, $12345678);
+ FBreakOffsets.Add(Pointer(Length(BlockInfo.Proc.Data)));
+ FParser.Next;
+ if (BlockInfo.SubType= tifOneliner) or (BlockInfo.SubType = TOneLiner) then
+ break;
+ end else if FParser.GetToken = 'CONTINUE' then
+ begin
+ if FBreakOffsets = nil then
+ begin
+ MakeError('', ecNotInLoop, '');
+ exit;
+ end;
+ for i := 0 to FExceptFinallyCount - 1 do
+ begin
+ BlockWriteByte(BlockInfo, cm_poexh);
+ BlockWriteByte(BlockInfo, 1);
+ end;
+
+ for i := 0 to FTryCount - 1 do
+ begin
+ BlockWriteByte(BlockInfo, cm_poexh);
+ BlockWriteByte(BlockInfo, 0);
+ BlockWriteByte(BlockInfo, cm_poexh);
+ BlockWriteByte(BlockInfo, 1);
+ end;
+
+ for i := 0 to FWithCount - 1 do
+ BlockWriteByte(BlockInfo,cm_po);
+ BlockWriteByte(BlockInfo, Cm_G);
+ BlockWriteLong(BlockInfo, $12345678);
+ FContinueOffsets.Add(Pointer(Length(BlockInfo.Proc.Data)));
+ FParser.Next;
+ if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
+ break;
+ end else
+ if not ProcessIdentifier then
+ exit;
+ if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
+ break;
+ end;
+ end; {case}
+
+ if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
+ break;
+
+ end;
+ {$IFDEF PS_USESSUPPORT}
+ CSTII_Finalization: //NvdS
+ begin //
+ if (BlockInfo.SubType = tUnitInit) then //
+ begin //
+ break; //
+ end //
+ else //
+ begin //
+ MakeError('', ecIdentifierExpected, ''); //
+ exit; //
+ end; //
+ end; //nvds
+ {$endif}
+ CSTII_End:
+ begin
+ if (BlockInfo.SubType = tTryEnd) or (BlockInfo.SubType = tMainBegin) or
+ (BlockInfo.SubType = tSubBegin) or (BlockInfo.SubType = tifOneliner) or
+ (BlockInfo.SubType = tProcBegin) or (BlockInfo.SubType = TOneLiner)
+ {$IFDEF PS_USESSUPPORT} or (BlockInfo.SubType = tUnitInit) or (BlockInfo.SubType = tUnitFinish) {$endif} then //nvds
+ begin
+ break;
+ end
+ else
+ begin
+ MakeError('', ecIdentifierExpected, '');
+ exit;
+ end;
+ end;
+ CSTI_EOF:
+ begin
+ MakeError('', ecUnexpectedEndOfFile, '');
+ exit;
+ end;
+ else
+ begin
+ MakeError('', ecIdentifierExpected, '');
+ exit;
+ end;
+ end;
+ end;
+ if (BlockInfo.SubType = tMainBegin) or (BlockInfo.SubType = tProcBegin)
+ {$IFDEF PS_USESSUPPORT} or (BlockInfo.SubType = tUnitInit) or (BlockInfo.SubType = tUnitFinish) {$endif} then //nvds
+ begin
+ Debug_WriteLine(BlockInfo);
+ BlockWriteByte(BlockInfo, Cm_R);
+ {$IFDEF PS_USESSUPPORT}
+ if FParser.CurrTokenId = CSTII_End then //nvds
+ begin
+ {$endif}
+ FParser.Next; // skip end
+ if ((BlockInfo.SubType = tMainBegin)
+ {$IFDEF PS_USESSUPPORT} or (BlockInfo.SubType = tUnitInit) or (BlockInfo.SubType = tUnitFinish){$endif}) //nvds
+ and (FParser.CurrTokenId <> CSTI_Period) then
+ begin
+ MakeError('', ecPeriodExpected, '');
+ exit;
+ end;
+ if (BlockInfo.SubType = tProcBegin) and (FParser.CurrTokenId <> CSTI_Semicolon) then
+ begin
+ MakeError('', ecSemicolonExpected, '');
+ exit;
+ end;
+ FParser.Next;
+ {$IFDEF PS_USESSUPPORT}
+ end; //nvds
+ {$endif}
+ end
+ else if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
+ begin
+ if (FParser.CurrTokenID <> CSTII_Else) and (FParser.CurrTokenID <> CSTII_End) then
+ if FParser.CurrTokenID <> CSTI_Semicolon then
+ begin
+ MakeError('', ecSemicolonExpected, '');
+ exit;
+ end;
+ end;
+
+ ProcessSub := True;
+end;
+procedure TPSPascalCompiler.UseProc(procdecl: TPSParametersDecl);
+var
+ i: Longint;
+begin
+ if procdecl.Result <> nil then
+ procdecl.Result := at2ut(procdecl.Result);
+ for i := 0 to procdecl.ParamCount -1 do
+ begin
+ procdecl.Params[i].aType := at2ut(procdecl.Params[i].aType);
+ end;
+end;
+
+function TPSPascalCompiler.at2ut(p: TPSType): TPSType;
+var
+ i: Longint;
+begin
+ p := GetTypeCopyLink(p);
+ if p = nil then
+ begin
+ Result := nil;
+ exit;
+ end;
+ if not p.Used then
+ begin
+ p.Use;
+ case p.BaseType of
+ btStaticArray, btArray: TPSArrayType(p).ArrayTypeNo := at2ut(TPSArrayType(p).ArrayTypeNo);
+ btRecord:
+ begin
+ for i := 0 to TPSRecordType(p).RecValCount -1 do
+ begin
+ TPSRecordType(p).RecVal(i).aType := at2ut(TPSRecordType(p).RecVal(i).aType);
+ end;
+ end;
+ btSet: TPSSetType(p).SetType := at2ut(TPSSetType(p).SetType);
+ btProcPtr:
+ begin
+ UseProc(TPSProceduralType(p).ProcDef);
+ end;
+ end;
+ p.FFinalTypeNo := FCurrUsedTypeNo;
+ inc(FCurrUsedTypeNo);
+ end;
+ Result := p;
+end;
+
+function TPSPascalCompiler.ProcessLabelForwards(Proc: TPSInternalProcedure): Boolean;
+var
+ i: Longint;
+ s, s2: tbtString;
+begin
+ for i := 0 to Proc.FLabels.Count -1 do
+ begin
+ s := Proc.FLabels[I];
+ if Longint((@s[1])^) = -1 then
+ begin
+ delete(s, 1, 8);
+ MakeError('', ecUnSetLabel, s);
+ Result := False;
+ exit;
+ end;
+ end;
+ for i := Proc.FGotos.Count -1 downto 0 do
+ begin
+ s := Proc.FGotos[I];
+ s2 := Proc.FLabels[Cardinal((@s[5])^)];
+ Cardinal((@Proc.Data[Cardinal((@s[1])^)-3])^) := Cardinal((@s2[1])^) - Cardinal((@s[1])^) ;
+ end;
+ Result := True;
+end;
+
+
+type
+ TCompilerState = (csStart, csProgram, csUnit, csUses, csInterface, csInterfaceUses, csImplementation);
+
+function TPSPascalCompiler.Compile(const s: tbtString): Boolean;
+var
+ Position: TCompilerState;
+ i: Longint;
+ {$IFDEF PS_USESSUPPORT}
+ OldFileName: tbtString;
+ OldParser : TPSPascalParser;
+ OldIsUnit : Boolean;
+ {$ENDIF}
+
+ procedure Cleanup;
+ var
+ I: Longint;
+ PT: TPSType;
+ begin
+ {$IFDEF PS_USESSUPPORT}
+ if fInCompile>1 then
+ begin
+ dec(fInCompile);
+ exit;
+ end;
+ {$ENDIF}
+
+ if @FOnBeforeCleanup <> nil then
+ FOnBeforeCleanup(Self); // no reason it actually read the result of this call
+ FGlobalBlock.Free;
+ FGlobalBlock := nil;
+
+ for I := 0 to FRegProcs.Count - 1 do
+ TObject(FRegProcs[I]).Free;
+ FRegProcs.Free;
+ for i := 0 to FConstants.Count -1 do
+ begin
+ TPSConstant(FConstants[I]).Free;
+ end;
+ Fconstants.Free;
+ for I := 0 to FVars.Count - 1 do
+ begin
+ TPSVar(FVars[I]).Free;
+ end;
+ FVars.Free;
+ FVars := nil;
+ for I := 0 to FProcs.Count - 1 do
+ TPSProcedure(FProcs[I]).Free;
+ FProcs.Free;
+ FProcs := nil;
+ for I := 0 to FTypes.Count - 1 do
+ begin
+ PT := FTypes[I];
+ pt.Free;
+ end;
+ FTypes.Free;
+
+{$IFNDEF PS_NOINTERFACES}
+ for i := FInterfaces.Count -1 downto 0 do
+ TPSInterface(FInterfaces[i]).Free;
+ FInterfaces.Free;
+{$ENDIF}
+
+ for i := FClasses.Count -1 downto 0 do
+ begin
+ TPSCompileTimeClass(FClasses[I]).Free;
+ end;
+ FClasses.Free;
+ for i := FAttributeTypes.Count -1 downto 0 do
+ begin
+ TPSAttributeType(FAttributeTypes[i]).Free;
+ end;
+ FAttributeTypes.Free;
+ FAttributeTypes := nil;
+
+ {$IFDEF PS_USESSUPPORT}
+ for I := 0 to FUnitInits.Count - 1 do //nvds
+ begin //nvds
+ TPSBlockInfo(FUnitInits[I]).free; //nvds
+ end; //nvds
+ FUnitInits.Free; //nvds
+ FUnitInits := nil; //
+ for I := 0 to FUnitFinits.Count - 1 do //nvds
+ begin //nvds
+ TPSBlockInfo(FUnitFinits[I]).free; //nvds
+ end; //nvds
+ FUnitFinits.Free; //
+ FUnitFinits := nil; //
+
+ FUses.Free;
+ FUses:=nil;
+ fInCompile:=0;
+ {$ENDIF}
+ end;
+
+ function MakeOutput: Boolean;
+
+ procedure WriteByte(b: Byte);
+ begin
+ FOutput := FOutput + tbtChar(b);
+ end;
+
+ procedure WriteData(const Data; Len: Longint);
+ var
+ l: Longint;
+ begin
+ if Len < 0 then Len := 0;
+ l := Length(FOutput);
+ SetLength(FOutput, l + Len);
+ Move(Data, FOutput[l + 1], Len);
+ end;
+
+ procedure WriteLong(l: Cardinal);
+ begin
+ WriteData(l, 4);
+ end;
+
+ procedure WriteVariant(p: PIfRVariant);
+ begin
+ WriteLong(p^.FType.FinalTypeNo);
+ case p.FType.BaseType of
+ btType: WriteLong(p^.ttype.FinalTypeNo);
+ {$IFNDEF PS_NOWIDESTRING}
+ btWideString:
+ begin
+ WriteLong(Length(tbtWideString(p^.twidestring)));
+ WriteData(tbtwidestring(p^.twidestring)[1], 2*Length(tbtWideString(p^.twidestring)));
+ end;
+ btUnicodeString:
+ begin
+ WriteLong(Length(tbtUnicodestring(p^.twidestring)));
+ WriteData(tbtUnicodestring(p^.twidestring)[1], 2*Length(tbtUnicodestring(p^.twidestring)));
+ end;
+ btWideChar: WriteData(p^.twidechar, 2);
+ {$ENDIF}
+ btSingle: WriteData(p^.tsingle, sizeof(tbtSingle));
+ btDouble: WriteData(p^.tsingle, sizeof(tbtDouble));
+ btExtended: WriteData(p^.tsingle, sizeof(tbtExtended));
+ btCurrency: WriteData(p^.tsingle, sizeof(tbtCurrency));
+ btChar: WriteData(p^.tchar, 1);
+ btSet:
+ begin
+ WriteData(tbtString(p^.tstring)[1], Length(tbtString(p^.tstring)));
+ end;
+ btString:
+ begin
+ WriteLong(Length(tbtString(p^.tstring)));
+ WriteData(tbtString(p^.tstring)[1], Length(tbtString(p^.tstring)));
+ end;
+ btenum:
+ begin
+ if TPSEnumType(p^.FType).HighValue <=256 then
+ WriteData( p^.tu32, 1)
+ else if TPSEnumType(p^.FType).HighValue <=65536 then
+ WriteData(p^.tu32, 2)
+ else
+ WriteData(p^.tu32, 4);
+ end;
+ bts8,btu8: WriteData(p^.tu8, 1);
+ bts16,btu16: WriteData(p^.tu16, 2);
+ bts32,btu32: WriteData(p^.tu32, 4);
+ {$IFNDEF PS_NOINT64}
+ bts64: WriteData(p^.ts64, 8);
+ {$ENDIF}
+ btProcPtr: WriteData(p^.tu32, 4);
+ {$IFDEF DEBUG}
+ else
+ asm int 3; end;
+ {$ENDIF}
+ end;
+ end;
+
+ procedure WriteAttributes(attr: TPSAttributes);
+ var
+ i, j: Longint;
+ begin
+ WriteLong(attr.Count);
+ for i := 0 to Attr.Count -1 do
+ begin
+ j := Length(attr[i].FAttribType.Name);
+ WriteLong(j);
+ WriteData(Attr[i].FAttribType.Name[1], j);
+ WriteLong(Attr[i].Count);
+ for j := 0 to Attr[i].Count -1 do
+ begin
+ WriteVariant(Attr[i][j]);
+ end;
+ end;
+ end;
+
+ procedure WriteTypes;
+ var
+ l, n: Longint;
+ bt: TPSBaseType;
+ x: TPSType;
+ s: tbtString;
+ FExportName: tbtString;
+ Items: TPSList;
+ procedure WriteTypeNo(TypeNo: Cardinal);
+ begin
+ WriteData(TypeNo, 4);
+ end;
+ begin
+ Items := TPSList.Create;
+ try
+ for l := 0 to FCurrUsedTypeNo -1 do
+ Items.Add(nil);
+ for l := 0 to FTypes.Count -1 do
+ begin
+ x := FTypes[l];
+ if x.Used then
+ Items[x.FinalTypeNo] := x;
+ end;
+ for l := 0 to Items.Count - 1 do
+ begin
+ x := Items[l];
+ if x.FExportName then
+ FExportName := x.Name
+ else
+ FExportName := '';
+ if (x.BaseType = btExtClass) and (x is TPSUndefinedClassType) then
+ begin
+ x := GetTypeCopyLink(TPSUndefinedClassType(x).ExtClass.SelfType);
+ end;
+ bt := x.BaseType;
+ if (x.BaseType = btType) or (x.BaseType = btNotificationVariant) then
+ begin
+ bt := btU32;
+ end else
+ if (x.BaseType = btEnum) then begin
+ if TPSEnumType(x).HighValue <= 256 then
+ bt := btU8
+ else if TPSEnumType(x).HighValue <= 65536 then
+ bt := btU16
+ else
+ bt := btU32;
+ end;
+ if FExportName <> '' then
+ begin
+ WriteByte(bt + 128);
+ end
+ else
+ WriteByte(bt);
+{$IFNDEF PS_NOINTERFACES} if x.BaseType = btInterface then
+ begin
+ WriteData(TPSInterfaceType(x).Intf.Guid, Sizeof(TGuid));
+ end else {$ENDIF} if x.BaseType = btClass then
+ begin
+ WriteLong(Length(TPSClassType(X).Cl.FClassName));
+ WriteData(TPSClassType(X).Cl.FClassName[1], Length(TPSClassType(X).Cl.FClassName));
+ end else
+ if (x.BaseType = btProcPtr) then
+ begin
+ s := DeclToBits(TPSProceduralType(x).ProcDef);
+ WriteLong(Length(s));
+ WriteData(s[1], Length(s));
+ end else
+ if (x.BaseType = btSet) then
+ begin
+ WriteLong(TPSSetType(x).BitSize);
+ end else
+ if (x.BaseType = btArray) or (x.basetype = btStaticArray) then
+ begin
+ WriteLong(TPSArrayType(x).ArrayTypeNo.FinalTypeNo);
+ if (x.baseType = btstaticarray) then begin
+ WriteLong(TPSStaticArrayType(x).Length);
+ WriteLong(TPSStaticArrayType(x).StartOffset); //<-additional StartOffset
+ end;
+ end else if x.BaseType = btRecord then
+ begin
+ n := TPSRecordType(x).RecValCount;
+ WriteData( n, 4);
+ for n := 0 to TPSRecordType(x).RecValCount - 1 do
+ WriteTypeNo(TPSRecordType(x).RecVal(n).FType.FinalTypeNo);
+ end;
+ if FExportName <> '' then
+ begin
+ WriteLong(Length(FExportName));
+ WriteData(FExportName[1], length(FExportName));
+ end;
+ WriteAttributes(x.Attributes);
+ end;
+ finally
+ Items.Free;
+ end;
+ end;
+
+ procedure WriteVars;
+ var
+ l,j : Longint;
+ x: TPSVar;
+ begin
+ for l := 0 to FVars.Count - 1 do
+ begin
+ x := FVars[l];
+ if x.SaveAsPointer then
+ begin
+ for j := FTypes.count -1 downto 0 do
+ begin
+ if TPSType(FTypes[j]).BaseType = btPointer then
+ begin
+ WriteLong(TPSType(FTypes[j]).FinalTypeNo);
+ break;
+ end;
+ end;
+ end else
+ WriteLong(x.FType.FinalTypeNo);
+ if x.exportname <> '' then
+ begin
+ WriteByte( 1);
+ WriteLong(Length(X.ExportName));
+ WriteData( X.ExportName[1], length(X.ExportName));
+ end else
+ WriteByte( 0);
+ end;
+ end;
+
+ procedure WriteProcs;
+ var
+ l: Longint;
+ xp: TPSProcedure;
+ xo: TPSInternalProcedure;
+ xe: TPSExternalProcedure;
+ s: tbtString;
+ att: Byte;
+ begin
+ for l := 0 to FProcs.Count - 1 do
+ begin
+ xp := FProcs[l];
+ if xp.Attributes.Count <> 0 then att := 4 else att := 0;
+ if xp.ClassType = TPSInternalProcedure then
+ begin
+ xo := TPSInternalProcedure(xp);
+ xo.OutputDeclPosition := Length(FOutput);
+ WriteByte(att or 2); // exported
+ WriteLong(0); // offset is unknown at this time
+ WriteLong(0); // length is also unknown at this time
+ WriteLong(Length(xo.Name));
+ WriteData( xo.Name[1], length(xo.Name));
+ s := MakeExportDecl(xo.Decl);
+ WriteLong(Length(s));
+ WriteData( s[1], length(S));
+ end
+ else
+ begin
+ xe := TPSExternalProcedure(xp);
+ if xe.RegProc.ImportDecl <> '' then
+ begin
+ WriteByte( att or 3); // imported
+ if xe.RegProc.FExportName then
+ begin
+ WriteByte(Length(xe.RegProc.Name));
+ WriteData(xe.RegProc.Name[1], Length(xe.RegProc.Name) and $FF);
+ end else begin
+ WriteByte(0);
+ end;
+ WriteLong(Length(xe.RegProc.ImportDecl));
+ WriteData(xe.RegProc.ImportDecl[1], Length(xe.RegProc.ImportDecl));
+ end else begin
+ WriteByte(att or 1); // imported
+ WriteByte(Length(xe.RegProc.Name));
+ WriteData(xe.RegProc.Name[1], Length(xe.RegProc.Name) and $FF);
+ end;
+ end;
+ if xp.Attributes.Count <> 0 then
+ WriteAttributes(xp.Attributes);
+ end;
+ end;
+
+ procedure WriteProcs2;
+ var
+ l: Longint;
+ L2: Cardinal;
+ x: TPSProcedure;
+ begin
+ for l := 0 to FProcs.Count - 1 do
+ begin
+ x := FProcs[l];
+ if x.ClassType = TPSInternalProcedure then
+ begin
+ if TPSInternalProcedure(x).Data = '' then
+ TPSInternalProcedure(x).Data := Chr(Cm_R);
+ L2 := Length(FOutput);
+ Move(L2, FOutput[TPSInternalProcedure(x).OutputDeclPosition + 2], 4);
+ // write position
+ WriteData(TPSInternalProcedure(x).Data[1], Length(TPSInternalProcedure(x).Data));
+ L2 := Cardinal(Length(FOutput)) - L2;
+ Move(L2, FOutput[TPSInternalProcedure(x).OutputDeclPosition + 6], 4); // write length
+ end;
+ end;
+ end;
+
+
+
+ {$IFDEF PS_USESSUPPORT}
+ function FindMainProc: Cardinal;
+ var
+ l: Longint;
+ Proc : TPSInternalProcedure;
+ ProcData : tbtString;
+ Calls : Integer;
+
+ procedure WriteProc(const aData: Longint);
+ var
+ l: Longint;
+ begin
+ ProcData := ProcData + Chr(cm_c);
+ l := Length(ProcData);
+ SetLength(ProcData, l + 4);
+ Move(aData, ProcData[l + 1], 4);
+ inc(Calls);
+ end;
+ begin
+ ProcData := ''; Calls := 1;
+ for l := 0 to FUnitInits.Count-1 do
+ if (FUnitInits[l] <> nil) and
+ (TPSBlockInfo(FUnitInits[l]).Proc.Data<>'') then
+ WriteProc(TPSBlockInfo(FUnitInits[l]).FProcNo);
+
+ WriteProc(FGlobalBlock.FProcNo);
+
+ for l := FUnitFinits.Count-1 downto 0 do
+ if (FUnitFinits[l] <> nil) and
+ (TPSBlockInfo(FUnitFinits[l]).Proc.Data<>'') then
+ WriteProc(TPSBlockInfo(FUnitFinits[l]).FProcNo);
+
+ if Calls = 1 then begin
+ Result := FGlobalBlock.FProcNo;
+ end else
+ begin
+ Proc := NewProc('Master proc', '!MASTERPROC');
+ Result := FindProc('!MASTERPROC');
+ Proc.data := Procdata + Chr(cm_R);
+ end;
+ end;
+ {$ELSE}
+ function FindMainProc: Cardinal;
+ var
+ l: Longint;
+ begin
+ for l := 0 to FProcs.Count - 1 do
+ begin
+ if (TPSProcedure(FProcs[l]).ClassType = TPSInternalProcedure) and
+ (TPSInternalProcedure(FProcs[l]).Name = PSMainProcName) then
+ begin
+ Result := l;
+ exit;
+ end;
+ end;
+ Result := InvalidVal;
+ end;
+ {$ENDIF}
+
+ procedure CreateDebugData;
+ var
+ I: Longint;
+ p: TPSProcedure;
+ pv: TPSVar;
+ s: tbtString;
+ begin
+ s := #0;
+ for I := 0 to FProcs.Count - 1 do
+ begin
+ p := FProcs[I];
+ if p.ClassType = TPSInternalProcedure then
+ begin
+ if TPSInternalProcedure(p).Name = PSMainProcName then
+ s := s + #1
+ else
+ s := s + TPSInternalProcedure(p).OriginalName + #1;
+ end
+ else
+ begin
+ s := s+ TPSExternalProcedure(p).RegProc.OrgName + #1;
+ end;
+ end;
+ s := s + #0#1;
+ for I := 0 to FVars.Count - 1 do
+ begin
+ pv := FVars[I];
+ s := s + pv.OrgName + #1;
+ end;
+ s := s + #0;
+ WriteDebugData(s);
+ end;
+
+ var //nvds
+ MainProc : Cardinal; //nvds
+
+ begin
+ if @FOnBeforeOutput <> nil then
+ begin
+ if not FOnBeforeOutput(Self) then
+ begin
+ Result := false;
+ exit;
+ end;
+ end;
+ MainProc := FindMainProc; //NvdS (need it here becose FindMainProc can create a New proc.
+ CreateDebugData;
+ WriteLong(PSValidHeader);
+ WriteLong(PSCurrentBuildNo);
+ WriteLong(FCurrUsedTypeNo);
+ WriteLong(FProcs.Count);
+ WriteLong(FVars.Count);
+ WriteLong(MainProc); //nvds
+ WriteLong(0);
+ WriteTypes;
+ WriteProcs;
+ WriteVars;
+ WriteProcs2;
+
+ Result := true;
+ end;
+
+ function CheckExports: Boolean;
+ var
+ i: Longint;
+ p: TPSProcedure;
+ begin
+ if @FOnExportCheck = nil then
+ begin
+ result := true;
+ exit;
+ end;
+ for i := 0 to FProcs.Count -1 do
+ begin
+ p := FProcs[I];
+ if p.ClassType = TPSInternalProcedure then
+ begin
+ if not FOnExportCheck(Self, TPSInternalProcedure(p), MakeDecl(TPSInternalProcedure(p).Decl)) then
+ begin
+ Result := false;
+ exit;
+ end;
+ end;
+ end;
+ Result := True;
+ end;
+ function DoConstBlock: Boolean;
+ var
+ COrgName: tbtString;
+ CTemp, CValue: PIFRVariant;
+ Cp: TPSConstant;
+ TokenPos, TokenRow, TokenCol: Integer;
+ begin
+ FParser.Next;
+ repeat
+ if FParser.CurrTokenID <> CSTI_Identifier then
+ begin
+ MakeError('', ecIdentifierExpected, '');
+ Result := False;
+ Exit;
+ end;
+ TokenPos := FParser.CurrTokenPos;
+ TokenRow := FParser.Row;
+ TokenCol := FParser.Col;
+ COrgName := FParser.OriginalToken;
+ if IsDuplicate(FastUpperCase(COrgName), [dcVars, dcProcs, dcConsts]) then
+ begin
+ MakeError('', ecDuplicateIdentifier, COrgName);
+ Result := False;
+ exit;
+ end;
+ FParser.Next;
+ if FParser.CurrTokenID <> CSTI_Equal then
+ begin
+ MakeError('', ecIsExpected, '');
+ Result := False;
+ Exit;
+ end;
+ FParser.Next;
+ CValue := ReadConstant(FParser, CSTI_SemiColon);
+ if CValue = nil then
+ begin
+ Result := False;
+ Exit;
+ end;
+ if FParser.CurrTokenID <> CSTI_Semicolon then
+ begin
+ MakeError('', ecSemicolonExpected, '');
+ Result := False;
+ exit;
+ end;
+ cp := TPSConstant.Create;
+ cp.Orgname := COrgName;
+ cp.Name := FastUpperCase(COrgName);
+ {$IFDEF PS_USESSUPPORT}
+ cp.DeclareUnit:=fModule;
+ {$ENDIF}
+ cp.DeclarePos := TokenPos;
+ cp.DeclareRow := TokenRow;
+ cp.DeclareCol := TokenCol;
+ New(CTemp);
+ InitializeVariant(CTemp, CValue.FType);
+ CopyVariantContents(cvalue, CTemp);
+ cp.Value := CTemp;
+ FConstants.Add(cp);
+ DisposeVariant(CValue);
+ FParser.Next;
+ until FParser.CurrTokenId <> CSTI_Identifier;
+ Result := True;
+ end;
+
+ function ProcessUses: Boolean;
+ var
+ {$IFNDEF PS_USESSUPPORT}
+ FUses: TIfStringList;
+ {$ENDIF}
+ I: Longint;
+ s: tbtString;
+ {$IFDEF PS_USESSUPPORT}
+ Parse: Boolean;
+ ParseUnit: tbtString;
+ ParserPos: TPSPascalParser;
+ {$ENDIF}
+ begin
+ FParser.Next;
+ {$IFNDEF PS_USESSUPPORT}
+ FUses := TIfStringList.Create;
+ FUses.Add('SYSTEM');
+ {$ENDIF}
+ repeat
+ if FParser.CurrTokenID <> CSTI_Identifier then
+ begin
+ MakeError('', ecIdentifierExpected, '');
+ {$IFNDEF PS_USESSUPPORT}
+ FUses.Free;
+ {$ENDIF}
+ Result := False;
+ exit;
+ end;
+ s := FParser.GetToken;
+ {$IFDEF PS_USESSUPPORT}
+ Parse:=true;
+ {$ENDIF}
+ for i := 0 to FUses.Count -1 do
+ begin
+ if FUses[I] = s then
+ begin
+ {$IFNDEF PS_USESSUPPORT}
+ MakeError('', ecDuplicateIdentifier, s);
+ FUses.Free;
+ Result := False;
+ exit;
+ {$ELSE}
+ Parse:=false;
+ {$ENDIF}
+ end;
+ end;
+ {$IFDEF PS_USESSUPPORT}
+ if Parse then
+ begin
+ {$ENDIF}
+ FUses.Add(s);
+ if @FOnUses <> nil then
+ begin
+ try
+ {$IFDEF PS_USESSUPPORT}
+ OldFileName:=fModule;
+ fModule:=FParser.OriginalToken;
+ ParseUnit:=FParser.OriginalToken;
+ ParserPos:=FParser;
+ {$ENDIF}
+ if not OnUses(Self, FParser.GetToken) then
+ begin
+ {$IFNDEF PS_USESSUPPORT}
+ FUses.Free;
+ {$ELSE}
+ FParser:=ParserPos;
+ fModule:=OldFileName;
+ MakeError(OldFileName, ecUnitNotFoundOrContainsErrors, ParseUnit);
+ {$ENDIF}
+ Result := False;
+ exit;
+ end;
+ {$IFDEF PS_USESSUPPORT}
+ fModule:=OldFileName;
+ {$ENDIF}
+ except
+ on e: Exception do
+ begin
+ MakeError('', ecCustomError, tbtstring(e.Message));
+ {$IFNDEF PS_USESSUPPORT}
+ FUses.Free;
+ {$ENDIF}
+ Result := False;
+ exit;
+ end;
+ end;
+ end;
+ {$IFDEF PS_USESSUPPORT}
+ end;
+ {$ENDIF}
+ FParser.Next;
+ if FParser.CurrTokenID = CSTI_Semicolon then break
+ else if FParser.CurrTokenId <> CSTI_Comma then
+ begin
+ MakeError('', ecSemicolonExpected, '');
+ Result := False;
+ {$IFNDEF PS_USESSUPPORT}
+ FUses.Free;
+ {$ENDIF}
+ exit;
+ end;
+ FParser.Next;
+ until False;
+ {$IFNDEF PS_USESSUPPORT}
+ FUses.Free;
+ {$ENDIF}
+ FParser.next;
+ Result := True;
+ end;
+
+var
+ Proc: TPSProcedure;
+ {$IFDEF PS_USESSUPPORT}
+ Block : TPSBlockInfo; //nvds
+ {$ENDIF}
+begin
+ Result := False;
+ FWithCount := -1;
+
+ {$IFDEF PS_USESSUPPORT}
+ if fInCompile=0 then
+ begin
+ {$ENDIF}
+ FUnitName := '';
+ FCurrUsedTypeNo := 0;
+ FIsUnit := False;
+ Clear;
+ FParserHadError := False;
+ FParser.SetText(s);
+ FAttributeTypes := TPSList.Create;
+ FProcs := TPSList.Create;
+ FConstants := TPSList.Create;
+ FVars := TPSList.Create;
+ FTypes := TPSList.Create;
+ FRegProcs := TPSList.Create;
+ FClasses := TPSList.Create;
+
+ {$IFDEF PS_USESSUPPORT}
+ FUnitInits := TPSList.Create; //nvds
+ FUnitFinits:= TPSList.Create; //nvds
+
+ FUses:=TIFStringList.Create;
+ {$ENDIF}
+ {$IFNDEF PS_NOINTERFACES} FInterfaces := TPSList.Create;{$ENDIF}
+
+ FGlobalBlock := TPSBlockInfo.Create(nil);
+ FGlobalBlock.SubType := tMainBegin;
+
+ FGlobalBlock.Proc := NewProc(PSMainProcNameOrg, PSMainProcName);
+ FGlobalBlock.ProcNo := FindProc(PSMainProcName);
+
+ {$IFDEF PS_USESSUPPORT}
+ OldFileName:=fModule;
+ fModule:='System';
+ FUses.Add('SYSTEM');
+ {$ENDIF}
+ {$IFNDEF PS_NOSTANDARDTYPES}
+ DefineStandardTypes;
+ DefineStandardProcedures;
+ {$ENDIF}
+ if @FOnUses <> nil then
+ begin
+ try
+ if not OnUses(Self, 'SYSTEM') then
+ begin
+ Cleanup;
+ exit;
+ end;
+ except
+ on e: Exception do
+ begin
+ MakeError('', ecCustomError, tbtstring(e.Message));
+ Cleanup;
+ exit;
+ end;
+ end;
+ end;
+ {$IFDEF PS_USESSUPPORT}
+ fModule:=OldFileName;
+ OldParser:=nil;
+ OldIsUnit:=false; // defaults
+ end
+ else
+ begin
+ OldParser:=FParser;
+ OldIsUnit:=FIsUnit;
+ FParser:=TPSPascalParser.Create;
+ FParser.SetText(s);
+ end;
+
+ inc(fInCompile);
+ {$ENDIF}
+
+ Position := csStart;
+ repeat
+ if FParser.CurrTokenId = CSTI_EOF then
+ begin
+ if FParserHadError then
+ begin
+ Cleanup;
+ exit;
+ end;
+ if FAllowNoEnd then
+ Break
+ else
+ begin
+ MakeError('', ecUnexpectedEndOfFile, '');
+ Cleanup;
+ exit;
+ end;
+ end;
+ if (FParser.CurrTokenId = CSTII_Program) and (Position = csStart) then
+ begin
+ {$IFDEF PS_USESSUPPORT}
+ if fInCompile>1 then
+ begin
+ MakeError('', ecNotAllowed, 'program');
+ Cleanup;
+ exit;
+ end;
+ {$ENDIF}
+ Position := csProgram;
+ FParser.Next;
+ if FParser.CurrTokenId <> CSTI_Identifier then
+ begin
+ MakeError('', ecIdentifierExpected, '');
+ Cleanup;
+ exit;
+ end;
+ FParser.Next;
+ if FParser.CurrTokenId <> CSTI_Semicolon then
+ begin
+ MakeError('', ecSemicolonExpected, '');
+ Cleanup;
+ exit;
+ end;
+ FParser.Next;
+ end else
+ if (Fparser.CurrTokenID = CSTII_Implementation) and ((Position = csinterface) or (position = csInterfaceUses)) then
+ begin
+ Position := csImplementation;
+ FParser.Next;
+ end else
+ if (Fparser.CurrTokenID = CSTII_Interface) and (Position = csUnit) then
+ begin
+ Position := csInterface;
+ FParser.Next;
+ end else
+ if (FParser.CurrTokenId = CSTII_Unit) and (Position = csStart) and (FAllowUnit) then
+ begin
+ Position := csUnit;
+ FIsUnit := True;
+ FParser.Next;
+ if FParser.CurrTokenId <> CSTI_Identifier then
+ begin
+ MakeError('', ecIdentifierExpected, '');
+ Cleanup;
+ exit;
+ end;
+ if fInCompile = 1 then
+ FUnitName := FParser.OriginalToken;
+ FParser.Next;
+ if FParser.CurrTokenId <> CSTI_Semicolon then
+ begin
+ MakeError('', ecSemicolonExpected, '');
+ Cleanup;
+ exit;
+ end;
+ FParser.Next;
+ end
+ else if (FParser.CurrTokenID = CSTII_Uses) and ((Position < csuses) or (Position = csInterface)) then
+ begin
+ if (Position = csInterface) or (Position =csInterfaceUses)
+ then Position := csInterfaceUses
+ else Position := csUses;
+ if not ProcessUses then
+ begin
+ Cleanup;
+ exit;
+ end;
+ end else if (FParser.CurrTokenId = CSTII_Procedure) or
+ (FParser.CurrTokenId = CSTII_Function) or (FParser.CurrTokenID = CSTI_OpenBlock) then
+ begin
+ if (Position = csInterface) or (position = csInterfaceUses) then
+ begin
+ if not ProcessFunction(True, nil) then
+ begin
+ Cleanup;
+ exit;
+ end;
+ end else begin
+ Position := csUses;
+ if not ProcessFunction(False, nil) then
+ begin
+ Cleanup;
+ exit;
+ end;
+ end;
+ end
+ else if (FParser.CurrTokenId = CSTII_Label) then
+ begin
+ if (Position = csInterface) or (Position =csInterfaceUses)
+ then Position := csInterfaceUses
+ else Position := csUses;
+ if not ProcessLabel(FGlobalBlock.Proc) then
+ begin
+ Cleanup;
+ exit;
+ end;
+ end
+ else if (FParser.CurrTokenId = CSTII_Var) then
+ begin
+ if (Position = csInterface) or (Position =csInterfaceUses)
+ then Position := csInterfaceUses
+ else Position := csUses;
+ if not DoVarBlock(nil) then
+ begin
+ Cleanup;
+ exit;
+ end;
+ end
+ else if (FParser.CurrTokenId = CSTII_Const) then
+ begin
+ if (Position = csInterface) or (Position =csInterfaceUses)
+ then Position := csInterfaceUses
+ else Position := csUses;
+ if not DoConstBlock then
+ begin
+ Cleanup;
+ exit;
+ end;
+ end
+ else if (FParser.CurrTokenId = CSTII_Type) then
+ begin
+ if (Position = csInterface) or (Position =csInterfaceUses)
+ then Position := csInterfaceUses
+ else Position := csUses;
+ if not DoTypeBlock(FParser) then
+ begin
+ Cleanup;
+ exit;
+ end;
+ end
+ else if (FParser.CurrTokenId = CSTII_Begin)
+ {$IFDEF PS_USESSUPPORT}
+ or ((FParser.CurrTokenID = CSTII_initialization) and FIsUnit) {$ENDIF} then //nvds
+ begin
+ {$IFDEF PS_USESSUPPORT}
+ if FIsUnit then
+ begin
+ Block := TPSBlockInfo.Create(nil); //nvds
+ Block.SubType := tUnitInit; //nvds
+ Block.Proc := NewProc(PSMainProcNameOrg+'_'+fModule, FastUpperCase(PSMainProcName+'_'+fModule)); //nvds
+ Block.ProcNo := FindProc(PSMainProcName+'_'+fModule); //nvds
+ Block.Proc.DeclareUnit:= fModule;
+ Block.Proc.DeclarePos := FParser.CurrTokenPos;
+ Block.Proc.DeclareRow := FParser.Row;
+ Block.Proc.DeclareCol := FParser.Col;
+ Block.Proc.Use;
+ FUnitInits.Add(Block);
+ if ProcessSub(Block) then
+ begin
+ if (Fparser.CurrTokenId = CSTI_EOF) THEN break;
+ end
+ else
+ begin
+ Cleanup;
+ exit;
+ end;
+ end
+ else
+ begin
+ FGlobalBlock.Proc.DeclareUnit:= fModule;
+ {$ENDIF}
+ FGlobalBlock.Proc.DeclarePos := FParser.CurrTokenPos;
+ FGlobalBlock.Proc.DeclareRow := FParser.Row;
+ FGlobalBlock.Proc.DeclareCol := FParser.Col;
+ if ProcessSub(FGlobalBlock) then
+ begin
+ break;
+ end
+ else
+ begin
+ Cleanup;
+ exit;
+ end;
+ {$IFDEF PS_USESSUPPORT}
+ end;
+ {$ENDIF}
+ end
+ {$IFDEF PS_USESSUPPORT}
+ else if ((FParser.CurrTokenID = CSTII_finalization) and FIsUnit) then //NvdS
+ begin
+ Block := TPSBlockInfo.Create(nil);
+ Block.SubType := tUnitFinish;
+ Block.Proc := NewProc('!Finish_'+fModule, '!FINISH_'+FastUppercase(fModule));
+ Block.ProcNo := FindProc('!FINISH_'+FastUppercase(fModule));
+ Block.Proc.DeclareUnit:= fModule;
+
+ Block.Proc.DeclarePos := FParser.CurrTokenPos;
+ Block.Proc.DeclareRow := FParser.Row;
+ Block.Proc.DeclareCol := FParser.Col;
+ Block.Proc.use;
+ FUnitFinits.Add(Block);
+ if ProcessSub(Block) then
+ begin
+ break;
+ end else begin
+ Cleanup;
+ Result := False; //Cleanup;
+ exit;
+ end;
+ end
+ {$endif}
+ else if (Fparser.CurrTokenId = CSTII_End) and (FAllowNoBegin or FIsUnit) then
+ begin
+ FParser.Next;
+ if FParser.CurrTokenID <> CSTI_Period then
+ begin
+ MakeError('', ecPeriodExpected, '');
+ Cleanup;
+ exit;
+ end;
+ break;
+ end else
+ begin
+ MakeError('', ecBeginExpected, '');
+ Cleanup;
+ exit;
+ end;
+ until False;
+
+ {$IFDEF PS_USESSUPPORT}
+ dec(fInCompile);
+ if fInCompile=0 then
+ begin
+ {$ENDIF}
+ if not ProcessLabelForwards(FGlobalBlock.Proc) then
+ begin
+ Cleanup;
+ exit;
+ end;
+ // NVDS: Do we need to check here also do a ProcessLabelForwards() for each Initialisation/finalization block?
+
+ for i := 0 to FProcs.Count -1 do
+ begin
+ Proc := FProcs[I];
+ if (Proc.ClassType = TPSInternalProcedure) and (TPSInternalProcedure(Proc).Forwarded) then
+ begin
+ with MakeError('', ecUnsatisfiedForward, TPSInternalProcedure(Proc).Name) do
+ begin
+ FPosition := TPSInternalProcedure(Proc).DeclarePos;
+ FRow := TPSInternalProcedure(Proc).DeclareRow;
+ FCol := TPSInternalProcedure(Proc).DeclareCol;
+ end;
+ Cleanup;
+ Exit;
+ end;
+ end;
+ if not CheckExports then
+ begin
+ Cleanup;
+ exit;
+ end;
+ for i := 0 to FVars.Count -1 do
+ begin
+ if not TPSVar(FVars[I]).Used then
+ begin
+ with MakeHint({$IFDEF PS_USESSUPPORT}TPSVar(FVars[I]).DeclareUnit{$ELSE}''{$ENDIF}, ehVariableNotUsed, TPSVar(FVars[I]).Name) do
+ begin
+ FPosition := TPSVar(FVars[I]).DeclarePos;
+ FRow := TPSVar(FVars[I]).DeclareRow;
+ FCol := TPSVar(FVars[I]).DeclareCol;
+ end;
+ end;
+ end;
+
+ Result := MakeOutput;
+ Cleanup;
+ {$IFDEF PS_USESSUPPORT}
+ end
+ else
+ begin
+ fParser.Free;
+ fParser:=OldParser;
+ fIsUnit:=OldIsUnit;
+ result:=true;
+ end;
+ {$ENDIF}
+end;
+
+constructor TPSPascalCompiler.Create;
+begin
+ inherited Create;
+ FParser := TPSPascalParser.Create;
+ FParser.OnParserError := ParserError;
+ FAutoFreeList := TPSList.Create;
+ FOutput := '';
+ {$IFDEF PS_USESSUPPORT}
+ FAllowUnit := true;
+ {$ENDIF}
+ FMessages := TPSList.Create;
+end;
+
+destructor TPSPascalCompiler.Destroy;
+begin
+ Clear;
+ FAutoFreeList.Free;
+
+ FMessages.Free;
+ FParser.Free;
+ inherited Destroy;
+end;
+
+function TPSPascalCompiler.GetOutput(var s: tbtString): Boolean;
+begin
+ if Length(FOutput) <> 0 then
+ begin
+ s := FOutput;
+ Result := True;
+ end
+ else
+ Result := False;
+end;
+
+function TPSPascalCompiler.GetMsg(l: Longint): TPSPascalCompilerMessage;
+begin
+ Result := FMessages[l];
+end;
+
+function TPSPascalCompiler.GetMsgCount: Longint;
+begin
+ Result := FMessages.Count;
+end;
+
+procedure TPSPascalCompiler.DefineStandardTypes;
+var
+ i: Longint;
+begin
+ AddType('Byte', btU8);
+ FDefaultBoolType := AddTypeS('Boolean', '(False, True)');
+ FDefaultBoolType.ExportName := True;
+ with TPSEnumType(AddType('LongBool', btEnum)) do
+ begin
+ HighValue := 2147483647; // make sure it's gonna be a 4 byte var
+ end;
+ with TPSEnumType(AddType('WordBool', btEnum)) do
+ begin
+ HighValue := 65535; // make sure it's gonna be a 2 byte var
+ end;
+ with TPSEnumType(AddType('ByteBool', btEnum)) do
+ begin
+ HighValue := 255; // make sure it's gonna be a 1 byte var
+ end;
+ //following 2 IFDEFs should actually be UNICODE IFDEFs...
+ AddType({$IFDEF PS_PANSICHAR}'AnsiChar'{$ELSE}'Char'{$ENDIF}, btChar);
+ {$IFDEF PS_PANSICHAR}
+ AddType('Char', btWideChar);
+ {$ENDIF}
+ {$IFNDEF PS_NOWIDESTRING}
+ AddType('WideChar', btWideChar);
+ AddType('WideString', btWideString);
+ AddType('UnicodeString', btUnicodeString);
+ {$ENDIF}
+ AddType('AnsiString', btString);
+ {$IFDEF DELPHI2009UP}
+ AddType('String', btUnicodeString);
+ ADdType('NativeString', btUnicodeString);
+ {$ELSE}
+ AddType('String', btString);
+ AddType('NativeString', btString);
+ {$ENDIF}
+ FAnyString := AddType('AnyString', btString);
+ AddType('ShortInt', btS8);
+ AddType('Word', btU16);
+ AddType('SmallInt', btS16);
+ AddType('LongInt', btS32);
+ at2ut(AddType('___Pointer', btPointer));
+ AddType('LongWord', btU32);
+ AddTypeCopyN('Integer', 'LONGINT');
+ AddTypeCopyN('Cardinal', 'LONGWORD');
+ AddType('tbtString', btString);
+ {$IFNDEF PS_NOINT64}
+ AddType('Int64', btS64);
+ {$ENDIF}
+ AddType('Single', btSingle);
+ AddType('Double', btDouble);
+ AddType('Extended', btExtended);
+ AddType('Currency', btCurrency);
+ AddType({$IFDEF PS_PANSICHAR}'PAnsiChar'{$ELSE}'PChar'{$ENDIF}, btPChar);
+ AddType('Variant', btVariant);
+ AddType('!NotificationVariant', btNotificationVariant);
+ for i := FTypes.Count -1 downto 0 do AT2UT(FTypes[i]);
+ TPSArrayType(AddType('TVariantArray', btArray)).ArrayTypeNo := FindType('VARIANT');
+
+ with AddFunction('function Assigned(I: Longint): Boolean;') do
+ begin
+ Name := '!ASSIGNED';
+ end;
+
+ with AddFunction('procedure _T(Name: tbtString; v: Variant);') do
+ begin
+ Name := '!NOTIFICATIONVARIANTSET';
+ end;
+ with AddFunction('function _T(Name: tbtString): Variant;') do
+ begin
+ Name := '!NOTIFICATIONVARIANTGET';
+ end;
+end;
+
+
+function TPSPascalCompiler.FindType(const Name: tbtString): TPSType;
+var
+ i, n: Longint;
+ RName: tbtString;
+begin
+ if FProcs = nil then begin Result := nil; exit;end;
+ RName := Fastuppercase(Name);
+ n := makehash(rname);
+ for i := FTypes.Count - 1 downto 0 do
+ begin
+ Result := FTypes.Data[I];
+ if (Result.NameHash = n) and (Result.name = rname) then
+ begin
+ Result := GetTypeCopyLink(Result);
+ exit;
+ end;
+ end;
+ result := nil;
+end;
+
+function TPSPascalCompiler.AddConstant(const Name: tbtString; FType: TPSType): TPSConstant;
+var
+ pc: TPSConstant;
+ val: PIfRVariant;
+begin
+ if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
+
+ FType := GetTypeCopyLink(FType);
+ if FType = nil then
+ Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterConst, [name]);
+ pc := TPSConstant.Create;
+ pc.OrgName := name;
+ pc.Name := FastUppercase(name);
+ pc.DeclarePos:=InvalidVal;
+ {$IFDEF PS_USESSUPPORT}
+ pc.DeclareUnit:=fModule;
+ {$ENDIF}
+ New(Val);
+ InitializeVariant(Val, FType);
+ pc.Value := Val;
+ FConstants.Add(pc);
+ result := pc;
+end;
+
+function TPSPascalCompiler.ReadAttributes(Dest: TPSAttributes): Boolean;
+var
+ Att: TPSAttributeType;
+ at: TPSAttribute;
+ varp: PIfRVariant;
+ h, i: Longint;
+ s: tbtString;
+begin
+ if FParser.CurrTokenID <> CSTI_OpenBlock then begin Result := true; exit; end;
+ FParser.Next;
+ if FParser.CurrTokenID <> CSTI_Identifier then
+ begin
+ MakeError('', ecIdentifierExpected, '');
+ Result := False;
+ exit;
+ end;
+ s := FParser.GetToken;
+ h := MakeHash(s);
+ att := nil;
+ for i := FAttributeTypes.count -1 downto 0 do
+ begin
+ att := FAttributeTypes[i];
+ if (att.FNameHash = h) and (att.FName = s) then
+ Break;
+ att := nil;
+ end;
+ if att = nil then
+ begin
+ MakeError('', ecUnknownIdentifier, '');
+ Result := False;
+ exit;
+ end;
+ FParser.Next;
+ i := 0;
+ at := Dest.Add(att);
+ while att.Fields[i].Hidden do
+ begin
+ at.AddValue(NewVariant(at2ut(att.Fields[i].FieldType)));
+ inc(i);
+ end;
+ if FParser.CurrTokenId <> CSTI_OpenRound then
+ begin
+ MakeError('', ecOpenRoundExpected, '');
+ Result := False;
+ exit;
+ end;
+ FParser.Next;
+ if i < Att.FieldCount then
+ begin
+ while i < att.FieldCount do
+ begin
+ varp := ReadConstant(FParser, CSTI_CloseRound);
+ if varp = nil then
+ begin
+ Result := False;
+ exit;
+ end;
+ at.AddValue(varp);
+ if not IsCompatibleType(varp.FType, Att.Fields[i].FieldType, False) then
+ begin
+ MakeError('', ecTypeMismatch, '');
+ Result := False;
+ exit;
+ end;
+ Inc(i);
+ while (i < Att.FieldCount) and (att.Fields[i].Hidden) do
+ begin
+ at.AddValue(NewVariant(at2ut(att.Fields[i].FieldType)));
+ inc(i);
+ end;
+ if i >= Att.FieldCount then
+ begin
+ break;
+ end else
+ begin
+ if FParser.CurrTokenID <> CSTI_Comma then
+ begin
+ MakeError('', ecCommaExpected, '');
+ Result := False;
+ exit;
+ end;
+ end;
+ FParser.Next;
+ end;
+ end;
+ if FParser.CurrTokenID <> CSTI_CloseRound then
+ begin
+ MakeError('', ecCloseRoundExpected, '');
+ Result := False;
+ exit;
+ end;
+ FParser.Next;
+ if FParser.CurrTokenID <> CSTI_CloseBlock then
+ begin
+ MakeError('', ecCloseBlockExpected, '');
+ Result := False;
+ exit;
+ end;
+ FParser.Next;
+ Result := True;
+end;
+
+type
+ TConstOperation = class(TObject)
+ private
+ FDeclPosition, FDeclRow, FDeclCol: Cardinal;
+ public
+ property DeclPosition: Cardinal read FDeclPosition write FDeclPosition;
+ property DeclRow: Cardinal read FDeclRow write FDeclRow;
+ property DeclCol: Cardinal read FDeclCol write FDeclCol;
+ procedure SetPos(Parser: TPSPascalParser);
+ end;
+
+ TUnConstOperation = class(TConstOperation)
+ private
+ FOpType: TPSUnOperatorType;
+ FVal1: TConstOperation;
+ public
+ property OpType: TPSUnOperatorType read FOpType write FOpType;
+ property Val1: TConstOperation read FVal1 write FVal1;
+
+ destructor Destroy; override;
+ end;
+
+ TBinConstOperation = class(TConstOperation)
+ private
+ FOpType: TPSBinOperatorType;
+ FVal2: TConstOperation;
+ FVal1: TConstOperation;
+ public
+ property OpType: TPSBinOperatorType read FOpType write FOpType;
+ property Val1: TConstOperation read FVal1 write FVal1;
+ property Val2: TConstOperation read FVal2 write FVal2;
+
+ destructor Destroy; override;
+ end;
+
+ TConstData = class(TConstOperation)
+ private
+ FData: PIfRVariant;
+ public
+ property Data: PIfRVariant read FData write FData;
+ destructor Destroy; override;
+ end;
+
+
+function TPSPascalCompiler.IsBoolean(aType: TPSType): Boolean;
+begin
+ Result := (AType = FDefaultBoolType)
+ or (AType.Name = 'LONGBOOL')
+ or (AType.Name = 'WORDBOOL')
+ or (AType.Name = 'BYTEBOOL');
+end;
+
+
+function TPSPascalCompiler.ReadConstant(FParser: TPSPascalParser; StopOn: TPSPasToken): PIfRVariant;
+
+ function ReadExpression: TConstOperation; forward;
+ function ReadTerm: TConstOperation; forward;
+ function ReadFactor: TConstOperation;
+ var
+ NewVar: TConstOperation;
+ NewVarU: TUnConstOperation;
+ function GetConstantIdentifier: PIfRVariant;
+ var
+ s: tbtString;
+ sh: Longint;
+ i: Longint;
+ p: TPSConstant;
+ begin
+ s := FParser.GetToken;
+ sh := MakeHash(s);
+ for i := FConstants.Count -1 downto 0 do
+ begin
+ p := FConstants[I];
+ if (p.NameHash = sh) and (p.Name = s) then
+ begin
+ New(Result);
+ InitializeVariant(Result, p.Value.FType);
+ CopyVariantContents(P.Value, Result);
+ FParser.Next;
+ exit;
+ end;
+ end;
+ MakeError('', ecUnknownIdentifier, '');
+ Result := nil;
+ end;
+ begin
+ case fParser.CurrTokenID of
+ CSTII_Not:
+ begin
+ FParser.Next;
+ NewVar := ReadFactor;
+ if NewVar = nil then
+ begin
+ Result := nil;
+ exit;
+ end;
+ NewVarU := TUnConstOperation.Create;
+ NewVarU.OpType := otNot;
+ NewVarU.Val1 := NewVar;
+ NewVar := NewVarU;
+ end;
+ CSTI_Minus:
+ begin
+ FParser.Next;
+ NewVar := ReadTerm;
+ if NewVar = nil then
+ begin
+ Result := nil;
+ exit;
+ end;
+ NewVarU := TUnConstOperation.Create;
+ NewVarU.OpType := otMinus;
+ NewVarU.Val1 := NewVar;
+ NewVar := NewVarU;
+ end;
+ CSTI_OpenRound:
+ begin
+ FParser.Next;
+ NewVar := ReadExpression;
+ if NewVar = nil then
+ begin
+ Result := nil;
+ exit;
+ end;
+ if FParser.CurrTokenId <> CSTI_CloseRound then
+ begin
+ NewVar.Free;
+ Result := nil;
+ MakeError('', ecCloseRoundExpected, '');
+ exit;
+ end;
+ FParser.Next;
+ end;
+ CSTI_Char, CSTI_String:
+ begin
+ NewVar := TConstData.Create;
+ NewVar.SetPos(FParser);
+ TConstData(NewVar).Data := ReadString;
+ end;
+ CSTI_HexInt, CSTI_Integer:
+ begin
+ NewVar := TConstData.Create;
+ NewVar.SetPos(FParser);
+ TConstData(NewVar).Data := ReadInteger(FParser.GetToken);
+ FParser.Next;
+ end;
+ CSTI_Real:
+ begin
+ NewVar := TConstData.Create;
+ NewVar.SetPos(FParser);
+ TConstData(NewVar).Data := ReadReal(FParser.GetToken);
+ FParser.Next;
+ end;
+ CSTI_Identifier:
+ begin
+ NewVar := TConstData.Create;
+ NewVar.SetPos(FParser);
+ TConstData(NewVar).Data := GetConstantIdentifier;
+ if TConstData(NewVar).Data = nil then
+ begin
+ NewVar.Free;
+ Result := nil;
+ exit;
+ end
+ end;
+ else
+ begin
+ MakeError('', ecSyntaxError, '');
+ Result := nil;
+ exit;
+ end;
+ end; {case}
+ Result := NewVar;
+ end; // ReadFactor
+
+ function ReadTerm: TConstOperation;
+ var
+ F1, F2: TConstOperation;
+ F: TBinConstOperation;
+ Token: TPSPasToken;
+ Op: TPSBinOperatorType;
+ begin
+ F1 := ReadFactor;
+ if F1 = nil then
+ begin
+ Result := nil;
+ exit;
+ end;
+ while FParser.CurrTokenID in [CSTI_Multiply, CSTI_Divide, CSTII_Div, CSTII_Mod, CSTII_And, CSTII_Shl, CSTII_Shr] do
+ begin
+ Token := FParser.CurrTokenID;
+ FParser.Next;
+ F2 := ReadFactor;
+ if f2 = nil then
+ begin
+ f1.Free;
+ Result := nil;
+ exit;
+ end;
+ case Token of
+ CSTI_Multiply: Op := otMul;
+ CSTII_div, CSTI_Divide: Op := otDiv;
+ CSTII_mod: Op := otMod;
+ CSTII_and: Op := otAnd;
+ CSTII_shl: Op := otShl;
+ CSTII_shr: Op := otShr;
+ else
+ Op := otAdd;
+ end;
+ F := TBinConstOperation.Create;
+ f.Val1 := F1;
+ f.Val2 := F2;
+ f.OpType := Op;
+ f1 := f;
+ end;
+ Result := F1;
+ end; // ReadTerm
+
+ function ReadSimpleExpression: TConstOperation;
+ var
+ F1, F2: TConstOperation;
+ F: TBinConstOperation;
+ Token: TPSPasToken;
+ Op: TPSBinOperatorType;
+ begin
+ F1 := ReadTerm;
+ if F1 = nil then
+ begin
+ Result := nil;
+ exit;
+ end;
+ while FParser.CurrTokenID in [CSTI_Plus, CSTI_Minus, CSTII_Or, CSTII_Xor] do
+ begin
+ Token := FParser.CurrTokenID;
+ FParser.Next;
+ F2 := ReadTerm;
+ if f2 = nil then
+ begin
+ f1.Free;
+ Result := nil;
+ exit;
+ end;
+ case Token of
+ CSTI_Plus: Op := otAdd;
+ CSTI_Minus: Op := otSub;
+ CSTII_or: Op := otOr;
+ CSTII_xor: Op := otXor;
+ else
+ Op := otAdd;
+ end;
+ F := TBinConstOperation.Create;
+ f.Val1 := F1;
+ f.Val2 := F2;
+ f.OpType := Op;
+ f1 := f;
+ end;
+ Result := F1;
+ end; // ReadSimpleExpression
+
+
+ function ReadExpression: TConstOperation;
+ var
+ F1, F2: TConstOperation;
+ F: TBinConstOperation;
+ Token: TPSPasToken;
+ Op: TPSBinOperatorType;
+ begin
+ F1 := ReadSimpleExpression;
+ if F1 = nil then
+ begin
+ Result := nil;
+ exit;
+ end;
+ while FParser.CurrTokenID in [ CSTI_GreaterEqual, CSTI_LessEqual, CSTI_Greater, CSTI_Less, CSTI_Equal, CSTI_NotEqual] do
+ begin
+ Token := FParser.CurrTokenID;
+ FParser.Next;
+ F2 := ReadSimpleExpression;
+ if f2 = nil then
+ begin
+ f1.Free;
+ Result := nil;
+ exit;
+ end;
+ case Token of
+ CSTI_GreaterEqual: Op := otGreaterEqual;
+ CSTI_LessEqual: Op := otLessEqual;
+ CSTI_Greater: Op := otGreater;
+ CSTI_Less: Op := otLess;
+ CSTI_Equal: Op := otEqual;
+ CSTI_NotEqual: Op := otNotEqual;
+ else
+ Op := otAdd;
+ end;
+ F := TBinConstOperation.Create;
+ f.Val1 := F1;
+ f.Val2 := F2;
+ f.OpType := Op;
+ f1 := f;
+ end;
+ Result := F1;
+ end; // ReadExpression
+
+
+ function EvalConst(P: TConstOperation): PIfRVariant;
+ var
+ p1, p2: PIfRVariant;
+ begin
+ if p is TBinConstOperation then
+ begin
+ p1 := EvalConst(TBinConstOperation(p).Val1);
+ if p1 = nil then begin Result := nil; exit; end;
+ p2 := EvalConst(TBinConstOperation(p).Val2);
+ if p2 = nil then begin DisposeVariant(p1); Result := nil; exit; end;
+ if not PreCalc(False, 0, p1, 0, p2, TBinConstOperation(p).OpType, p.DeclPosition, p.DeclRow, p.DeclCol) then
+ begin
+ DisposeVariant(p1);
+ DisposeVariant(p2);
+// MakeError('', ecTypeMismatch, '');
+ result := nil;
+ exit;
+ end;
+ DisposeVariant(p2);
+ Result := p1;
+ end else if p is TUnConstOperation then
+ begin
+ with TUnConstOperation(P) do
+ begin
+ p1 := EvalConst(Val1);
+ case OpType of
+ otNot:
+ case p1.FType.BaseType of
+ btU8: p1.tu8 := not p1.tu8;
+ btU16: p1.tu16 := not p1.tu16;
+ btU32: p1.tu32 := not p1.tu32;
+ bts8: p1.ts8 := not p1.ts8;
+ bts16: p1.ts16 := not p1.ts16;
+ bts32: p1.ts32 := not p1.ts32;
+ {$IFNDEF PS_NOINT64}
+ bts64: p1.ts64 := not p1.ts64;
+ {$ENDIF}
+ else
+ begin
+ MakeError('', ecTypeMismatch, '');
+ DisposeVariant(p1);
+ Result := nil;
+ exit;
+ end;
+ end;
+ otMinus:
+ case p1.FType.BaseType of
+ btU8: p1.tu8 := -p1.tu8;
+ btU16: p1.tu16 := -p1.tu16;
+ btU32: p1.tu32 := -p1.tu32;
+ bts8: p1.ts8 := -p1.ts8;
+ bts16: p1.ts16 := -p1.ts16;
+ bts32: p1.ts32 := -p1.ts32;
+ {$IFNDEF PS_NOINT64}
+ bts64: p1.ts64 := -p1.ts64;
+ {$ENDIF}
+ btDouble: p1.tdouble := - p1.tDouble;
+ btSingle: p1.tsingle := - p1.tsingle;
+ btCurrency: p1.tcurrency := - p1.tcurrency;
+ btExtended: p1.textended := - p1.textended;
+ else
+ begin
+ MakeError('', ecTypeMismatch, '');
+ DisposeVariant(p1);
+ Result := nil;
+ exit;
+ end;
+ end;
+ else
+ begin
+ DisposeVariant(p1);
+ Result := nil;
+ exit;
+ end;
+ end;
+ end;
+ Result := p1;
+ end else
+ begin
+ if ((p as TConstData).Data.FType.BaseType = btString)
+ and (length(tbtstring((p as TConstData).Data.tstring)) =1) then
+ begin
+ New(p1);
+ InitializeVariant(p1, FindBaseType(btChar));
+ p1.tchar := tbtstring((p as TConstData).Data.tstring)[1];
+ Result := p1;
+ end else begin
+ New(p1);
+ InitializeVariant(p1, (p as TConstData).Data.FType);
+ CopyVariantContents((p as TConstData).Data, p1);
+ Result := p1;
+ end;
+ end;
+ end;
+
+var
+ Val: TConstOperation;
+begin
+ Val := ReadExpression;
+ if val = nil then
+ begin
+ Result := nil;
+ exit;
+ end;
+ Result := EvalConst(Val);
+ Val.Free;
+end;
+
+procedure TPSPascalCompiler.WriteDebugData(const s: tbtString);
+begin
+ FDebugOutput := FDebugOutput + s;
+end;
+
+function TPSPascalCompiler.GetDebugOutput(var s: tbtString): Boolean;
+begin
+ if Length(FDebugOutput) <> 0 then
+ begin
+ s := FDebugOutput;
+ Result := True;
+ end
+ else
+ Result := False;
+end;
+
+function TPSPascalCompiler.AddUsedFunction(var Proc: TPSInternalProcedure): Cardinal;
+begin
+ if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
+ Proc := TPSInternalProcedure.Create;
+ FProcs.Add(Proc);
+ Result := FProcs.Count - 1;
+end;
+
+{$IFNDEF PS_NOINTERFACES}
+const
+ IUnknown_Guid: TGuid = (D1: 0; d2: 0; d3: 0; d4: ($c0,00,00,00,00,00,00,$46));
+ IDispatch_Guid: Tguid = (D1: $20400; D2: $0; D3: $0; D4:($C0, $0, $0, $0, $0, $0, $0, $46));
+{$ENDIF}
+
+procedure TPSPascalCompiler.DefineStandardProcedures;
+var
+ p: TPSRegProc;
+begin
+ {$IFNDEF PS_NOINT64}
+ AddFunction('function IntToStr(i: Int64): String;');
+ {$ELSE}
+ AddFunction('function IntTostr(i: Integer): String;');
+ {$ENDIF}
+ AddFunction('function StrToInt(s: String): Longint;');
+ AddFunction('function StrToIntDef(s: String; def: Longint): Longint;');
+ AddFunction('function Copy(s: AnyString; iFrom, iCount: Longint): AnyString;');
+ AddFunction('function Pos(SubStr, S: AnyString): Longint;');
+ AddFunction('procedure Delete(var s: AnyString; ifrom, icount: Longint);');
+ AddFunction('procedure Insert(s: AnyString; var s2: AnyString; iPos: Longint);');
+ p := AddFunction('function GetArrayLength: integer;');
+ with P.Decl.AddParam do
+ begin
+ OrgName := 'arr';
+ Mode := pmInOut;
+ end;
+ p := AddFunction('procedure SetArrayLength;');
+ with P.Decl.AddParam do
+ begin
+ OrgName := 'arr';
+ Mode := pmInOut;
+ end;
+ with P.Decl.AddParam do
+ begin
+ OrgName := 'count';
+ aType := FindBaseType(btS32);
+ end;
+ AddFunction('Function StrGet(var S : String; I : Integer) : Char;');
+ AddFunction('Function StrGet2(S : String; I : Integer) : Char;');
+ AddFunction('procedure StrSet(c : Char; I : Integer; var s : String);');
+ {$IFNDEF PS_NOWIDESTRING}
+ AddFunction('Function WStrGet(var S : AnyString; I : Integer) : WideChar;');
+ AddFunction('procedure WStrSet(c : AnyString; I : Integer; var s : AnyString);');
+ {$ENDIF}
+ AddFunction('Function AnsiUppercase(s : String) : String;');
+ AddFunction('Function AnsiLowercase(s : String) : String;');
+ AddFunction('Function Uppercase(s : AnyString) : AnyString;');
+ AddFunction('Function Lowercase(s : AnyString) : AnyString;');
+ AddFunction('Function Trim(s : AnyString) : AnyString;');
+ AddFunction('function Length: Integer;').Decl.AddParam.OrgName:='s';
+ with AddFunction('procedure SetLength;').Decl do
+ begin
+ with AddParam do
+ begin
+ OrgName:='s';
+ Mode:=pmInOut;
+ end;
+ with AddParam do
+ begin
+ OrgName:='NewLength';
+ aType:=FindBaseType(btS32); //Integer
+ end;
+ end;
+ {$IFNDEF PS_NOINT64}
+ AddFunction('function Low: Int64;').Decl.AddParam.OrgName:='x';
+ AddFunction('function High: Int64;').Decl.AddParam.OrgName:='x';
+ {$ELSE}
+ AddFunction('function Low: Integer;').Decl.AddParam.OrgName:='x';
+ AddFunction('function High: Integer;').Decl.AddParam.OrgName:='x';
+ {$ENDIF}
+ with AddFunction('procedure Dec;').Decl do begin
+ with AddParam do
+ begin
+ OrgName:='x';
+ Mode:=pmInOut;
+ end;
+ end;
+ with AddFunction('procedure Inc;').Decl do begin
+ with AddParam do
+ begin
+ OrgName:='x';
+ Mode:=pmInOut;
+ end;
+ end;
+ AddFunction('Function Sin(e : Extended) : Extended;');
+ AddFunction('Function Cos(e : Extended) : Extended;');
+ AddFunction('Function Sqrt(e : Extended) : Extended;');
+ AddFunction('Function Round(e : Extended) : Longint;');
+ AddFunction('Function Trunc(e : Extended) : Longint;');
+ AddFunction('Function Int(e : Extended) : Extended;');
+ AddFunction('Function Pi : Extended;');
+ AddFunction('Function Abs(e : Extended) : Extended;');
+ AddFunction('function StrToFloat(s: String): Extended;');
+ AddFunction('Function FloatToStr(e : Extended) : String;');
+ AddFunction('Function Padl(s : AnyString;I : longInt) : AnyString;');
+ AddFunction('Function Padr(s : AnyString;I : longInt) : AnyString;');
+ AddFunction('Function Padz(s : AnyString;I : longInt) : AnyString;');
+ AddFunction('Function Replicate(c : char;I : longInt) : String;');
+ AddFunction('Function StringOfChar(c : char;I : longInt) : String;');
+ AddTypeS('TVarType', 'Word');
+ AddConstantN('varEmpty', 'Word').Value.tu16 := varempty;
+ AddConstantN('varNull', 'Word').Value.tu16 := varnull;
+ AddConstantN('varSmallInt', 'Word').Value.tu16 := varsmallint;
+ AddConstantN('varInteger', 'Word').Value.tu16 := varinteger;
+ AddConstantN('varSingle', 'Word').Value.tu16 := varsingle;
+ AddConstantN('varDouble', 'Word').Value.tu16 := vardouble;
+ AddConstantN('varCurrency', 'Word').Value.tu16 := varcurrency;
+ AddConstantN('varDate', 'Word').Value.tu16 := vardate;
+ AddConstantN('varOleStr', 'Word').Value.tu16 := varolestr;
+ AddConstantN('varDispatch', 'Word').Value.tu16 := vardispatch;
+ AddConstantN('varError', 'Word').Value.tu16 := varerror;
+ AddConstantN('varBoolean', 'Word').Value.tu16 := varboolean;
+ AddConstantN('varVariant', 'Word').Value.tu16 := varvariant;
+ AddConstantN('varUnknown', 'Word').Value.tu16 := varunknown;
+{$IFDEF DELPHI6UP}
+ AddConstantN('varShortInt', 'Word').Value.tu16 := varshortint;
+ AddConstantN('varByte', 'Word').Value.tu16 := varbyte;
+ AddConstantN('varWord', 'Word').Value.tu16 := varword;
+ AddConstantN('varLongWord', 'Word').Value.tu16 := varlongword;
+ AddConstantN('varInt64', 'Word').Value.tu16 := varint64;
+{$ENDIF}
+{$IFDEF DELPHI5UP}
+ AddConstantN('varStrArg', 'Word').Value.tu16 := varstrarg;
+ AddConstantN('varAny', 'Word').Value.tu16 := varany;
+{$ENDIF}
+ AddConstantN('varString', 'Word').Value.tu16 := varstring;
+ AddConstantN('varTypeMask', 'Word').Value.tu16 := vartypemask;
+ AddConstantN('varArray', 'Word').Value.tu16 := vararray;
+ AddConstantN('varByRef', 'Word').Value.tu16 := varByRef;
+{$IFDEF UNICODE}
+ AddConstantN('varUString', 'Word').Value.tu16 := varUString;
+{$ENDIF}
+ AddDelphiFunction('function Unassigned: Variant;');
+ AddDelphiFunction('function VarIsEmpty(const V: Variant): Boolean;');
+ AddDelphiFunction('function Null: Variant;');
+ AddDelphiFunction('function VarIsNull(const V: Variant): Boolean;');
+ AddDelphiFunction('function VarType(const V: Variant): TVarType;');
+ addTypeS('TIFException', '(ErNoError, erCannotImport, erInvalidType, ErInternalError, '+
+ 'erInvalidHeader, erInvalidOpcode, erInvalidOpcodeParameter, erNoMainProc, erOutOfGlobalVarsRange, '+
+ 'erOutOfProcRange, ErOutOfRange, erOutOfStackRange, ErTypeMismatch, erUnexpectedEof, '+
+ 'erVersionError, ErDivideByZero, ErMathError,erCouldNotCallProc, erOutofRecordRange, '+
+ 'erOutOfMemory, erException, erNullPointerException, erNullVariantError, erInterfaceNotSupported, erCustomError)');
+ AddFunction('procedure RaiseLastException;');
+ AddFunction('procedure RaiseException(Ex: TIFException; Param: String);');
+ AddFunction('function ExceptionType: TIFException;');
+ AddFunction('function ExceptionParam: String;');
+ AddFunction('function ExceptionProc: Cardinal;');
+ AddFunction('function ExceptionPos: Cardinal;');
+ AddFunction('function ExceptionToString(er: TIFException; Param: String): String;');
+ {$IFNDEF PS_NOINT64}
+ AddFunction('function StrToInt64(s: String): int64;');
+ AddFunction('function Int64ToStr(i: Int64): String;');
+ {$ENDIF}
+
+ with AddFunction('function SizeOf: Longint;').Decl.AddParam do
+ begin
+ OrgName := 'Data';
+ end;
+{$IFNDEF PS_NOINTERFACES}
+ with AddInterface(nil, IUnknown_Guid, 'IUnknown') do
+ begin
+ RegisterDummyMethod; // Query Interface
+ RegisterDummyMethod; // _AddRef
+ RegisterDummyMethod; // _Release
+ end;
+ with AddInterface(nil, IUnknown_Guid, 'IInterface') do
+ begin
+ RegisterDummyMethod; // Query Interface
+ RegisterDummyMethod; // _AddRef
+ RegisterDummyMethod; // _Release
+ end;
+
+ {$IFNDEF PS_NOIDISPATCH}
+ with AddInterface(FindInterface('IUnknown'), IDispatch_Guid, 'IDispatch') do
+ begin
+ RegisterDummyMethod; // GetTypeCount
+ RegisterDummyMethod; // GetTypeInfo
+ RegisterDummyMethod; // GetIdsOfName
+ RegisterDummyMethod; // Invoke
+ end;
+ with TPSInterfaceType(FindType('IDispatch')) do
+ begin
+ ExportName := True;
+ end;
+ AddDelphiFunction('function IDispatchInvoke(Self: IDispatch; PropertySet: Boolean; const Name: String; Par: array of variant): variant;');
+ {$ENDIF}
+{$ENDIF}
+end;
+
+function TPSPascalCompiler.GetTypeCount: Longint;
+begin
+ if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
+ Result := FTypes.Count;
+end;
+
+function TPSPascalCompiler.GetType(I: Longint): TPSType;
+begin
+ if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
+ Result := FTypes[I];
+end;
+
+function TPSPascalCompiler.GetVarCount: Longint;
+begin
+ if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
+ Result := FVars.Count;
+end;
+
+function TPSPascalCompiler.GetVar(I: Longint): TPSVar;
+begin
+ if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
+ Result := FVars[i];
+end;
+
+function TPSPascalCompiler.GetProcCount: Longint;
+begin
+ if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
+ Result := FProcs.Count;
+end;
+
+function TPSPascalCompiler.GetProc(I: Longint): TPSProcedure;
+begin
+ if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
+ Result := FProcs[i];
+end;
+
+
+
+
+function TPSPascalCompiler.AddUsedFunction2(var Proc: TPSExternalProcedure): Cardinal;
+begin
+ if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
+ Proc := TPSExternalProcedure.Create;
+ FProcs.Add(Proc);
+ Result := FProcs.Count -1;
+end;
+
+function TPSPascalCompiler.AddVariable(const Name: tbtString; FType: TPSType): TPSVar;
+var
+ P: TPSVar;
+begin
+ if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
+ if FType = nil then raise EPSCompilerException.CreateFmt(RPS_InvalidTypeForVar, [Name]);
+ p := TPSVar.Create;
+ p.OrgName := Name;
+ p.Name := Fastuppercase(Name);
+ p.FType := AT2UT(FType);
+ p.exportname := p.Name;
+ FVars.Add(p);
+ Result := P;
+end;
+
+function TPSPascalCompiler.AddAttributeType: TPSAttributeType;
+begin
+ if FAttributeTypes = nil then Raise Exception.Create(RPS_OnUseEventOnly);
+ Result := TPSAttributeType.Create;
+ FAttributeTypes.Add(Result);
+end;
+
+function TPSPascalCompiler.FindAttributeType(const Name: tbtString): TPSAttributeType;
+var
+ h, i: Integer;
+ n: tbtString;
+begin
+ if FAttributeTypes = nil then Raise Exception.Create(RPS_OnUseEventOnly);
+ n := FastUpperCase(Name);
+ h := MakeHash(n);
+ for i := FAttributeTypes.Count -1 downto 0 do
+ begin
+ result := TPSAttributeType(FAttributeTypes[i]);
+ if (Result.NameHash = h) and (Result.Name = n) then
+ exit;
+ end;
+ result := nil;
+end;
+function TPSPascalCompiler.GetConstCount: Longint;
+begin
+ if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
+ result := FConstants.Count;
+end;
+
+function TPSPascalCompiler.GetConst(I: Longint): TPSConstant;
+begin
+ if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
+ Result := TPSConstant(FConstants[i]);
+end;
+
+function TPSPascalCompiler.GetRegProcCount: Longint;
+begin
+ if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
+ Result := FRegProcs.Count;
+end;
+
+function TPSPascalCompiler.GetRegProc(I: Longint): TPSRegProc;
+begin
+ if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
+ Result := TPSRegProc(FRegProcs[i]);
+end;
+
+
+procedure TPSPascalCompiler.AddToFreeList(Obj: TObject);
+begin
+ FAutoFreeList.Add(Obj);
+end;
+
+function TPSPascalCompiler.AddConstantN(const Name,
+ FType: tbtString): TPSConstant;
+begin
+ Result := AddConstant(Name, FindType(FType));
+end;
+
+function TPSPascalCompiler.AddTypeCopy(const Name: tbtString;
+ TypeNo: TPSType): TPSType;
+begin
+ if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
+ TypeNo := GetTypeCopyLink(TypeNo);
+ if Typeno = nil then raise EPSCompilerException.Create(RPS_InvalidType);
+ Result := AddType(Name, BtTypeCopy);
+ TPSTypeLink(Result).LinkTypeNo := TypeNo;
+end;
+
+function TPSPascalCompiler.AddTypeCopyN(const Name,
+ FType: tbtString): TPSType;
+begin
+ Result := AddTypeCopy(Name, FindType(FType));
+end;
+
+
+function TPSPascalCompiler.AddUsedVariable(const Name: tbtString;
+ FType: TPSType): TPSVar;
+begin
+ Result := AddVariable(Name, FType);
+ if Result <> nil then
+ Result.Use;
+end;
+
+function TPSPascalCompiler.AddUsedVariableN(const Name,
+ FType: tbtString): TPSVar;
+begin
+ Result := AddVariable(Name, FindType(FType));
+ if Result <> nil then
+ Result.Use;
+end;
+
+function TPSPascalCompiler.AddVariableN(const Name,
+ FType: tbtString): TPSVar;
+begin
+ Result := AddVariable(Name, FindType(FType));
+end;
+
+function TPSPascalCompiler.AddUsedPtrVariable(const Name: tbtString; FType: TPSType): TPSVar;
+begin
+ Result := AddVariable(Name, FType);
+ if Result <> nil then
+ begin
+ result.SaveAsPointer := True;
+ Result.Use;
+ end;
+end;
+
+function TPSPascalCompiler.AddUsedPtrVariableN(const Name, FType: tbtString): TPSVar;
+begin
+ Result := AddVariable(Name, FindType(FType));
+ if Result <> nil then
+ begin
+ result.SaveAsPointer := True;
+ Result.Use;
+ end;
+end;
+
+function TPSPascalCompiler.AddTypeS(const Name, Decl: tbtString): TPSType;
+var
+ Parser: TPSPascalParser;
+begin
+ if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
+ Parser := TPSPascalParser.Create;
+ Parser.SetText(Decl);
+ Result := ReadType(Name, Parser);
+ if Result<>nil then
+ begin
+ Result.DeclarePos:=InvalidVal;
+ {$IFDEF PS_USESSUPPORT}
+ Result.DeclareUnit:=fModule;
+ {$ENDIF}
+ Result.DeclareRow:=0;
+ Result.DeclareCol:=0;
+ end;
+ Parser.Free;
+ if result = nil then Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterType, [name]);
+end;
+
+
+function TPSPascalCompiler.CheckCompatProc(P: TPSType; ProcNo: Cardinal): Boolean;
+var
+ i: Longint;
+ s1, s2: TPSParametersDecl;
+begin
+ if p.BaseType <> btProcPtr then begin
+ Result := False;
+ Exit;
+ end;
+
+ S1 := TPSProceduralType(p).ProcDef;
+
+ if TPSProcedure(FProcs[ProcNo]).ClassType = TPSInternalProcedure then
+ s2 := TPSInternalProcedure(FProcs[ProcNo]).Decl
+ else
+ s2 := TPSExternalProcedure(FProcs[ProcNo]).RegProc.Decl;
+ if (s1.Result <> s2.Result) or (s1.ParamCount <> s2.ParamCount) then
+ begin
+ Result := False;
+ Exit;
+ end;
+ for i := 0 to s1.ParamCount -1 do
+ begin
+ if (s1.Params[i].Mode <> s2.Params[i].Mode) or (s1.Params[i].aType <> s2.Params[i].aType) then
+ begin
+ Result := False;
+ Exit;
+ end;
+ end;
+ Result := True;
+end;
+
+function TPSPascalCompiler.MakeExportDecl(decl: TPSParametersDecl): tbtString;
+var
+ i: Longint;
+begin
+ if Decl.Result = nil then result := '-1' else
+ result := IntToStr(Decl.Result.FinalTypeNo);
+
+ for i := 0 to decl.ParamCount -1 do
+ begin
+ if decl.GetParam(i).Mode = pmIn then
+ Result := Result + ' @'
+ else
+ Result := Result + ' !';
+ Result := Result + inttostr(decl.GetParam(i).aType.FinalTypeNo);
+ end;
+end;
+
+
+function TPSPascalCompiler.IsIntBoolType(aType: TPSType): Boolean;
+begin
+ if Isboolean(aType) then begin Result := True; exit;end;
+
+ case aType.BaseType of
+ btU8, btS8, btU16, btS16, btU32, btS32{$IFNDEF PS_NOINT64}, btS64{$ENDIF}: Result := True;
+ else
+ Result := False;
+ end;
+end;
+
+
+procedure TPSPascalCompiler.ParserError(Parser: TObject;
+ Kind: TPSParserErrorKind);
+begin
+ FParserHadError := True;
+ case Kind of
+ ICOMMENTERROR: MakeError('', ecCommentError, '');
+ ISTRINGERROR: MakeError('', ecStringError, '');
+ ICHARERROR: MakeError('', ecCharError, '');
+ else
+ MakeError('', ecSyntaxError, '');
+ end;
+end;
+
+
+function TPSPascalCompiler.AddDelphiFunction(const Decl: tbtString): TPSRegProc;
+var
+ p: TPSRegProc;
+ pDecl: TPSParametersDecl;
+ DOrgName: tbtString;
+ FT: TPMFuncType;
+ i: Longint;
+
+begin
+ pDecl := TPSParametersDecl.Create;
+ p := nil;
+ try
+ if not ParseMethod(Self, '', Decl, DOrgName, pDecl, FT) then
+ Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Decl]);
+
+ p := TPSRegProc.Create;
+ P.Name := FastUppercase(DOrgName);
+ p.OrgName := DOrgName;
+ p.ExportName := True;
+ p.Decl.Assign(pDecl);
+
+ FRegProcs.Add(p);
+
+ if pDecl.Result = nil then
+ begin
+ p.ImportDecl := p.ImportDecl + #0;
+ end else
+ p.ImportDecl := p.ImportDecl + #1;
+ for i := 0 to pDecl.ParamCount -1 do
+ begin
+ if pDecl.Params[i].Mode <> pmIn then
+ p.ImportDecl := p.ImportDecl + #1
+ else
+ p.ImportDecl := p.ImportDecl + #0;
+ end;
+ finally
+ pDecl.Free;
+ end;
+ Result := p;
+end;
+
+{$IFNDEF PS_NOINTERFACES}
+function TPSPascalCompiler.AddInterface(InheritedFrom: TPSInterface; Guid: TGuid; const Name: tbtString): TPSInterface;
+var
+ f: TPSType;
+begin
+ if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
+ f := FindType(Name);
+ if (f <> nil) and (f is TPSInterfaceType) then
+ begin
+ result := TPSInterfaceType(f).Intf;
+ Result.Guid := Guid;
+ Result.InheritedFrom := InheritedFrom;
+ exit;
+ end;
+ f := AddType(Name, btInterface);
+ Result := TPSInterface.Create(Self, InheritedFrom, GUID, FastUppercase(Name), f);
+ FInterfaces.Add(Result);
+ TPSInterfaceType(f).Intf := Result;
+end;
+
+function TPSPascalCompiler.FindInterface(const Name: tbtString): TPSInterface;
+var
+ n: tbtString;
+ i, nh: Longint;
+begin
+ if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
+ n := FastUpperCase(Name);
+ nh := MakeHash(n);
+ for i := FInterfaces.Count -1 downto 0 do
+ begin
+ Result := FInterfaces[i];
+ if (Result.NameHash = nh) and (Result.Name = N) then
+ exit;
+ end;
+ raise EPSCompilerException.CreateFmt(RPS_UnknownInterface, [Name]);
+end;
+{$ENDIF}
+function TPSPascalCompiler.AddClass(InheritsFrom: TPSCompileTimeClass; aClass: TClass): TPSCompileTimeClass;
+var
+ f: TPSType;
+begin
+ if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
+ Result := FindClass(tbtstring(aClass.ClassName));
+ if Result <> nil then exit;
+ f := AddType(tbtstring(aClass.ClassName), btClass);
+ Result := TPSCompileTimeClass.CreateC(aClass, Self, f);
+ Result.FInheritsFrom := InheritsFrom;
+ FClasses.Add(Result);
+ TPSClassType(f).Cl := Result;
+ f.ExportName := True;
+end;
+
+function TPSPascalCompiler.AddClassN(InheritsFrom: TPSCompileTimeClass; const aClass: tbtString): TPSCompileTimeClass;
+var
+ f: TPSType;
+begin
+ if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
+ Result := FindClass(aClass);
+ if Result <> nil then
+ begin
+ if InheritsFrom <> nil then
+ Result.FInheritsFrom := InheritsFrom;
+ exit;
+ end;
+ f := AddType(aClass, btClass);
+ Result := TPSCompileTimeClass.Create(FastUppercase(aClass), Self, f);
+ TPSClassType(f).Cl := Result;
+ Result.FInheritsFrom := InheritsFrom;
+ FClasses.Add(Result);
+ TPSClassType(f).Cl := Result;
+ f.ExportName := True;
+end;
+
+function TPSPascalCompiler.FindClass(const aClass: tbtString): TPSCompileTimeClass;
+var
+ i: Longint;
+ Cl: tbtString;
+ H: Longint;
+ x: TPSCompileTimeClass;
+begin
+ cl := FastUpperCase(aClass);
+ H := MakeHash(Cl);
+ for i :=0 to FClasses.Count -1 do
+ begin
+ x := FClasses[I];
+ if (X.FClassNameHash = H) and (X.FClassName = Cl) then
+ begin
+ Result := X;
+ Exit;
+ end;
+ end;
+ Result := nil;
+end;
+
+
+
+{ }
+
+function TransDoubleToStr(D: Double): tbtString;
+begin
+ SetLength(Result, SizeOf(Double));
+ Double((@Result[1])^) := D;
+end;
+
+function TransSingleToStr(D: Single): tbtString;
+begin
+ SetLength(Result, SizeOf(Single));
+ Single((@Result[1])^) := D;
+end;
+
+function TransExtendedToStr(D: Extended): tbtString;
+begin
+ SetLength(Result, SizeOf(Extended));
+ Extended((@Result[1])^) := D;
+end;
+
+function TransLongintToStr(D: Longint): tbtString;
+begin
+ SetLength(Result, SizeOf(Longint));
+ Longint((@Result[1])^) := D;
+end;
+
+function TransCardinalToStr(D: Cardinal): tbtString;
+begin
+ SetLength(Result, SizeOf(Cardinal));
+ Cardinal((@Result[1])^) := D;
+end;
+
+function TransWordToStr(D: Word): tbtString;
+begin
+ SetLength(Result, SizeOf(Word));
+ Word((@Result[1])^) := D;
+end;
+
+function TransSmallIntToStr(D: SmallInt): tbtString;
+begin
+ SetLength(Result, SizeOf(SmallInt));
+ SmallInt((@Result[1])^) := D;
+end;
+
+function TransByteToStr(D: Byte): tbtString;
+begin
+ SetLength(Result, SizeOf(Byte));
+ Byte((@Result[1])^) := D;
+end;
+
+function TransShortIntToStr(D: ShortInt): tbtString;
+begin
+ SetLength(Result, SizeOf(ShortInt));
+ ShortInt((@Result[1])^) := D;
+end;
+
+function TPSPascalCompiler.GetConstant(const Name: tbtString): TPSConstant;
+var
+ h, i: Longint;
+ n: tbtString;
+
+begin
+ n := FastUppercase(name);
+ h := MakeHash(n);
+ for i := 0 to FConstants.Count -1 do
+ begin
+ result := TPSConstant(FConstants[i]);
+ if (Result.NameHash = h) and (Result.Name = n) then exit;
+ end;
+ result := nil;
+end;
+
+{ TPSType }
+
+constructor TPSType.Create;
+begin
+ inherited Create;
+ FAttributes := TPSAttributes.Create;
+ FFinalTypeNo := InvalidVal;
+end;
+
+destructor TPSType.Destroy;
+begin
+ FAttributes.Free;
+ inherited Destroy;
+end;
+
+procedure TPSType.SetName(const Value: tbtString);
+begin
+ FName := Value;
+ FNameHash := MakeHash(Value);
+end;
+
+procedure TPSType.Use;
+begin
+ FUsed := True;
+end;
+
+{ TPSRecordType }
+
+function TPSRecordType.AddRecVal: PIFPSRecordFieldTypeDef;
+begin
+ Result := TPSRecordFieldTypeDef.Create;
+ FRecordSubVals.Add(Result);
+end;
+
+constructor TPSRecordType.Create;
+begin
+ inherited Create;
+ FRecordSubVals := TPSList.Create;
+end;
+
+destructor TPSRecordType.Destroy;
+var
+ i: Longint;
+begin
+ for i := FRecordSubVals.Count -1 downto 0 do
+ TPSRecordFieldTypeDef(FRecordSubVals[I]).Free;
+ FRecordSubVals.Free;
+ inherited Destroy;
+end;
+
+function TPSRecordType.RecVal(I: Longint): PIFPSRecordFieldTypeDef;
+begin
+ Result := FRecordSubVals[I]
+end;
+
+function TPSRecordType.RecValCount: Longint;
+begin
+ Result := FRecordSubVals.Count;
+end;
+
+
+{ TPSRegProc }
+
+constructor TPSRegProc.Create;
+begin
+ inherited Create;
+ FDecl := TPSParametersDecl.Create;
+end;
+
+destructor TPSRegProc.Destroy;
+begin
+ FDecl.Free;
+ inherited Destroy;
+end;
+
+procedure TPSRegProc.SetName(const Value: tbtString);
+begin
+ FName := Value;
+ FNameHash := MakeHash(FName);
+end;
+
+{ TPSRecordFieldTypeDef }
+
+procedure TPSRecordFieldTypeDef.SetFieldOrgName(const Value: tbtString);
+begin
+ FFieldOrgName := Value;
+ FFieldName := FastUppercase(Value);
+ FFieldNameHash := MakeHash(FFieldName);
+end;
+
+{ TPSProcVar }
+
+procedure TPSProcVar.SetName(const Value: tbtString);
+begin
+ FName := Value;
+ FNameHash := MakeHash(FName);
+end;
+
+procedure TPSProcVar.Use;
+begin
+ FUsed := True;
+end;
+
+
+
+{ TPSInternalProcedure }
+
+constructor TPSInternalProcedure.Create;
+begin
+ inherited Create;
+ FProcVars := TPSList.Create;
+ FLabels := TIfStringList.Create;
+ FGotos := TIfStringList.Create;
+ FDecl := TPSParametersDecl.Create;
+end;
+
+destructor TPSInternalProcedure.Destroy;
+var
+ i: Longint;
+begin
+ FDecl.Free;
+ for i := FProcVars.Count -1 downto 0 do
+ TPSProcVar(FProcVars[I]).Free;
+ FProcVars.Free;
+ FGotos.Free;
+ FLabels.Free;
+ inherited Destroy;
+end;
+
+procedure TPSInternalProcedure.ResultUse;
+begin
+ FResultUsed := True;
+end;
+
+procedure TPSInternalProcedure.SetName(const Value: tbtString);
+begin
+ FName := Value;
+ FNameHash := MakeHash(FName);
+end;
+
+procedure TPSInternalProcedure.Use;
+begin
+ FUsed := True;
+end;
+
+{ TPSProcedure }
+constructor TPSProcedure.Create;
+begin
+ inherited Create;
+ FAttributes := TPSAttributes.Create;
+end;
+
+destructor TPSProcedure.Destroy;
+begin
+ FAttributes.Free;
+ inherited Destroy;
+end;
+
+{ TPSVar }
+
+procedure TPSVar.SetName(const Value: tbtString);
+begin
+ FName := Value;
+ FNameHash := MakeHash(Value);
+end;
+
+procedure TPSVar.Use;
+begin
+ FUsed := True;
+end;
+
+{ TPSConstant }
+
+destructor TPSConstant.Destroy;
+begin
+ DisposeVariant(Value);
+ inherited Destroy;
+end;
+
+procedure TPSConstant.SetChar(c: tbtChar);
+begin
+ if (FValue <> nil) then
+ begin
+ case FValue.FType.BaseType of
+ btChar: FValue.tchar := c;
+ btString: tbtString(FValue.tstring) := c;
+ {$IFNDEF PS_NOWIDESTRING}
+ btWideString: tbtwidestring(FValue.twidestring) := tbtWidestring(c);
+ btUnicodeString: tbtUnicodestring(FValue.twidestring) := tbtUnicodestring(c);
+ {$ENDIF}
+ else
+ raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
+ end;
+ end else
+ raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
+end;
+
+procedure TPSConstant.SetExtended(const Val: Extended);
+begin
+ if (FValue <> nil) then
+ begin
+ case FValue.FType.BaseType of
+ btSingle: FValue.tsingle := Val;
+ btDouble: FValue.tdouble := Val;
+ btExtended: FValue.textended := Val;
+ btCurrency: FValue.tcurrency := Val;
+ else
+ raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
+ end;
+ end else
+ raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
+end;
+
+procedure TPSConstant.SetInt(const Val: Longint);
+begin
+ if (FValue <> nil) then
+ begin
+ case FValue.FType.BaseType of
+ btEnum: FValue.tu32 := Val;
+ btU32, btS32: FValue.ts32 := Val;
+ btU16, btS16: FValue.ts16 := Val;
+ btU8, btS8: FValue.ts8 := Val;
+ btSingle: FValue.tsingle := Val;
+ btDouble: FValue.tdouble := Val;
+ btExtended: FValue.textended := Val;
+ btCurrency: FValue.tcurrency := Val;
+ {$IFNDEF PS_NOINT64}
+ bts64: FValue.ts64 := Val;
+ {$ENDIF}
+ else
+ raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
+ end;
+ end else
+ raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
+end;
+{$IFNDEF PS_NOINT64}
+procedure TPSConstant.SetInt64(const Val: Int64);
+begin
+ if (FValue <> nil) then
+ begin
+ case FValue.FType.BaseType of
+ btEnum: FValue.tu32 := Val;
+ btU32, btS32: FValue.ts32 := Val;
+ btU16, btS16: FValue.ts16 := Val;
+ btU8, btS8: FValue.ts8 := Val;
+ btSingle: FValue.tsingle := Val;
+ btDouble: FValue.tdouble := Val;
+ btExtended: FValue.textended := Val;
+ btCurrency: FValue.tcurrency := Val;
+ bts64: FValue.ts64 := Val;
+ else
+ raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
+ end;
+ end else
+ raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
+end;
+{$ENDIF}
+procedure TPSConstant.SetName(const Value: tbtString);
+begin
+ FName := Value;
+ FNameHash := MakeHash(Value);
+end;
+
+
+procedure TPSConstant.SetSet(const val);
+begin
+ if (FValue <> nil) then
+ begin
+ case FValue.FType.BaseType of
+ btSet:
+ begin
+ if length(tbtstring(FValue.tstring)) <> TPSSetType(FValue.FType).ByteSize then
+ SetLength(tbtstring(FValue.tstring), TPSSetType(FValue.FType).ByteSize);
+ Move(Val, FValue.tstring^, TPSSetType(FValue.FType).ByteSize);
+ end;
+ else
+ raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
+ end;
+ end else
+ raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
+end;
+
+procedure TPSConstant.SetString(const Val: tbtString);
+begin
+ if (FValue <> nil) then
+ begin
+ case FValue.FType.BaseType of
+ btChar: FValue.tchar := (Val+#0)[1];
+ btWideChar: FValue.twidechar := WideChar((Val+#0)[1]);
+ btString: tbtString(FValue.tstring) := val;
+ {$IFNDEF PS_NOWIDESTRING}
+ btWideString: tbtwidestring(FValue.twidestring) := tbtwidestring(val);
+ btUnicodeString: tbtunicodestring(FValue.tunistring) := tbtunicodestring(val);
+ {$ENDIF}
+ else
+ raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
+ end;
+ end else
+ raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
+end;
+
+procedure TPSConstant.SetUInt(const Val: Cardinal);
+begin
+ if (FValue <> nil) then
+ begin
+ case FValue.FType.BaseType of
+ btEnum: FValue.tu32 := Val;
+ btU32, btS32: FValue.tu32 := Val;
+ btU16, btS16: FValue.tu16 := Val;
+ btU8, btS8: FValue.tu8 := Val;
+ btSingle: FValue.tsingle := Val;
+ btDouble: FValue.tdouble := Val;
+ btExtended: FValue.textended := Val;
+ btCurrency: FValue.tcurrency := Val;
+ {$IFNDEF PS_NOINT64}
+ bts64: FValue.ts64 := Val;
+ {$ENDIF}
+ else
+ raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
+ end;
+ end else
+ raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
+end;
+
+{$IFNDEF PS_NOWIDESTRING}
+procedure TPSConstant.SetWideChar(const val: WideChar);
+begin
+ if (FValue <> nil) then
+ begin
+ case FValue.FType.BaseType of
+ btString: tbtString(FValue.tstring) := tbtstring(val);
+ btWideChar: FValue.twidechar := val;
+ btWideString: tbtwidestring(FValue.twidestring) := val;
+ btUnicodeString: tbtUnicodestring(FValue.tUniString) := val;
+ else
+ raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
+ end;
+ end else
+ raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
+end;
+
+procedure TPSConstant.SetWideString(const val: tbtwidestring);
+begin
+ if (FValue <> nil) then
+ begin
+ case FValue.FType.BaseType of
+ btString: tbtString(FValue.tstring) := tbtstring(val);
+ btWideString: tbtwidestring(FValue.twidestring) := val;
+ btUnicodeString: tbtunicodestring(FValue.tunistring) := val;
+ else
+ raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
+ end;
+ end else
+ raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
+end;
+procedure TPSConstant.SetUnicodeString(const val: tbtunicodestring);
+begin
+ if (FValue <> nil) then
+ begin
+ case FValue.FType.BaseType of
+ btString: tbtString(FValue.tstring) := tbtstring(val);
+ btWideString: tbtwidestring(FValue.twidestring) := val;
+ btUnicodeString: tbtunicodestring(FValue.tunistring) := val;
+ else
+ raise EPSCompilerException.Create(RPS_ConstantValueMismatch);
+ end;
+ end else
+ raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned)
+end;
+{$ENDIF}
+{ TPSPascalCompilerError }
+
+function TPSPascalCompilerError.ErrorType: tbtString;
+begin
+ Result := tbtstring(RPS_Error);
+end;
+
+function TPSPascalCompilerError.ShortMessageToString: tbtString;
+begin
+ case Error of
+ ecUnknownIdentifier: Result := tbtstring(Format (RPS_UnknownIdentifier, [Param]));
+ ecIdentifierExpected: Result := tbtstring(RPS_IdentifierExpected);
+ ecCommentError: Result := tbtstring(RPS_CommentError);
+ ecStringError: Result := tbtstring(RPS_StringError);
+ ecCharError: Result := tbtstring(RPS_CharError);
+ ecSyntaxError: Result := tbtstring(RPS_SyntaxError);
+ ecUnexpectedEndOfFile: Result := tbtstring(RPS_EOF);
+ ecSemicolonExpected: Result := tbtstring(RPS_SemiColonExpected);
+ ecBeginExpected: Result := tbtstring(RPS_BeginExpected);
+ ecPeriodExpected: Result := tbtstring(RPS_PeriodExpected);
+ ecDuplicateIdentifier: Result := tbtstring(Format (RPS_DuplicateIdent, [Param]));
+ ecColonExpected: Result := tbtstring(RPS_ColonExpected);
+ ecUnknownType: Result := tbtstring(Format (RPS_UnknownType, [Param]));
+ ecCloseRoundExpected: Result := tbtstring(RPS_CloseRoundExpected);
+ ecTypeMismatch: Result := tbtstring(RPS_TypeMismatch);
+ ecInternalError: Result := tbtstring(Format (RPS_InternalError, [Param]));
+ ecAssignmentExpected: Result := tbtstring(RPS_AssignmentExpected);
+ ecThenExpected: Result := tbtstring(RPS_ThenExpected);
+ ecDoExpected: Result := tbtstring(RPS_DoExpected);
+ ecNoResult: Result := tbtstring(RPS_NoResult);
+ ecOpenRoundExpected: Result := tbtstring(RPS_OpenRoundExpected);
+ ecCommaExpected: Result := tbtstring(RPS_CommaExpected);
+ ecToExpected: Result := tbtstring(RPS_ToExpected);
+ ecIsExpected: Result := tbtstring(RPS_IsExpected);
+ ecOfExpected: Result := tbtstring(RPS_OfExpected);
+ ecCloseBlockExpected: Result := tbtstring(RPS_CloseBlockExpected);
+ ecVariableExpected: Result := tbtstring(RPS_VariableExpected);
+ ecStringExpected: result := tbtstring(RPS_StringExpected);
+ ecEndExpected: Result := tbtstring(RPS_EndExpected);
+ ecUnSetLabel: Result := tbtstring(Format (RPS_UnSetLabel, [Param]));
+ ecNotInLoop: Result := tbtstring(RPS_NotInLoop);
+ ecInvalidJump: Result := tbtstring(RPS_InvalidJump);
+ ecOpenBlockExpected: Result := tbtstring(RPS_OpenBlockExpected);
+ ecWriteOnlyProperty: Result := tbtstring(RPS_WriteOnlyProperty);
+ ecReadOnlyProperty: Result := tbtstring(RPS_ReadOnlyProperty);
+ ecClassTypeExpected: Result := tbtstring(RPS_ClassTypeExpected);
+ ecCustomError: Result := Param;
+ ecDivideByZero: Result := tbtstring(RPS_DivideByZero);
+ ecMathError: Result := tbtstring(RPS_MathError);
+ ecUnsatisfiedForward: Result := tbtstring(Format (RPS_UnsatisfiedForward, [Param]));
+ ecForwardParameterMismatch: Result := tbtstring(RPS_ForwardParameterMismatch);
+ ecInvalidnumberOfParameters: Result := tbtstring(RPS_InvalidNumberOfParameter);
+ {$IFDEF PS_USESSUPPORT}
+ ecNotAllowed : Result:=tbtstring(Format(RPS_NotAllowed,[Param]));
+ ecUnitNotFoundOrContainsErrors: Result:=tbtstring(Format(RPS_UnitNotFound,[Param]));
+ {$ENDIF}
+ else
+ Result := tbtstring(RPS_UnknownError);
+ end;
+ Result := Result;
+end;
+
+
+{ TPSPascalCompilerHint }
+
+function TPSPascalCompilerHint.ErrorType: tbtString;
+begin
+ Result := tbtstring(RPS_Hint);
+end;
+
+function TPSPascalCompilerHint.ShortMessageToString: tbtString;
+begin
+ case Hint of
+ ehVariableNotUsed: Result := tbtstring(Format (RPS_VariableNotUsed, [Param]));
+ ehFunctionNotUsed: Result := tbtstring(Format (RPS_FunctionNotUsed, [Param]));
+ ehCustomHint: Result := Param;
+ else
+ Result := tbtstring(RPS_UnknownHint);
+ end;
+end;
+
+{ TPSPascalCompilerWarning }
+
+function TPSPascalCompilerWarning.ErrorType: tbtString;
+begin
+ Result := tbtstring(RPS_Warning);
+end;
+
+function TPSPascalCompilerWarning.ShortMessageToString: tbtString;
+begin
+ case Warning of
+ ewCustomWarning: Result := Param;
+ ewCalculationAlwaysEvaluatesTo: Result := tbtstring(Format (RPS_CalculationAlwaysEvaluatesTo, [Param]));
+ ewIsNotNeeded: Result := tbtstring(Format (RPS_IsNotNeeded, [Param]));
+ ewAbstractClass: Result := tbtstring(RPS_AbstractClass);
+ else
+ Result := tbtstring(RPS_UnknownWarning);
+ end;
+end;
+
+{ TPSPascalCompilerMessage }
+
+function TPSPascalCompilerMessage.MessageToString: tbtString;
+begin
+ Result := '['+ErrorType+'] '+FModuleName+'('+IntToStr(FRow)+':'+IntToStr(FCol)+'): '+ShortMessageToString;
+end;
+
+procedure TPSPascalCompilerMessage.SetParserPos(Parser: TPSPascalParser);
+begin
+ FPosition := Parser.CurrTokenPos;
+ FRow := Parser.Row;
+ FCol := Parser.Col;
+end;
+
+procedure TPSPascalCompilerMessage.SetCustomPos(Pos, Row, Col: Cardinal);
+begin
+ FPosition := Pos;
+ FRow := Row;
+ FCol := Col;
+end;
+
+{ TUnConstOperation }
+
+destructor TUnConstOperation.Destroy;
+begin
+ FVal1.Free;
+ inherited Destroy;
+end;
+
+
+{ TBinConstOperation }
+
+destructor TBinConstOperation.Destroy;
+begin
+ FVal1.Free;
+ FVal2.Free;
+ inherited Destroy;
+end;
+
+{ TConstData }
+
+destructor TConstData.Destroy;
+begin
+ DisposeVariant(FData);
+ inherited Destroy;
+end;
+
+
+{ TConstOperation }
+
+procedure TConstOperation.SetPos(Parser: TPSPascalParser);
+begin
+ FDeclPosition := Parser.CurrTokenPos;
+ FDeclRow := Parser.Row;
+ FDeclCol := Parser.Col;
+end;
+
+{ TPSValue }
+
+procedure TPSValue.SetParserPos(P: TPSPascalParser);
+begin
+ FPos := P.CurrTokenPos;
+ FRow := P.Row;
+ FCol := P.Col;
+end;
+
+{ TPSValueData }
+
+destructor TPSValueData.Destroy;
+begin
+ DisposeVariant(FData);
+ inherited Destroy;
+end;
+
+
+{ TPSValueReplace }
+
+constructor TPSValueReplace.Create;
+begin
+ FFreeNewValue := True;
+ FReplaceTimes := 1;
+end;
+
+destructor TPSValueReplace.Destroy;
+begin
+ if FFreeOldValue then
+ FOldValue.Free;
+ if FFreeNewValue then
+ FNewValue.Free;
+ inherited Destroy;
+end;
+
+
+
+{ TPSUnValueOp }
+
+destructor TPSUnValueOp.Destroy;
+begin
+ FVal1.Free;
+ inherited Destroy;
+end;
+
+{ TPSBinValueOp }
+
+destructor TPSBinValueOp.Destroy;
+begin
+ FVal1.Free;
+ FVal2.Free;
+ inherited Destroy;
+end;
+
+
+
+
+{ TPSSubValue }
+
+destructor TPSSubValue.Destroy;
+begin
+ FSubNo.Free;
+ inherited Destroy;
+end;
+
+{ TPSValueVar }
+
+constructor TPSValueVar.Create;
+begin
+ inherited Create;
+ FRecItems := TPSList.Create;
+end;
+
+destructor TPSValueVar.Destroy;
+var
+ i: Longint;
+begin
+ for i := 0 to FRecItems.Count -1 do
+ begin
+ TPSSubItem(FRecItems[I]).Free;
+ end;
+ FRecItems.Free;
+ inherited Destroy;
+end;
+
+function TPSValueVar.GetRecCount: Cardinal;
+begin
+ Result := FRecItems.Count;
+end;
+
+function TPSValueVar.GetRecItem(I: Cardinal): TPSSubItem;
+begin
+ Result := FRecItems[I];
+end;
+
+function TPSValueVar.RecAdd(Val: TPSSubItem): Cardinal;
+begin
+ Result := FRecItems.Add(Val);
+end;
+
+procedure TPSValueVar.RecDelete(I: Cardinal);
+var
+ rr :TPSSubItem;
+begin
+ rr := FRecItems[i];
+ FRecItems.Delete(I);
+ rr.Free;
+end;
+
+{ TPSValueProc }
+
+destructor TPSValueProc.Destroy;
+begin
+ FSelfPtr.Free;
+ FParameters.Free;
+end;
+{ TPSParameter }
+
+destructor TPSParameter.Destroy;
+begin
+ FTempVar.Free;
+ FValue.Free;
+ inherited Destroy;
+end;
+
+
+ { TPSParameters }
+
+function TPSParameters.Add: TPSParameter;
+begin
+ Result := TPSParameter.Create;
+ FItems.Add(Result);
+end;
+
+constructor TPSParameters.Create;
+begin
+ inherited Create;
+ FItems := TPSList.Create;
+end;
+
+procedure TPSParameters.Delete(I: Cardinal);
+var
+ p: TPSParameter;
+begin
+ p := FItems[I];
+ FItems.Delete(i);
+ p.Free;
+end;
+
+destructor TPSParameters.Destroy;
+var
+ i: Longint;
+begin
+ for i := FItems.Count -1 downto 0 do
+ begin
+ TPSParameter(FItems[I]).Free;
+ end;
+ FItems.Free;
+ inherited Destroy;
+end;
+
+function TPSParameters.GetCount: Cardinal;
+begin
+ Result := FItems.Count;
+end;
+
+function TPSParameters.GetItem(I: Longint): TPSParameter;
+begin
+ Result := FItems[I];
+end;
+
+
+{ TPSValueArray }
+
+function TPSValueArray.Add(Item: TPSValue): Cardinal;
+begin
+ Result := FItems.Add(Item);
+end;
+
+constructor TPSValueArray.Create;
+begin
+ inherited Create;
+ FItems := TPSList.Create;
+end;
+
+procedure TPSValueArray.Delete(I: Cardinal);
+begin
+ FItems.Delete(i);
+end;
+
+destructor TPSValueArray.Destroy;
+var
+ i: Longint;
+begin
+ for i := FItems.Count -1 downto 0 do
+ TPSValue(FItems[I]).Free;
+ FItems.Free;
+
+ inherited Destroy;
+end;
+
+function TPSValueArray.GetCount: Cardinal;
+begin
+ Result := FItems.Count;
+end;
+
+function TPSValueArray.GetItem(I: Cardinal): TPSValue;
+begin
+ Result := FItems[I];
+end;
+
+
+{ TPSValueAllocatedStackVar }
+
+destructor TPSValueAllocatedStackVar.Destroy;
+var
+ pv: TPSProcVar;
+begin
+ {$IFDEF DEBUG}
+ if Cardinal(LocalVarNo +1) <> proc.ProcVars.Count then
+ begin
+ Abort;
+ exit;
+ end;
+ {$ENDIF}
+ if Proc <> nil then
+ begin
+ pv := Proc.ProcVars[Proc.ProcVars.Count -1];
+ Proc.ProcVars.Delete(Proc.ProcVars.Count -1);
+ pv.Free;
+ Proc.Data := Proc.Data + tbtChar(CM_PO);
+ end;
+ inherited Destroy;
+end;
+
+
+
+
+function AddImportedClassVariable(Sender: TPSPascalCompiler; const VarName, VarType: tbtString): Boolean;
+var
+ P: TPSVar;
+begin
+ P := Sender.AddVariableN(VarName, VarType);
+ if p = nil then
+ begin
+ Result := False;
+ Exit;
+ end;
+ SetVarExportName(P, FastUppercase(VarName));
+ p.Use;
+ Result := True;
+end;
+
+
+{'class:'+CLASSNAME+'|'+FUNCNAME+'|'+chr(CallingConv)+chr(hasresult)+params
+
+For property write functions there is an '@' after the funcname.
+}
+
+const
+ ProcHDR = 'procedure a;';
+
+
+
+{ TPSCompileTimeClass }
+
+function TPSCompileTimeClass.CastToType(IntoType: TPSType;
+ var ProcNo: Cardinal): Boolean;
+var
+ P: TPSExternalProcedure;
+begin
+ if (IntoType <> nil) and (IntoType.BaseType <> btClass) and (IntoType.BaseType <> btInterface) then
+ begin
+ Result := False;
+ exit;
+ end;
+ if FCastProc <> InvalidVal then
+ begin
+ Procno := FCastProc;
+ Result := True;
+ exit;
+ end;
+ ProcNo := FOwner. AddUsedFunction2(P);
+ P.RegProc := FOwner.AddFunction(ProcHDR);
+ P.RegProc.Name := '';
+
+ with P.RegProc.Decl.AddParam do
+ begin
+ OrgName := 'Org';
+ aType := Self.FType;
+ end;
+ with P.RegProc.Decl.AddParam do
+ begin
+ OrgName := 'TypeNo';
+ aType := FOwner.at2ut(FOwner.FindBaseType(btU32));
+ end;
+ P.RegProc.Decl.Result := IntoType;
+ P.RegProc.ImportDecl := 'class:+';
+ FCastProc := ProcNo;
+ Result := True;
+end;
+
+
+function TPSCompileTimeClass.ClassFunc_Call(Index: IPointer;
+ var ProcNo: Cardinal): Boolean;
+var
+ C: TPSDelphiClassItemConstructor;
+ P: TPSExternalProcedure;
+ s: tbtString;
+ i: Longint;
+
+begin
+ if FIsAbstract then
+ FOwner.MakeWarning('', ewAbstractClass, '');
+ C := Pointer(Index);
+ if c.MethodNo = InvalidVal then
+ begin
+ ProcNo := FOwner.AddUsedFunction2(P);
+ P.RegProc := FOwner.AddFunction(ProcHDR);
+ P.RegProc.Name := '';
+ P.RegProc.Decl.Assign(c.Decl);
+ s := 'class:' + C.Owner.FClassName + '|' + C.Name + '|'+ chr(0);
+ if c.Decl.Result = nil then
+ s := s + #0
+ else
+ s := s + #1;
+ for i := 0 to C.Decl.ParamCount -1 do
+ begin
+ if c.Decl.Params[i].Mode <> pmIn then
+ s := s + #1
+ else
+ s := s + #0;
+ end;
+ P.RegProc.ImportDecl := s;
+ C.MethodNo := ProcNo;
+ end else begin
+ ProcNo := c.MethodNo;
+ end;
+ Result := True;
+end;
+
+function TPSCompileTimeClass.ClassFunc_Find(const Name: tbtString;
+ var Index: IPointer): Boolean;
+var
+ H: Longint;
+ I: Longint;
+ CurrClass: TPSCompileTimeClass;
+ C: TPSDelphiClassItem;
+begin
+ H := MakeHash(Name);
+ CurrClass := Self;
+ while CurrClass <> nil do
+ begin
+ for i := CurrClass.FClassItems.Count -1 downto 0 do
+ begin
+ C := CurrClass.FClassItems[I];
+ if (c is TPSDelphiClassItemConstructor) and (C.NameHash = H) and (C.Name = Name) then
+ begin
+ Index := Cardinal(C);
+ Result := True;
+ exit;
+ end;
+ end;
+ CurrClass := CurrClass.FInheritsFrom;
+ end;
+ Result := False;
+end;
+
+
+class function TPSCompileTimeClass.CreateC(FClass: TClass; aOwner: TPSPascalCompiler; aType: TPSType): TPSCompileTimeClass;
+begin
+ Result := TPSCompileTimeClass.Create(FastUpperCase(tbtstring(FClass.ClassName)), aOwner, aType);
+ Result.FClass := FClass;
+end;
+
+constructor TPSCompileTimeClass.Create(ClassName: tbtString; aOwner: TPSPascalCompiler; aType: TPSType);
+begin
+ inherited Create;
+ FType := aType;
+ FCastProc := InvalidVal;
+ FNilProc := InvalidVal;
+
+ FDefaultProperty := InvalidVal;
+ FClassName := Classname;
+ FClassNameHash := MakeHash(FClassName);
+ FClassItems := TPSList.Create;
+ FOwner := aOwner;
+end;
+
+destructor TPSCompileTimeClass.Destroy;
+var
+ I: Longint;
+begin
+ for i := FClassItems.Count -1 downto 0 do
+ TPSDelphiClassItem(FClassItems[I]).Free;
+ FClassItems.Free;
+ inherited Destroy;
+end;
+
+
+function TPSCompileTimeClass.Func_Call(Index: IPointer;
+ var ProcNo: Cardinal): Boolean;
+var
+ C: TPSDelphiClassItemMethod;
+ P: TPSExternalProcedure;
+ i: Longint;
+ s: tbtString;
+
+begin
+ C := Pointer(Index);
+ if c.MethodNo = InvalidVal then
+ begin
+ ProcNo := FOwner.AddUsedFunction2(P);
+ P.RegProc := FOwner.AddFunction(ProcHDR);
+ P.RegProc.Name := '';
+ p.RegProc.Decl.Assign(c.Decl);
+ s := 'class:' + C.Owner.FClassName + '|' + C.Name + '|'+ chr(0);
+ if c.Decl.Result = nil then
+ s := s + #0
+ else
+ s := s + #1;
+ for i := 0 to c.Decl.ParamCount -1 do
+ begin
+ if c.Decl.Params[i].Mode <> pmIn then
+ s := s + #1
+ else
+ s := s + #0;
+ end;
+ P.RegProc.ImportDecl := s;
+ C.MethodNo := ProcNo;
+ end else begin
+ ProcNo := c.MethodNo;
+ end;
+ Result := True;
+end;
+
+function TPSCompileTimeClass.Func_Find(const Name: tbtString;
+ var Index: IPointer): Boolean;
+var
+ H: Longint;
+ I: Longint;
+ CurrClass: TPSCompileTimeClass;
+ C: TPSDelphiClassItem;
+begin
+ H := MakeHash(Name);
+ CurrClass := Self;
+ while CurrClass <> nil do
+ begin
+ for i := CurrClass.FClassItems.Count -1 downto 0 do
+ begin
+ C := CurrClass.FClassItems[I];
+ if (c is TPSDelphiClassItemMethod) and (C.NameHash = H) and (C.Name = Name) then
+ begin
+ Index := Cardinal(C);
+ Result := True;
+ exit;
+ end;
+ end;
+ CurrClass := CurrClass.FInheritsFrom;
+ end;
+ Result := False;
+end;
+
+function TPSCompileTimeClass.GetCount: Longint;
+begin
+ Result := FClassItems.Count;
+end;
+
+function TPSCompileTimeClass.GetItem(i: Longint): TPSDelphiClassItem;
+begin
+ Result := FClassItems[i];
+end;
+
+function TPSCompileTimeClass.IsCompatibleWith(aType: TPSType): Boolean;
+var
+ Temp: TPSCompileTimeClass;
+begin
+ if (atype.BaseType <> btClass) then
+ begin
+ Result := False;
+ exit;
+ end;
+ temp := TPSClassType(aType).Cl;
+ while Temp <> nil do
+ begin
+ if Temp = Self then
+ begin
+ Result := True;
+ exit;
+ end;
+ Temp := Temp.FInheritsFrom;
+ end;
+ Result := False;
+end;
+
+function TPSCompileTimeClass.Property_Find(const Name: tbtString;
+ var Index: IPointer): Boolean;
+var
+ H: Longint;
+ I: Longint;
+ CurrClass: TPSCompileTimeClass;
+ C: TPSDelphiClassItem;
+begin
+ if Name = '' then
+ begin
+ CurrClass := Self;
+ while CurrClass <> nil do
+ begin
+ if CurrClass.FDefaultProperty <> InvalidVal then
+ begin
+ Index := Cardinal(CurrClass.FClassItems[Currclass.FDefaultProperty]);
+ result := True;
+ exit;
+ end;
+ CurrClass := CurrClass.FInheritsFrom;
+ end;
+ Result := False;
+ exit;
+ end;
+ H := MakeHash(Name);
+ CurrClass := Self;
+ while CurrClass <> nil do
+ begin
+ for i := CurrClass.FClassItems.Count -1 downto 0 do
+ begin
+ C := CurrClass.FClassItems[I];
+ if (c is TPSDelphiClassItemProperty) and (C.NameHash = H) and (C.Name = Name) then
+ begin
+ Index := Cardinal(C);
+ Result := True;
+ exit;
+ end;
+ end;
+ CurrClass := CurrClass.FInheritsFrom;
+ end;
+ Result := False;
+end;
+
+function TPSCompileTimeClass.Property_Get(Index: IPointer;
+ var ProcNo: Cardinal): Boolean;
+var
+ C: TPSDelphiClassItemProperty;
+ P: TPSExternalProcedure;
+ s: tbtString;
+
+begin
+ C := Pointer(Index);
+ if c.AccessType = iptW then
+ begin
+ Result := False;
+ exit;
+ end;
+ if c.ReadProcNo = InvalidVal then
+ begin
+ ProcNo := FOwner.AddUsedFunction2(P);
+ P.RegProc := FOwner.AddFunction(ProcHDR);
+ P.RegProc.Name := '';
+ P.RegProc.Decl.Result := C.Decl.Result;
+ s := 'class:' + C.Owner.FClassName + '|' + C.Name + '|'+#0#0#0#0;
+ Longint((@(s[length(s)-3]))^) := c.Decl.ParamCount +1;
+ P.RegProc.ImportDecl := s;
+ C.ReadProcNo := ProcNo;
+ end else begin
+ ProcNo := c.ReadProcNo;
+ end;
+ Result := True;
+end;
+
+function TPSCompileTimeClass.Property_GetHeader(Index: IPointer;
+ Dest: TPSParametersDecl): Boolean;
+var
+ c: TPSDelphiClassItemProperty;
+begin
+ C := Pointer(Index);
+ FOwner.UseProc(c.Decl);
+ Dest.Assign(c.Decl);
+ Result := True;
+end;
+
+function TPSCompileTimeClass.Property_Set(Index: IPointer;
+ var ProcNo: Cardinal): Boolean;
+var
+ C: TPSDelphiClassItemProperty;
+ P: TPSExternalProcedure;
+ s: tbtString;
+
+begin
+ C := Pointer(Index);
+ if c.AccessType = iptR then
+ begin
+ Result := False;
+ exit;
+ end;
+ if c.WriteProcNo = InvalidVal then
+ begin
+ ProcNo := FOwner.AddUsedFunction2(P);
+ P.RegProc := FOwner.AddFunction(ProcHDR);
+ P.RegProc.Name := '';
+ s := 'class:' + C.Owner.FClassName + '|' + C.Name + '@|'#0#0#0#0;
+ Longint((@(s[length(s)-3]))^) := C.Decl.ParamCount+1;
+ P.RegProc.ImportDecl := s;
+ C.WriteProcNo := ProcNo;
+ end else begin
+ ProcNo := c.WriteProcNo;
+ end;
+ Result := True;
+end;
+
+function TPSCompileTimeClass.RegisterMethod(const Decl: tbtString): Boolean;
+var
+ DOrgName: tbtString;
+ DDecl: TPSParametersDecl;
+ FT: TPMFuncType;
+ p: TPSDelphiClassItemMethod;
+begin
+ DDecl := TPSParametersDecl.Create;
+ try
+ if not ParseMethod(FOwner, FClassName, Decl, DOrgName, DDecl, FT) then
+ begin
+ Result := False;
+ {$IFDEF DEBUG} raise EPSCompilerException.CreateFmt(RPS_UnableToRegister, [Decl]); {$ENDIF}
+ exit;
+ end;
+ if ft = mftConstructor then
+ p := TPSDelphiClassItemConstructor.Create(Self)
+ else
+ p := TPSDelphiClassItemMethod.Create(self);
+ p.OrgName := DOrgName;
+ p.Decl.Assign(DDecl);
+ p.MethodNo := InvalidVal;
+ FClassItems.Add(p);
+ Result := True;
+ finally
+ DDecl.Free;
+ end;
+end;
+
+procedure TPSCompileTimeClass.RegisterProperty(const PropertyName,
+ PropertyType: tbtString; PropAC: TPSPropType);
+var
+ FType: TPSType;
+ Param: TPSParameterDecl;
+ p: TPSDelphiClassItemProperty;
+ PT: tbtString;
+begin
+ pt := PropertyType;
+ p := TPSDelphiClassItemProperty.Create(Self);
+ p.AccessType := PropAC;
+ p.ReadProcNo := InvalidVal;
+ p.WriteProcNo := InvalidVal;
+ p.OrgName := PropertyName;
+ repeat
+ FType := FOwner.FindType(FastUpperCase(grfw(pt)));
+ if FType = nil then
+ begin
+ p.Free;
+ Exit;
+ end;
+ if p.Decl.Result = nil then p.Decl.Result := FType else
+ begin
+ param := p.Decl.AddParam;
+ Param.OrgName := 'param'+IntToStr(p.Decl.ParamCount);
+ Param.aType := FType;
+ end;
+ until pt = '';
+ FClassItems.Add(p);
+end;
+
+
+procedure TPSCompileTimeClass.RegisterPublishedProperties;
+var
+ p: PPropList;
+ i, Count: Longint;
+ a: TPSPropType;
+begin
+ if (Fclass = nil) or (Fclass.ClassInfo = nil) then exit;
+ Count := GetTypeData(fclass.ClassInfo)^.PropCount;
+ GetMem(p, Count * SizeOf(Pointer));
+ GetPropInfos(fclass.ClassInfo, p);
+ for i := Count -1 downto 0 do
+ begin
+ if p^[i]^.PropType^.Kind in [tkLString, tkInteger, tkChar, tkEnumeration, tkFloat, tkString, tkSet, tkClass, tkMethod{$IFNDEF PS_NOWIDESTRING}, tkWString{$ENDIF}] then
+ begin
+ if (p^[i]^.GetProc <> nil) then
+ begin
+ if p^[i]^.SetProc = nil then
+ a := iptr
+ else
+ a := iptrw;
+ end else
+ begin
+ a := iptW;
+ if p^[i]^.SetProc = nil then continue;
+ end;
+ RegisterProperty(p^[i]^.Name, p^[i]^.PropType^.Name, a);
+ end;
+ end;
+ FreeMem(p);
+end;
+
+function TPSCompileTimeClass.RegisterPublishedProperty(const Name: tbtString): Boolean;
+var
+ p: PPropInfo;
+ a: TPSPropType;
+begin
+ if (Fclass = nil) or (Fclass.ClassInfo = nil) then begin Result := False; exit; end;
+ p := GetPropInfo(fclass.ClassInfo, string(Name));
+ if p = nil then begin Result := False; exit; end;
+ if (p^.GetProc <> nil) then
+ begin
+ if p^.SetProc = nil then
+ a := iptr
+ else
+ a := iptrw;
+ end else
+ begin
+ a := iptW;
+ if p^.SetProc = nil then begin result := False; exit; end;
+ end;
+ RegisterProperty(p^.Name, p^.PropType^.Name, a);
+ Result := True;
+end;
+
+
+procedure TPSCompileTimeClass.SetDefaultPropery(const Name: tbtString);
+var
+ i,h: Longint;
+ p: TPSDelphiClassItem;
+ s: tbtString;
+
+begin
+ s := FastUppercase(name);
+ h := MakeHash(s);
+ for i := FClassItems.Count -1 downto 0 do
+ begin
+ p := FClassItems[i];
+ if (p.NameHash = h) and (p.Name = s) then
+ begin
+ if p is TPSDelphiClassItemProperty then
+ begin
+ if p.Decl.ParamCount = 0 then
+ Raise EPSCompilerException.Create(RPS_NotArrayProperty);
+ FDefaultProperty := I;
+ exit;
+ end else Raise EPSCompilerException.Create(RPS_NotProperty);
+ end;
+ end;
+ raise EPSCompilerException.Create(RPS_UnknownProperty);
+end;
+
+function TPSCompileTimeClass.SetNil(var ProcNo: Cardinal): Boolean;
+var
+ P: TPSExternalProcedure;
+
+begin
+ if FNilProc <> InvalidVal then
+ begin
+ Procno := FNilProc;
+ Result := True;
+ exit;
+ end;
+ ProcNo := FOwner.AddUsedFunction2(P);
+ P.RegProc := FOwner.AddFunction(ProcHDR);
+ P.RegProc.Name := '';
+ with P.RegProc.Decl.AddParam do
+ begin
+ OrgName := 'VarNo';
+ aType := FOwner.at2ut(FType);
+ end;
+ P.RegProc.ImportDecl := 'class:-';
+ FNilProc := Procno;
+ Result := True;
+end;
+
+{ TPSSetType }
+
+function TPSSetType.GetBitSize: Longint;
+begin
+ case SetType.BaseType of
+ btEnum: begin Result := TPSEnumType(setType).HighValue+1; end;
+ btChar, btU8: Result := 256;
+ else
+ Result := 0;
+ end;
+end;
+
+function TPSSetType.GetByteSize: Longint;
+var
+ r: Longint;
+begin
+ r := BitSize;
+ if r mod 8 <> 0 then inc(r, 7);
+ Result := r div 8;
+end;
+
+
+{ TPSBlockInfo }
+
+procedure TPSBlockInfo.Clear;
+var
+ i: Longint;
+begin
+ for i := WithList.Count -1 downto 0 do
+ begin
+ TPSValue(WithList[i]).Free;
+ WithList.Delete(i);
+ end;
+end;
+
+constructor TPSBlockInfo.Create(Owner: TPSBlockInfo);
+begin
+ inherited Create;
+ FOwner := Owner;
+ FWithList := TPSList.Create;
+ if FOwner <> nil then
+ begin
+ FProcNo := FOwner.ProcNo;
+ FProc := FOwner.Proc;
+ end;
+end;
+
+destructor TPSBlockInfo.Destroy;
+begin
+ Clear;
+ FWithList.Free;
+ inherited Destroy;
+end;
+
+{ TPSAttributeTypeField }
+procedure TPSAttributeTypeField.SetFieldOrgName(const Value: tbtString);
+begin
+ FFieldOrgName := Value;
+ FFieldName := FastUpperCase(Value);
+ FFieldNameHash := MakeHash(FFieldName);
+end;
+
+constructor TPSAttributeTypeField.Create(AOwner: TPSAttributeType);
+begin
+ inherited Create;
+ FOwner := AOwner;
+end;
+
+{ TPSAttributeType }
+
+function TPSAttributeType.GetField(I: Longint): TPSAttributeTypeField;
+begin
+ Result := TPSAttributeTypeField(FFields[i]);
+end;
+
+function TPSAttributeType.GetFieldCount: Longint;
+begin
+ Result := FFields.Count;
+end;
+
+procedure TPSAttributeType.SetName(const s: tbtString);
+begin
+ FOrgname := s;
+ FName := FastUppercase(s);
+ FNameHash := MakeHash(FName);
+end;
+
+constructor TPSAttributeType.Create;
+begin
+ inherited Create;
+ FFields := TPSList.Create;
+end;
+
+destructor TPSAttributeType.Destroy;
+var
+ i: Longint;
+begin
+ for i := FFields.Count -1 downto 0 do
+ begin
+ TPSAttributeTypeField(FFields[i]).Free;
+ end;
+ FFields.Free;
+ inherited Destroy;
+end;
+
+function TPSAttributeType.AddField: TPSAttributeTypeField;
+begin
+ Result := TPSAttributeTypeField.Create(self);
+ FFields.Add(Result);
+end;
+
+procedure TPSAttributeType.DeleteField(I: Longint);
+var
+ Fld: TPSAttributeTypeField;
+begin
+ Fld := FFields[i];
+ FFields.Delete(i);
+ Fld.Free;
+end;
+
+{ TPSAttribute }
+function TPSAttribute.GetValueCount: Longint;
+begin
+ Result := FValues.Count;
+end;
+
+function TPSAttribute.GetValue(I: Longint): PIfRVariant;
+begin
+ Result := FValues[i];
+end;
+
+constructor TPSAttribute.Create(AttribType: TPSAttributeType);
+begin
+ inherited Create;
+ FValues := TPSList.Create;
+ FAttribType := AttribType;
+end;
+
+procedure TPSAttribute.DeleteValue(i: Longint);
+var
+ Val: PIfRVariant;
+begin
+ Val := FValues[i];
+ FValues.Delete(i);
+ DisposeVariant(Val);
+end;
+
+function TPSAttribute.AddValue(v: PIFRVariant): Longint;
+begin
+ Result := FValues.Add(v);
+end;
+
+
+destructor TPSAttribute.Destroy;
+var
+ i: Longint;
+begin
+ for i := FValues.Count -1 downto 0 do
+ begin
+ DisposeVariant(FValues[i]);
+ end;
+ FValues.Free;
+ inherited Destroy;
+end;
+
+
+procedure TPSAttribute.Assign(Item: TPSAttribute);
+var
+ i: Longint;
+ p: PIfRVariant;
+begin
+ for i := FValues.Count -1 downto 0 do
+ begin
+ DisposeVariant(FValues[i]);
+ end;
+ FValues.Clear;
+ FAttribType := Item.FAttribType;
+ for i := 0 to Item.FValues.Count -1 do
+ begin
+ p := DuplicateVariant(Item.FValues[i]);
+ FValues.Add(p);
+ end;
+end;
+
+{ TPSAttributes }
+
+function TPSAttributes.GetCount: Longint;
+begin
+ Result := FItems.Count;
+end;
+
+function TPSAttributes.GetItem(I: Longint): TPSAttribute;
+begin
+ Result := TPSAttribute(FItems[i]);
+end;
+
+procedure TPSAttributes.Delete(i: Longint);
+var
+ item: TPSAttribute;
+begin
+ item := TPSAttribute(FItems[i]);
+ FItems.Delete(i);
+ Item.Free;
+end;
+
+function TPSAttributes.Add(AttribType: TPSAttributeType): TPSAttribute;
+begin
+ Result := TPSAttribute.Create(AttribType);
+ FItems.Add(Result);
+end;
+
+constructor TPSAttributes.Create;
+begin
+ inherited Create;
+ FItems := TPSList.Create;
+end;
+
+destructor TPSAttributes.Destroy;
+var
+ i: Longint;
+begin
+ for i := FItems.Count -1 downto 0 do
+ begin
+ TPSAttribute(FItems[i]).Free;
+ end;
+ FItems.Free;
+ inherited Destroy;
+end;
+
+procedure TPSAttributes.Assign(attr: TPSAttributes; Move: Boolean);
+var
+ newitem, item: TPSAttribute;
+ i: Longint;
+begin
+ for i := ATtr.FItems.Count -1 downto 0 do
+ begin
+ Item := Attr.Fitems[i];
+ if Move then
+ begin
+ FItems.Add(Item);
+ Attr.FItems.Delete(i);
+ end else
+ begin
+ newitem := TPSAttribute.Create(Item.FAttribType );
+ newitem.Assign(item);
+ FItems.Add(NewItem);
+ end;
+ end;
+
+end;
+
+
+function TPSAttributes.FindAttribute(
+ const Name: tbtString): TPSAttribute;
+var
+ h, i: Longint;
+
+begin
+ h := MakeHash(name);
+ for i := FItems.Count -1 downto 0 do
+ begin
+ Result := FItems[i];
+ if (Result.FAttribType.NameHash = h) and (Result.FAttribType.Name = Name) then
+ exit;
+ end;
+ result := nil;
+end;
+
+{ TPSParameterDecl }
+procedure TPSParameterDecl.SetName(const s: tbtString);
+begin
+ FOrgName := s;
+ FName := FastUppercase(s);
+end;
+
+
+{ TPSParametersDecl }
+
+procedure TPSParametersDecl.Assign(Params: TPSParametersDecl);
+var
+ i: Longint;
+ np, orgp: TPSParameterDecl;
+begin
+ for i := FParams.Count -1 downto 0 do
+ begin
+ TPSParameterDecl(Fparams[i]).Free;
+ end;
+ FParams.Clear;
+ FResult := Params.Result;
+
+ for i := 0 to Params.FParams.count -1 do
+ begin
+ orgp := Params.FParams[i];
+ np := AddParam;
+ np.OrgName := orgp.OrgName;
+ np.Mode := orgp.Mode;
+ np.aType := orgp.aType;
+ np.DeclarePos:=orgp.DeclarePos;
+ np.DeclareRow:=orgp.DeclareRow;
+ np.DeclareCol:=orgp.DeclareCol;
+ end;
+end;
+
+
+function TPSParametersDecl.GetParam(I: Longint): TPSParameterDecl;
+begin
+ Result := FParams[i];
+end;
+
+function TPSParametersDecl.GetParamCount: Longint;
+begin
+ Result := FParams.Count;
+end;
+
+function TPSParametersDecl.AddParam: TPSParameterDecl;
+begin
+ Result := TPSParameterDecl.Create;
+ FParams.Add(Result);
+end;
+
+procedure TPSParametersDecl.DeleteParam(I: Longint);
+var
+ param: TPSParameterDecl;
+begin
+ param := FParams[i];
+ FParams.Delete(i);
+ Param.Free;
+end;
+
+constructor TPSParametersDecl.Create;
+begin
+ inherited Create;
+ FParams := TPSList.Create;
+end;
+
+destructor TPSParametersDecl.Destroy;
+var
+ i: Longint;
+begin
+ for i := FParams.Count -1 downto 0 do
+ begin
+ TPSParameterDecl(Fparams[i]).Free;
+ end;
+ FParams.Free;
+ inherited Destroy;
+end;
+
+function TPSParametersDecl.Same(d: TPSParametersDecl): boolean;
+var
+ i: Longint;
+begin
+ if (d = nil) or (d.ParamCount <> ParamCount) or (d.Result <> Self.Result) then
+ Result := False
+ else begin
+ for i := 0 to d.ParamCount -1 do
+ begin
+ if (d.Params[i].Mode <> Params[i].Mode) or (d.Params[i].aType <> Params[i].aType) then
+ begin
+ Result := False;
+ exit;
+ end;
+ end;
+ Result := True;
+ end;
+end;
+
+{ TPSProceduralType }
+
+constructor TPSProceduralType.Create;
+begin
+ inherited Create;
+ FProcDef := TPSParametersDecl.Create;
+
+end;
+
+destructor TPSProceduralType.Destroy;
+begin
+ FProcDef.Free;
+ inherited Destroy;
+end;
+
+{ TPSDelphiClassItem }
+
+procedure TPSDelphiClassItem.SetName(const s: tbtString);
+begin
+ FOrgName := s;
+ FName := FastUpperCase(s);
+ FNameHash := MakeHash(FName);
+end;
+
+constructor TPSDelphiClassItem.Create(Owner: TPSCompileTimeClass);
+begin
+ inherited Create;
+ FOwner := Owner;
+ FDecl := TPSParametersDecl.Create;
+end;
+
+destructor TPSDelphiClassItem.Destroy;
+begin
+ FDecl.Free;
+ inherited Destroy;
+end;
+
+{$IFNDEF PS_NOINTERFACES}
+{ TPSInterface }
+
+function TPSInterface.CastToType(IntoType: TPSType;
+ var ProcNo: Cardinal): Boolean;
+var
+ P: TPSExternalProcedure;
+begin
+ if (IntoType <> nil) and (IntoType.BaseType <> btInterface) then
+ begin
+ Result := False;
+ exit;
+ end;
+ if FCastProc <> InvalidVal then
+ begin
+ ProcNo := FCastProc;
+ Result := True;
+ exit;
+ end;
+ ProcNo := FOwner.AddUsedFunction2(P);
+ P.RegProc := FOwner.AddFunction(ProcHDR);
+ P.RegProc.Name := '';
+ with P.RegProc.Decl.AddParam do
+ begin
+ OrgName := 'Org';
+ aType := Self.FType;
+ end;
+ with P.RegProc.Decl.AddParam do
+ begin
+ OrgName := 'TypeNo';
+ aType := FOwner.at2ut(FOwner.FindBaseType(btU32));
+ end;
+ P.RegProc.Decl.Result := FOwner.at2ut(IntoType);
+
+ P.RegProc.ImportDecl := 'class:+';
+ FCastProc := ProcNo;
+ Result := True;
+end;
+
+constructor TPSInterface.Create(Owner: TPSPascalCompiler; InheritedFrom: TPSInterface; Guid: TGuid; const Name: tbtString; aType: TPSType);
+begin
+ inherited Create;
+ FCastProc := InvalidVal;
+ FNilProc := InvalidVal;
+
+ FType := aType;
+ FOWner := Owner;
+ FGuid := GUID;
+ Self.InheritedFrom := InheritedFrom;
+
+ FItems := TPSList.Create;
+ FName := Name;
+ FNameHash := MakeHash(Name);
+end;
+
+procedure TPSInterface.SetInheritedFrom(p: TPSInterface);
+begin
+ FInheritedFrom := p;
+end;
+
+destructor TPSInterface.Destroy;
+var
+ i: Longint;
+begin
+ for i := FItems.Count -1 downto 0 do
+ begin
+ TPSInterfaceMethod(FItems[i]).Free;
+ end;
+ FItems.Free;
+ inherited Destroy;
+end;
+
+function TPSInterface.Func_Call(Index: Cardinal;
+ var ProcNo: Cardinal): Boolean;
+var
+ c: TPSInterfaceMethod;
+ P: TPSExternalProcedure;
+ s: tbtString;
+ i: Longint;
+begin
+ c := TPSInterfaceMethod(Index);
+ if c.FScriptProcNo <> InvalidVal then
+ begin
+ Procno := c.FScriptProcNo;
+ Result := True;
+ exit;
+ end;
+ ProcNo := FOwner.AddUsedFunction2(P);
+ P.RegProc := FOwner.AddFunction(ProcHDR);
+ P.RegProc.Name := '';
+ FOwner.UseProc(C.Decl);
+ P.RegProc.Decl.Assign(c.Decl);
+ s := tbtstring('intf:.') + PS_mi2s(c.AbsoluteProcOffset) + tbtchar(ord(c.CC));
+ if c.Decl.Result = nil then
+ s := s + #0
+ else
+ s := s + #1;
+ for i := 0 to C.Decl.ParamCount -1 do
+ begin
+ if c.Decl.Params[i].Mode <> pmIn then
+ s := s + #1
+ else
+ s := s + #0;
+ end;
+ P.RegProc.ImportDecl := s;
+ C.FScriptProcNo := ProcNo;
+ Result := True;
+end;
+
+function TPSInterface.Func_Find(const Name: tbtString;
+ var Index: Cardinal): Boolean;
+var
+ H: Longint;
+ I: Longint;
+ CurrClass: TPSInterface;
+ C: TPSInterfaceMethod;
+begin
+ H := MakeHash(Name);
+ CurrClass := Self;
+ while CurrClass <> nil do
+ begin
+ for i := CurrClass.FItems.Count -1 downto 0 do
+ begin
+ C := CurrClass.FItems[I];
+ if (C.NameHash = H) and (C.Name = Name) then
+ begin
+ Index := Cardinal(c);
+ Result := True;
+ exit;
+ end;
+ end;
+ CurrClass := CurrClass.FInheritedFrom;
+ end;
+ Result := False;
+end;
+
+function TPSInterface.IsCompatibleWith(aType: TPSType): Boolean;
+var
+ Temp: TPSInterface;
+begin
+ if (atype.BaseType = btClass) then // just support it, we'll see what happens
+ begin
+ Result := true;
+ exit;
+ end;
+ if atype.BaseType <> btInterface then
+ begin
+ Result := False;
+ exit;
+ end;
+ temp := TPSInterfaceType(atype).FIntf;
+ while Temp <> nil do
+ begin
+ if Temp = Self then
+ begin
+ Result := True;
+ exit;
+ end;
+ Temp := Temp.FInheritedFrom;
+ end;
+ Result := False;
+end;
+
+procedure TPSInterface.RegisterDummyMethod;
+begin
+ FItems.Add(TPSInterfaceMethod.Create(self));
+end;
+
+function TPSInterface.RegisterMethod(const Declaration: tbtString;
+ const cc: TPSCallingConvention): Boolean;
+var
+ M: TPSInterfaceMethod;
+ DOrgName: tbtString;
+ Func: TPMFuncType;
+begin
+ M := TPSInterfaceMethod.Create(Self);
+ if not ParseMethod(FOwner, '', Declaration, DOrgname, m.Decl, Func) then
+ begin
+ FItems.Add(m); // in any case, add a dummy item
+ Result := False;
+ exit;
+ end;
+ m.FName := FastUppercase(DOrgName);
+ m.FOrgName := DOrgName;
+ m.FNameHash := MakeHash(m.FName);
+ m.FCC := CC;
+ m.FScriptProcNo := InvalidVal;
+ FItems.Add(M);
+ Result := True;
+end;
+
+
+function TPSInterface.SetNil(var ProcNo: Cardinal): Boolean;
+var
+ P: TPSExternalProcedure;
+
+begin
+ if FNilProc <> InvalidVal then
+ begin
+ Procno := FNilProc;
+ Result := True;
+ exit;
+ end;
+ ProcNo := FOwner.AddUsedFunction2(P);
+ P.RegProc := FOwner.AddFunction(ProcHDR);
+ P.RegProc.Name := '';
+ with p.RegProc.Decl.AddParam do
+ begin
+ Mode := pmInOut;
+ OrgName := 'VarNo';
+ aType := FOwner.at2ut(Self.FType);
+ end;
+ P.RegProc.ImportDecl := 'class:-';
+ FNilProc := Procno;
+ Result := True;
+end;
+
+{ TPSInterfaceMethod }
+
+constructor TPSInterfaceMethod.Create(Owner: TPSInterface);
+begin
+ inherited Create;
+ FDecl := TPSParametersDecl.Create;
+ FOwner := Owner;
+ FOffsetCache := InvalidVal;
+end;
+
+function TPSInterfaceMethod.GetAbsoluteProcOffset: Cardinal;
+var
+ ps: TPSInterface;
+begin
+ if FOffsetCache = InvalidVal then
+ begin
+ FOffsetCache := FOwner.FItems.IndexOf(Self);
+ ps := FOwner.FInheritedFrom;
+ while ps <> nil do
+ begin
+ FOffsetCache := FOffsetCache + ps.FItems.Count;
+ ps := ps.FInheritedFrom;
+ end;
+ end;
+ result := FOffsetCache;
+end;
+
+
+destructor TPSInterfaceMethod.Destroy;
+begin
+ FDecl.Free;
+ inherited Destroy;
+end;
+{$ENDIF}
+
+{ TPSVariantType }
+
+function TPSVariantType.GetDynInvokeParamType(Owner: TPSPascalCompiler) : TPSType;
+begin
+ Result := Owner.at2ut(FindAndAddType(owner, '!OPENARRAYOFVARIANT', 'array of variant'));
+end;
+
+function TPSVariantType.GetDynInvokeProcNo(Owner: TPSPascalCompiler; const Name: tbtString;
+ Params: TPSParameters): Cardinal;
+begin
+ Result := Owner.FindProc('IDISPATCHINVOKE');
+end;
+
+function TPSVariantType.GetDynIvokeResulType(
+ Owner: TPSPascalCompiler): TPSType;
+begin
+ Result := Owner.FindType('VARIANT');
+end;
+
+function TPSVariantType.GetDynIvokeSelfType(Owner: TPSPascalCompiler): TPSType;
+begin
+ Result := Owner.at2ut(Owner.FindType('IDISPATCH'));
+end;
+
+
+{ TPSExternalClass }
+function TPSExternalClass.SetNil(var ProcNo: Cardinal): Boolean;
+begin
+ Result := False;
+end;
+
+constructor TPSExternalClass.Create(Se: TIFPSPascalCompiler; TypeNo: TPSType);
+begin
+ inherited Create;
+ Self.SE := se;
+ Self.FTypeNo := TypeNo;
+end;
+
+function TPSExternalClass.Func_Call(Index: Cardinal;
+ var ProcNo: Cardinal): Boolean;
+begin
+ Result := False;
+end;
+
+function TPSExternalClass.Func_Find(const Name: tbtString;
+ var Index: Cardinal): Boolean;
+begin
+ Result := False;
+end;
+
+function TPSExternalClass.IsCompatibleWith(
+ Cl: TPSExternalClass): Boolean;
+begin
+ Result := False;
+end;
+
+function TPSExternalClass.SelfType: TPSType;
+begin
+ Result := nil;
+end;
+
+function TPSExternalClass.CastToType(IntoType: TPSType;
+ var ProcNo: Cardinal): Boolean;
+begin
+ Result := False;
+end;
+
+function TPSExternalClass.CompareClass(OtherTypeNo: TPSType;
+ var ProcNo: Cardinal): Boolean;
+begin
+ Result := false;
+end;
+
+function TPSExternalClass.ClassFunc_Find(const Name: tbtString; var Index: Cardinal): Boolean;
+begin
+ result := false;
+end;
+
+function TPSExternalClass.ClassFunc_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean;
+begin
+ result := false;
+end;
+
+
+{ TPSValueProcVal }
+
+destructor TPSValueProcVal.Destroy;
+begin
+ FProcNo.Free;
+ inherited;
+end;
+
+
+{
+
+Internal error counter: 00020 (increase and then use)
+
+}
+end.
diff --git a/Units/PascalScript/uPSComponent.pas b/Units/PascalScript/uPSComponent.pas
new file mode 100644
index 0000000..fbb608e
--- /dev/null
+++ b/Units/PascalScript/uPSComponent.pas
@@ -0,0 +1,1511 @@
+unit uPSComponent;
+{$I PascalScript.inc}
+interface
+
+uses
+ SysUtils, Classes, uPSRuntime, uPSDebugger, uPSUtils,
+ uPSCompiler, uPSC_dll, uPSR_dll, uPSPreProcessor;
+
+const
+ {alias to @link(ifps3.cdRegister)}
+ cdRegister = uPSRuntime.cdRegister;
+ {alias to @link(ifps3.cdPascal)}
+ cdPascal = uPSRuntime.cdPascal;
+
+ CdCdecl = uPSRuntime.CdCdecl;
+
+ CdStdCall = uPSRuntime.CdStdCall;
+
+type
+ TPSScript = class;
+
+ TDelphiCallingConvention = uPSRuntime.TPSCallingConvention;
+ {Alias to @link(ifps3.TPSRuntimeClassImporter)}
+ TPSRuntimeClassImporter = uPSRuntime.TPSRuntimeClassImporter;
+
+ TPSPlugin = class(TComponent)
+ public
+ procedure CompOnUses(CompExec: TPSScript); virtual;
+
+ procedure ExecOnUses(CompExec: TPSScript); virtual;
+
+ procedure CompileImport1(CompExec: TPSScript); virtual;
+
+ procedure CompileImport2(CompExec: TPSScript); virtual;
+
+ procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); virtual;
+
+ procedure ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); virtual;
+ end;
+
+ TIFPS3Plugin = class(TPSPlugin);
+
+ TPSDllPlugin = class(TPSPlugin)
+ public
+ procedure CompOnUses(CompExec: TPSScript); override;
+ procedure ExecOnUses(CompExec: TPSScript); override;
+ end;
+
+ TIFPS3DllPlugin = class(TPSDllPlugin);
+
+
+ TPSPluginItem = class(TCollectionItem)
+ private
+ FPlugin: TPSPlugin;
+ procedure SetPlugin(const Value: TPSPlugin);
+ protected
+ function GetDisplayName: string; override;
+ public
+ procedure Assign(Source: TPersistent); override; //Birb
+ published
+ property Plugin: TPSPlugin read FPlugin write SetPlugin;
+ end;
+
+
+ TIFPS3CEPluginItem = class(TPSPluginItem);
+
+
+ TPSPlugins = class(TCollection)
+ private
+ FCompExec: TPSScript;
+ protected
+
+ function GetOwner: TPersistent; override;
+ public
+
+ constructor Create(CE: TPSScript);
+ end;
+
+ TIFPS3CEPlugins = class(TPSPlugins);
+
+
+ TPSOnGetNotVariant = function (Sender: TPSScript; const Name: tbtstring): Variant of object;
+ TPSOnSetNotVariant = procedure (Sender: TPSScript; const Name: tbtstring; V: Variant) of object;
+ TPSCompOptions = set of (icAllowNoBegin, icAllowUnit, icAllowNoEnd, icBooleanShortCircuit);
+
+ TPSVerifyProc = procedure (Sender: TPSScript; Proc: TPSInternalProcedure; const Decl: tbtstring; var Error: Boolean) of object;
+
+ TPSEvent = procedure (Sender: TPSScript) of object;
+
+ TPSOnCompImport = procedure (Sender: TObject; x: TPSPascalCompiler) of object;
+
+ TPSOnExecImport = procedure (Sender: TObject; se: TPSExec; x: TPSRuntimeClassImporter) of object;
+ {Script engine event function}
+ TPSOnNeedFile = function (Sender: TObject; const OrginFileName: tbtstring; var FileName, Output: tbtstring): Boolean of object;
+
+ TPSOnProcessDirective = procedure (
+ Sender: TPSPreProcessor;
+ Parser: TPSPascalPreProcessorParser;
+ const Active: Boolean;
+ const DirectiveName, DirectiveParam: tbtstring;
+ Var Continue: Boolean) of Object; // jgv
+
+ TPSScript = class(TComponent)
+ private
+ FOnGetNotificationVariant: TPSOnGetNotVariant;
+ FOnSetNotificationVariant: TPSOnSetNotVariant;
+ FCanAdd: Boolean;
+ FComp: TPSPascalCompiler;
+ FCompOptions: TPSCompOptions;
+ FExec: TPSDebugExec;
+ FSuppressLoadData: Boolean;
+ FScript: TStrings;
+ FOnLine: TNotifyEvent;
+ FUseDebugInfo: Boolean;
+ FOnAfterExecute, FOnCompile, FOnExecute: TPSEvent;
+ FOnCompImport: TPSOnCompImport;
+ FOnExecImport: TPSOnExecImport;
+ RI: TPSRuntimeClassImporter;
+ FPlugins: TPSPlugins;
+ FPP: TPSPreProcessor;
+ FMainFileName: tbtstring;
+ FOnNeedFile: TPSOnNeedFile;
+ FUsePreProcessor: Boolean;
+ FDefines: TStrings;
+ FOnVerifyProc: TPSVerifyProc;
+ FOnProcessDirective: TPSOnProcessDirective;
+ FOnProcessUnknowDirective: TPSOnProcessDirective;
+ FOnFindUnknownFile: TPSOnNeedFile;
+ function GetRunning: Boolean;
+ procedure SetScript(const Value: TStrings);
+ function GetCompMsg(i: Integer): TPSPascalCompilerMessage;
+ function GetCompMsgCount: Longint;
+ function GetAbout: tbtstring;
+ function ScriptUses(Sender: TPSPascalCompiler; const Name: tbtstring): Boolean;
+ function GetExecErrorByteCodePosition: Cardinal;
+ function GetExecErrorCode: TIFError;
+ function GetExecErrorParam: tbtstring;
+ function GetExecErrorProcNo: Cardinal;
+ function GetExecErrorString: tbtstring;
+ function GetExecErrorPosition: Cardinal;
+ function GetExecErrorCol: Cardinal;
+ function GetExecErrorRow: Cardinal;
+ function GetExecErrorFileName: tbtstring;
+ procedure SetDefines(const Value: TStrings);
+ protected
+ procedure Notification(AComponent: TComponent; Operation: TOperation); override;
+
+ protected
+ //jgv move where private before - not very usefull
+ procedure OnLineEvent; virtual;
+ procedure SetMainFileName(const Value: tbtstring); virtual;
+
+ //--jgv new
+ function DoOnNeedFile (Sender: TObject; const OrginFileName: tbtstring; var FileName, Output: tbtstring): Boolean; virtual;
+ function DoOnUnknowUses (Sender: TPSPascalCompiler; const Name: tbtstring): Boolean; virtual; // return true if processed
+ procedure DoOnCompImport; virtual;
+ procedure DoOnCompile; virtual;
+ function DoVerifyProc (Sender: TPSScript; Proc: TPSInternalProcedure; const Decl: tbtstring): Boolean; virtual;
+
+ procedure DoOnExecImport (RunTimeImporter: TPSRuntimeClassImporter); virtual;
+ procedure DoOnExecute (RunTimeImporter: TPSRuntimeClassImporter); virtual;
+ procedure DoAfterExecute; virtual;
+ function DoOnGetNotificationVariant (const Name: tbtstring): Variant; virtual;
+ procedure DoOnSetNotificationVariant (const Name: tbtstring; V: Variant); virtual;
+
+ procedure DoOnProcessDirective (Sender: TPSPreProcessor;
+ Parser: TPSPascalPreProcessorParser;
+ const Active: Boolean;
+ const DirectiveName, DirectiveParam: tbtstring;
+ Var Continue: Boolean); virtual;
+ procedure DoOnProcessUnknowDirective (Sender: TPSPreProcessor;
+ Parser: TPSPascalPreProcessorParser;
+ const Active: Boolean;
+ const DirectiveName, DirectiveParam: tbtstring;
+ Var Continue: Boolean); virtual;
+ public
+ property RuntimeImporter: TPSRuntimeClassImporter read RI;
+
+ function FindNamedType(const Name: tbtstring): TPSTypeRec;
+
+ function FindBaseType(Bt: TPSBaseType): TPSTypeRec;
+
+ property SuppressLoadData: Boolean read FSuppressLoadData write FSuppressLoadData;
+
+ function LoadExec: Boolean;
+
+ procedure Stop; virtual;
+
+ constructor Create(AOwner: TComponent); override;
+
+ destructor Destroy; override;
+
+ function Compile: Boolean; virtual;
+
+ function Execute: Boolean; virtual;
+
+ property Running: Boolean read GetRunning;
+
+ procedure GetCompiled(var data: tbtstring);
+
+ procedure SetCompiled(const Data: tbtstring);
+
+ property Comp: TPSPascalCompiler read FComp;
+
+ property Exec: TPSDebugExec read FExec;
+
+ property CompilerMessageCount: Longint read GetCompMsgCount;
+
+ property CompilerMessages[i: Longint]: TPSPascalCompilerMessage read GetCompMsg;
+
+ function CompilerErrorToStr(I: Longint): tbtstring;
+
+ property ExecErrorCode: TIFError read GetExecErrorCode;
+
+ property ExecErrorParam: tbtstring read GetExecErrorParam;
+
+ property ExecErrorToString: tbtstring read GetExecErrorString;
+
+ property ExecErrorProcNo: Cardinal read GetExecErrorProcNo;
+
+ property ExecErrorByteCodePosition: Cardinal read GetExecErrorByteCodePosition;
+
+ property ExecErrorPosition: Cardinal read GetExecErrorPosition;
+
+ property ExecErrorRow: Cardinal read GetExecErrorRow;
+
+ property ExecErrorCol: Cardinal read GetExecErrorCol;
+
+ property ExecErrorFileName: tbtstring read GetExecErrorFileName;
+
+ function AddFunctionEx(Ptr: Pointer; const Decl: tbtstring; CallingConv: TDelphiCallingConvention): Boolean;
+
+ function AddFunction(Ptr: Pointer; const Decl: tbtstring): Boolean;
+
+
+ function AddMethodEx(Slf, Ptr: Pointer; const Decl: tbtstring; CallingConv: TDelphiCallingConvention): Boolean;
+
+ function AddMethod(Slf, Ptr: Pointer; const Decl: tbtstring): Boolean;
+
+ function AddRegisteredVariable(const VarName, VarType: tbtstring): Boolean;
+ function AddNotificationVariant(const VarName: tbtstring): Boolean;
+
+ function AddRegisteredPTRVariable(const VarName, VarType: tbtstring): Boolean;
+
+ function GetVariable(const Name: tbtstring): PIFVariant;
+
+ function SetVarToInstance(const VarName: tbtstring; cl: TObject): Boolean;
+
+ procedure SetPointerToData(const VarName: tbtstring; Data: Pointer; aType: TIFTypeRec);
+
+ function TranslatePositionPos(Proc, Position: Cardinal; var Pos: Cardinal; var fn: tbtstring): Boolean;
+
+ function TranslatePositionRC(Proc, Position: Cardinal; var Row, Col: Cardinal; var fn: tbtstring): Boolean;
+
+ function GetProcMethod(const ProcName: tbtstring): TMethod;
+
+ function ExecuteFunction(const Params: array of Variant; const ProcName: tbtstring): Variant;
+ published
+
+ property About: tbtstring read GetAbout stored false;
+
+ property Script: TStrings read FScript write SetScript;
+
+ property CompilerOptions: TPSCompOptions read FCompOptions write FCompOptions;
+
+ property OnLine: TNotifyEvent read FOnLine write FOnLine;
+
+ property OnCompile: TPSEvent read FOnCompile write FOnCompile;
+
+ property OnExecute: TPSEvent read FOnExecute write FOnExecute;
+
+ property OnAfterExecute: TPSEvent read FOnAfterExecute write FOnAfterExecute;
+
+ property OnCompImport: TPSOnCompImport read FOnCompImport write FOnCompImport;
+
+ property OnExecImport: TPSOnExecImport read FOnExecImport write FOnExecImport;
+
+ property UseDebugInfo: Boolean read FUseDebugInfo write FUseDebugInfo default True;
+
+ property Plugins: TPSPlugins read FPlugins write FPlugins;
+
+ property MainFileName: tbtstring read FMainFileName write SetMainFileName;
+
+ property UsePreProcessor: Boolean read FUsePreProcessor write FUsePreProcessor;
+
+ property OnNeedFile: TPSOnNeedFile read FOnNeedFile write FOnNeedFile;
+
+ property Defines: TStrings read FDefines write SetDefines;
+
+ property OnVerifyProc: TPSVerifyProc read FOnVerifyProc write FOnVerifyProc;
+ property OnGetNotificationVariant: TPSOnGetNotVariant read FOnGetNotificationVariant write FOnGetNotificationVariant;
+ property OnSetNotificationVariant: TPSOnSetNotVariant read FOnSetNotificationVariant write FOnSetNotificationVariant;
+ property OnFindUnknownFile: TPSOnNeedFile read FOnFindUnknownFile write FOnFindUnknownFile;
+
+ published
+ //-- jgv
+ property OnProcessDirective: TPSOnProcessDirective read FOnProcessDirective write FOnProcessDirective;
+ property OnProcessUnknowDirective: TPSOnProcessDirective read FOnProcessUnknowDirective write FOnProcessUnknowDirective;
+ end;
+
+ TIFPS3CompExec = class(TPSScript);
+
+
+ TPSBreakPointInfo = class
+ private
+ FLine: Longint;
+ FFileNameHash: Longint;
+ FFileName: tbtstring;
+ procedure SetFileName(const Value: tbtstring);
+ public
+
+ property FileName: tbtstring read FFileName write SetFileName;
+
+ property FileNameHash: Longint read FFileNameHash;
+
+ property Line: Longint read FLine write FLine;
+ end;
+
+ TPSOnLineInfo = procedure (Sender: TObject; const FileName: tbtstring; Position, Row, Col: Cardinal) of object;
+
+ TPSScriptDebugger = class(TPSScript)
+ private
+ FOnIdle: TNotifyEvent;
+ FBreakPoints: TIFList;
+ FOnLineInfo: TPSOnLineInfo;
+ FLastRow: Cardinal;
+ FOnBreakpoint: TPSOnLineInfo;
+ function GetBreakPoint(I: Integer): TPSBreakPointInfo;
+ function GetBreakPointCount: Longint;
+ protected
+ procedure SetMainFileName(const Value: tbtstring); override;
+ public
+ constructor Create(AOwner: TComponent); override;
+ destructor Destroy; override;
+
+
+ procedure Pause; virtual;
+
+ procedure Resume; virtual;
+
+
+ procedure StepInto; virtual;
+
+ procedure StepOver; virtual;
+
+ procedure SetBreakPoint(const Fn: tbtstring; Line: Longint);
+
+ procedure ClearBreakPoint(const Fn: tbtstring; Line: Longint);
+
+ property BreakPointCount: Longint read GetBreakPointCount;
+
+ property BreakPoint[I: Longint]: TPSBreakPointInfo read GetBreakPoint;
+
+ function HasBreakPoint(const Fn: tbtstring; Line: Longint): Boolean;
+
+ procedure ClearBreakPoints;
+
+ function GetVarContents(const Name: tbtstring): tbtstring;
+ published
+
+ property OnIdle: TNotifyEvent read FOnIdle write FOnIdle;
+
+ property OnLineInfo: TPSOnLineInfo read FOnLineInfo write FOnLineInfo;
+
+ property OnBreakpoint: TPSOnLineInfo read FOnBreakpoint write FOnBreakpoint;
+ end;
+
+ TIFPS3DebugCompExec = class(TPSScriptDebugger);
+
+ TPSCustumPlugin = class(TPSPlugin)
+ private
+ FOnCompileImport2: TPSEvent;
+ FOnExecOnUses: TPSEvent;
+ FOnCompOnUses: TPSEvent;
+ FOnCompileImport1: TPSEvent;
+ FOnExecImport1: TPSOnExecImport;
+ FOnExecImport2: TPSOnExecImport;
+ public
+ procedure CompOnUses(CompExec: TPSScript); override;
+ procedure ExecOnUses(CompExec: TPSScript); override;
+ procedure CompileImport1(CompExec: TPSScript); override;
+ procedure CompileImport2(CompExec: TPSScript); override;
+ procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
+
+ procedure ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
+ public
+ published
+ property OnCompOnUses : TPSEvent read FOnCompOnUses write FOnCompOnUses;
+ property OnExecOnUses: TPSEvent read FOnExecOnUses write FOnExecOnUses;
+ property OnCompileImport1: TPSEvent read FOnCompileImport1 write FOnCompileImport1;
+ property OnCompileImport2: TPSEvent read FOnCompileImport2 write FOnCompileImport2;
+ property OnExecImport1: TPSOnExecImport read FOnExecImport1 write FOnExecImport1;
+ property OnExecImport2: TPSOnExecImport read FOnExecImport2 write FOnExecImport2;
+ end;
+
+implementation
+
+
+{$IFDEF DELPHI3UP }
+resourceString
+{$ELSE }
+const
+{$ENDIF }
+
+ RPS_UnableToReadVariant = 'Unable to read variant';
+ RPS_UnableToWriteVariant = 'Unable to write variant';
+ RPS_ScripEngineAlreadyRunning = 'Script engine already running';
+ RPS_ScriptNotCompiled = 'Script is not compiled';
+ RPS_NotRunning = 'Not running';
+ RPS_UnableToFindVariable = 'Unable to find variable';
+ RPS_UnknownIdentifier = 'Unknown Identifier';
+ RPS_NoScript = 'No script';
+
+function MyGetVariant(Sender: TPSExec; const Name: tbtstring): Variant;
+begin
+ Result := TPSScript (Sender.Id).DoOnGetNotificationVariant(Name);
+end;
+
+procedure MySetVariant(Sender: TPSExec; const Name: tbtstring; V: Variant);
+begin
+ TPSScript (Sender.Id).DoOnSetNotificationVariant(Name, V);
+end;
+
+function CompScriptUses(Sender: TPSPascalCompiler; const Name: tbtstring): Boolean;
+begin
+ Result := TPSScript(Sender.ID).ScriptUses(Sender, Name);
+end;
+
+procedure ExecOnLine(Sender: TPSExec);
+begin
+ if assigned(TPSScript(Sender.ID).FOnLine) then
+ begin
+ TPSScript(Sender.ID).OnLineEvent;
+ end;
+end;
+
+function CompExportCheck(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure; const ProcDecl: tbtstring): Boolean;
+begin
+ Result := TPSScript(Sender.ID).DoVerifyProc (Sender.ID, Proc, ProcDecl);
+end;
+
+
+procedure callObjectOnProcessDirective (
+ Sender: TPSPreProcessor;
+ Parser: TPSPascalPreProcessorParser;
+ const Active: Boolean;
+ const DirectiveName, DirectiveParam: tbtstring;
+ Var Continue: Boolean);
+begin
+ TPSScript (Sender.ID).DoOnProcessUnknowDirective(Sender, Parser, Active, DirectiveName, DirectiveParam, Continue);
+end;
+
+procedure callObjectOnProcessUnknowDirective (
+ Sender: TPSPreProcessor;
+ Parser: TPSPascalPreProcessorParser;
+ const Active: Boolean;
+ const DirectiveName, DirectiveParam: tbtstring;
+ Var Continue: Boolean);
+begin
+ TPSScript (Sender.ID).DoOnProcessDirective(Sender, Parser, Active, DirectiveName, DirectiveParam, Continue);
+end;
+
+
+{ TPSPlugin }
+procedure TPSPlugin.CompileImport1(CompExec: TPSScript);
+begin
+ // do nothing
+end;
+
+procedure TPSPlugin.CompileImport2(CompExec: TPSScript);
+begin
+ // do nothing
+end;
+
+procedure TPSPlugin.CompOnUses(CompExec: TPSScript);
+begin
+ // do nothing
+end;
+
+procedure TPSPlugin.ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter);
+begin
+ // do nothing
+end;
+
+procedure TPSPlugin.ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter);
+begin
+ // do nothing
+end;
+
+procedure TPSPlugin.ExecOnUses(CompExec: TPSScript);
+begin
+ // do nothing
+end;
+
+
+{ TPSScript }
+
+function TPSScript.AddFunction(Ptr: Pointer;
+ const Decl: tbtstring): Boolean;
+begin
+ Result := AddFunctionEx(Ptr, Decl, cdRegister);
+end;
+
+function TPSScript.AddFunctionEx(Ptr: Pointer; const Decl: tbtstring;
+ CallingConv: TDelphiCallingConvention): Boolean;
+var
+ P: TPSRegProc;
+begin
+ if not FCanAdd then begin Result := False; exit; end;
+ p := Comp.AddDelphiFunction(Decl);
+ if p <> nil then
+ begin
+ Exec.RegisterDelphiFunction(Ptr, p.Name, CallingConv);
+ Result := True;
+ end else Result := False;
+end;
+
+function TPSScript.AddRegisteredVariable(const VarName,
+ VarType: tbtstring): Boolean;
+var
+ FVar: TPSVar;
+begin
+ if not FCanAdd then begin Result := False; exit; end;
+ FVar := FComp.AddUsedVariableN(varname, vartype);
+ if fvar = nil then
+ result := False
+ else begin
+ fvar.exportname := fvar.Name;
+ Result := True;
+ end;
+end;
+
+function CENeedFile(Sender: TPSPreProcessor; const callingfilename: tbtstring; var FileName, Output: tbtstring): Boolean;
+begin
+ Result := TPSScript (Sender.ID).DoOnNeedFile(Sender.ID, CallingFileName, FileName, Output);
+end;
+
+procedure CompTranslateLineInfo(Sender: TPSPascalCompiler; var Pos, Row, Col: Cardinal; var Name: tbtstring);
+var
+ res: TPSLineInfoResults;
+begin
+ if TPSScript(Sender.ID).FPP.CurrentLineInfo.GetLineInfo(Name, Pos, Res) then
+ begin
+ Pos := Res.Pos;
+ Row := Res.Row;
+ Col := Res.Col;
+ Name := Res.Name;
+ end;
+end;
+
+function TPSScript.Compile: Boolean;
+var
+ i: Longint;
+ dta: tbtstring;
+begin
+ FExec.Clear;
+ FExec.CMD_Err(erNoError);
+ FExec.ClearspecialProcImports;
+ FExec.ClearFunctionList;
+ if ri <> nil then
+ begin
+ RI.Free;
+ RI := nil;
+ end;
+ RI := TPSRuntimeClassImporter.Create;
+ for i := 0 to FPlugins.Count -1 do
+ begin
+ if (TPSPluginItem(FPlugins.Items[i]) <> nil) and (TPSPluginItem(FPlugins.Items[i]).Plugin <> nil) then
+ TPSPluginItem(FPlugins.Items[i]).Plugin.ExecImport1(Self, ri);
+ end;
+
+ DoOnExecImport (RI);
+
+ for i := 0 to FPlugins.Count -1 do
+ begin
+ if (TPSPluginItem(FPlugins.Items[i]) <> nil)and (TPSPluginItem(FPlugins.Items[i]).Plugin <> nil) then
+ TPSPluginItem(FPlugins.Items[i]).Plugin.ExecImport2(Self, ri);
+ end;
+ RegisterClassLibraryRuntime(Exec, RI);
+ for i := 0 to FPlugins.Count -1 do
+ begin
+ if (TPSPluginItem(FPlugins.Items[i]) <> nil)and (TPSPluginItem(FPlugins.Items[i]).Plugin <> nil) then
+ TPSPluginItem(FPlugins.Items[i]).Plugin.ExecOnUses(Self);
+ end;
+ FCanAdd := True;
+ FComp.BooleanShortCircuit := icBooleanShortCircuit in FCompOptions;
+ FComp.AllowNoBegin := icAllowNoBegin in FCompOptions;
+ FComp.AllowUnit := icAllowUnit in FCompOptions;
+ FComp.AllowNoEnd := icAllowNoEnd in FCompOptions;
+ if FUsePreProcessor then
+ begin
+ FPP.Clear;
+ FPP.Defines.Assign(FDefines);
+ FComp.OnTranslateLineInfo := CompTranslateLineInfo;
+ Fpp.OnProcessDirective := callObjectOnProcessDirective;
+ Fpp.OnProcessUnknowDirective := callObjectOnProcessUnknowDirective;
+ Fpp.MainFile := FScript.Text;
+ Fpp.MainFileName := FMainFileName;
+ Fpp.PreProcess(FMainFileName, dta);
+ if FComp.Compile(dta) then
+ begin
+ FCanAdd := False;
+ if (not SuppressLoadData) and (not LoadExec) then
+ begin
+ Result := False;
+ end else
+ Result := True;
+ end else Result := False;
+ Fpp.AdjustMessages(Comp);
+ end else
+ begin
+ FComp.OnTranslateLineInfo := nil;
+ if FComp.Compile(FScript.Text) then
+ begin
+ FCanAdd := False;
+ if not LoadExec then
+ begin
+ Result := False;
+ end else
+ Result := True;
+ end else Result := False;
+ end;
+end;
+
+function TPSScript.CompilerErrorToStr(I: Integer): tbtstring;
+begin
+ Result := CompilerMessages[i].MessageToString;
+end;
+
+constructor TPSScript.Create(AOwner: TComponent);
+begin
+ inherited Create(AOwner);
+ FComp := TPSPascalCompiler.Create;
+ FExec := TPSDebugExec.Create;
+ FScript := TStringList.Create;
+ FPlugins := TPSPlugins.Create(self);
+
+ FComp.ID := Self;
+ FComp.OnUses := CompScriptUses;
+ FComp.OnExportCheck := CompExportCheck;
+ FExec.Id := Self;
+ FExec.OnRunLine:= ExecOnLine;
+ FExec.OnGetNVariant := MyGetVariant;
+ FExec.OnSetNVariant := MySetVariant;
+
+ FUseDebugInfo := True;
+
+ FPP := TPSPreProcessor.Create;
+ FPP.Id := Self;
+ FPP.OnNeedFile := CENeedFile;
+
+ FDefines := TStringList.Create;
+end;
+
+destructor TPSScript.Destroy;
+begin
+ FDefines.Free;
+
+ FPP.Free;
+ RI.Free;
+ FPlugins.Free;
+ FPlugins := nil;
+ FScript.Free;
+ FExec.Free;
+ FComp.Free;
+ inherited Destroy;
+end;
+
+function TPSScript.Execute: Boolean;
+begin
+ if Running then raise Exception.Create(RPS_ScripEngineAlreadyRunning);
+ if SuppressLoadData then
+ LoadExec;
+
+ DoOnExecute (RI);
+
+ FExec.DebugEnabled := FUseDebugInfo;
+ Result := FExec.RunScript and (FExec.ExceptionCode = erNoError) ;
+
+ DoAfterExecute;
+end;
+
+function TPSScript.GetAbout: tbtstring;
+begin
+ Result := TPSExec.About;
+end;
+
+procedure TPSScript.GetCompiled(var data: tbtstring);
+begin
+ if not FComp.GetOutput(Data) then
+ raise Exception.Create(RPS_ScriptNotCompiled);
+end;
+
+function TPSScript.GetCompMsg(i: Integer): TPSPascalCompilerMessage;
+begin
+ Result := FComp.Msg[i];
+end;
+
+function TPSScript.GetCompMsgCount: Longint;
+begin
+ Result := FComp.MsgCount;
+end;
+
+function TPSScript.GetExecErrorByteCodePosition: Cardinal;
+begin
+ Result := Exec.ExceptionPos;
+end;
+
+function TPSScript.GetExecErrorCode: TIFError;
+begin
+ Result := Exec.ExceptionCode;
+end;
+
+function TPSScript.GetExecErrorParam: tbtstring;
+begin
+ Result := Exec.ExceptionString;
+end;
+
+function TPSScript.GetExecErrorPosition: Cardinal;
+begin
+ Result := FExec.TranslatePosition(Exec.ExceptionProcNo, Exec.ExceptionPos);
+end;
+
+function TPSScript.GetExecErrorProcNo: Cardinal;
+begin
+ Result := Exec.ExceptionProcNo;
+end;
+
+function TPSScript.GetExecErrorString: tbtstring;
+begin
+ Result := TIFErrorToString(Exec.ExceptionCode, Exec.ExceptionString);
+end;
+
+function TPSScript.GetVariable(const Name: tbtstring): PIFVariant;
+begin
+ Result := FExec.GetVar2(name);
+end;
+
+function TPSScript.LoadExec: Boolean;
+var
+ s: tbtstring;
+begin
+ if (not FComp.GetOutput(s)) or (not FExec.LoadData(s)) then
+ begin
+ Result := False;
+ exit;
+ end;
+ if FUseDebugInfo then
+ begin
+ FComp.GetDebugOutput(s);
+ FExec.LoadDebugData(s);
+ end;
+ Result := True;
+end;
+
+function TPSScript.ScriptUses(Sender: TPSPascalCompiler;
+ const Name: tbtstring): Boolean;
+var
+ i: Longint;
+begin
+ if Name = 'SYSTEM' then
+ begin
+ for i := 0 to FPlugins.Count -1 do
+ begin
+ if (TPSPluginItem(FPlugins.Items[i]) <> nil)and (TPSPluginItem(FPlugins.Items[i]).Plugin <> nil) then
+ TPSPluginItem(FPlugins.Items[i]).Plugin.CompOnUses(Self);
+ end;
+ for i := 0 to FPlugins.Count -1 do
+ begin
+ if (TPSPluginItem(FPlugins.Items[i]) <> nil)and (TPSPluginItem(FPlugins.Items[i]).Plugin <> nil) then
+ TPSPluginItem(FPlugins.Items[i]).Plugin.CompileImport1(self);
+ end;
+
+ DoOnCompImport;
+
+ for i := 0 to FPlugins.Count -1 do
+ begin
+ if (TPSPluginItem(FPlugins.Items[i]) <> nil)and (TPSPluginItem(FPlugins.Items[i]).Plugin <> nil) then
+ TPSPluginItem(FPlugins.Items[i]).Plugin.CompileImport2(Self);
+ end;
+
+ DoOnCompile;
+
+ Result := true;
+ for i := 0 to Sender.MsgCount -1 do begin
+ if Sender.Msg[i] is TPSPascalCompilerError then Result := false;
+ end;
+ end
+ else begin
+ Result := DoOnUnknowUses (Sender, Name);
+{ If Not Result then
+ Sender.MakeError('', ecUnknownIdentifier, Name);}
+ end;
+end;
+
+procedure TPSScript.SetCompiled(const Data: tbtstring);
+var
+ i: Integer;
+begin
+ FExec.Clear;
+ FExec.ClearspecialProcImports;
+ FExec.ClearFunctionList;
+ if ri <> nil then
+ begin
+ RI.Free;
+ RI := nil;
+ end;
+ RI := TPSRuntimeClassImporter.Create;
+ for i := 0 to FPlugins.Count -1 do
+ begin
+ if (TPSPluginItem(FPlugins.Items[i]) <> nil)and (TPSPluginItem(FPlugins.Items[i]).Plugin <> nil) then
+ TPSPluginItem(FPlugins.Items[i]).Plugin.ExecImport1(Self, ri);
+ end;
+
+ DoOnExecImport(RI);
+
+ for i := 0 to FPlugins.Count -1 do
+ begin
+ if (TPSPluginItem(FPlugins.Items[i]) <> nil)and (TPSPluginItem(FPlugins.Items[i]).Plugin <> nil) then
+ TPSPluginItem(FPlugins.Items[i]).Plugin.ExecImport2(Self, ri);
+ end;
+ RegisterClassLibraryRuntime(Exec, RI);
+ for i := 0 to FPlugins.Count -1 do
+ begin
+ if (TPSPluginItem(FPlugins.Items[i]) <> nil)and (TPSPluginItem(FPlugins.Items[i]).Plugin <> nil) then
+ TPSPluginItem(FPlugins.Items[i]).Plugin.ExecOnUses(Self);
+ end;
+ if not FExec.LoadData(Data) then
+ raise Exception.Create(GetExecErrorString);
+end;
+
+function TPSScript.SetVarToInstance(const VarName: tbtstring; cl: TObject): Boolean;
+var
+ p: PIFVariant;
+begin
+ p := GetVariable(VarName);
+ if p <> nil then
+ begin
+ SetVariantToClass(p, cl);
+ result := true;
+ end else result := false;
+end;
+
+procedure TPSScript.SetScript(const Value: TStrings);
+begin
+ FScript.Assign(Value);
+end;
+
+
+function TPSScript.AddMethod(Slf, Ptr: Pointer;
+ const Decl: tbtstring): Boolean;
+begin
+ Result := AddMethodEx(Slf, Ptr, Decl, cdRegister);
+end;
+
+function TPSScript.AddMethodEx(Slf, Ptr: Pointer; const Decl: tbtstring;
+ CallingConv: TDelphiCallingConvention): Boolean;
+var
+ P: TPSRegProc;
+begin
+ if not FCanAdd then begin Result := False; exit; end;
+ p := Comp.AddDelphiFunction(Decl);
+ if p <> nil then
+ begin
+ Exec.RegisterDelphiMethod(Slf, Ptr, p.Name, CallingConv);
+ Result := True;
+ end else Result := False;
+end;
+
+procedure TPSScript.OnLineEvent;
+begin
+ if @FOnLine <> nil then FOnLine(Self);
+end;
+
+function TPSScript.GetRunning: Boolean;
+begin
+ Result := FExec.Status = isRunning;
+end;
+
+function TPSScript.GetExecErrorCol: Cardinal;
+var
+ s: tbtstring;
+ D1: Cardinal;
+begin
+ if not TranslatePositionRC(Exec.ExceptionProcNo, Exec.ExceptionPos, D1, Result, s) then
+ Result := 0;
+end;
+
+function TPSScript.TranslatePositionPos(Proc, Position: Cardinal;
+ var Pos: Cardinal; var fn: tbtstring): Boolean;
+var
+ D1, D2: Cardinal;
+begin
+ Result := Exec.TranslatePositionEx(Exec.ExceptionProcNo, Exec.ExceptionPos, Pos, D1, D2, fn);
+end;
+
+function TPSScript.TranslatePositionRC(Proc, Position: Cardinal;
+ var Row, Col: Cardinal; var fn: tbtstring): Boolean;
+var
+ d1: Cardinal;
+begin
+ Result := Exec.TranslatePositionEx(Proc, Position, d1, Row, Col, fn);
+end;
+
+
+function TPSScript.GetExecErrorRow: Cardinal;
+var
+ D1: Cardinal;
+ s: tbtstring;
+begin
+ if not TranslatePositionRC(Exec.ExceptionProcNo, Exec.ExceptionPos, Result, D1, s) then
+ Result := 0;
+end;
+
+procedure TPSScript.Stop;
+begin
+ if (FExec.Status = isRunning) or (Fexec.Status = isPaused) then
+ FExec.Stop
+ else
+ raise Exception.Create(RPS_NotRunning);
+end;
+
+function TPSScript.GetProcMethod(const ProcName: tbtstring): TMethod;
+begin
+ Result := FExec.GetProcAsMethodN(ProcName)
+end;
+
+procedure TPSScript.SetMainFileName(const Value: tbtstring);
+begin
+ FMainFileName := Value;
+end;
+
+function TPSScript.GetExecErrorFileName: tbtstring;
+var
+ D1, D2: Cardinal;
+begin
+ if not TranslatePositionRC(Exec.ExceptionProcNo, Exec.ExceptionPos, D1, D2, Result) then
+ Result := '';
+end;
+
+procedure TPSScript.SetPointerToData(const VarName: tbtstring;
+ Data: Pointer; aType: TIFTypeRec);
+var
+ v: PIFVariant;
+ t: TPSVariantIFC;
+begin
+ v := GetVariable(VarName);
+ if (Atype = nil) or (v = nil) then raise Exception.Create(RPS_UnableToFindVariable);
+ t.Dta := @PPSVariantData(v).Data;
+ t.aType := v.FType;
+ t.VarParam := false;
+ VNSetPointerTo(t, Data, aType);
+end;
+
+function TPSScript.AddRegisteredPTRVariable(const VarName,
+ VarType: tbtstring): Boolean;
+var
+ FVar: TPSVar;
+begin
+ if not FCanAdd then begin Result := False; exit; end;
+ FVar := FComp.AddUsedVariableN(varname, vartype);
+ if fvar = nil then
+ result := False
+ else begin
+ fvar.exportname := fvar.Name;
+ fvar.SaveAsPointer := true;
+ Result := True;
+ end;
+end;
+
+procedure TPSScript.SetDefines(const Value: TStrings);
+begin
+ FDefines.Assign(Value);
+end;
+
+function TPSScript.ExecuteFunction(const Params: array of Variant;
+ const ProcName: tbtstring): Variant;
+begin
+ if SuppressLoadData then
+ LoadExec;
+
+ DoOnExecute (RI);
+
+ FExec.DebugEnabled := FUseDebugInfo;
+
+ Result := Exec.RunProcPN(Params, ProcName);
+
+ DoAfterExecute;
+end;
+
+function TPSScript.FindBaseType(Bt: TPSBaseType): TPSTypeRec;
+begin
+ Result := Exec.FindType2(Bt);
+end;
+
+function TPSScript.FindNamedType(const Name: tbtstring): TPSTypeRec;
+begin
+ Result := Exec.GetTypeNo(Exec.GetType(Name));
+end;
+
+procedure TPSScript.Notification(AComponent: TComponent;
+ Operation: TOperation);
+var
+ i: Longint;
+begin
+ inherited Notification(AComponent, Operation);
+ if (Operation = opRemove) and (aComponent is TPSPlugin) then
+ begin
+ for i := Plugins.Count -1 downto 0 do
+ begin
+ if (Plugins.Items[i] as TPSPluginItem).Plugin = aComponent then
+ {$IFDEF FPC_COL_NODELETE}
+ TCollectionItem(Plugins.Items[i]).Free;
+ {$ELSE}
+ Plugins.Delete(i);
+ {$ENDIF}
+ end;
+ end;
+end;
+
+function TPSScript.AddNotificationVariant(const VarName: tbtstring): Boolean;
+begin
+ Result := AddRegisteredVariable(VarName, '!NOTIFICATIONVARIANT');
+end;
+
+procedure TPSScript.DoOnProcessDirective(Sender: TPSPreProcessor;
+ Parser: TPSPascalPreProcessorParser; const Active: Boolean;
+ const DirectiveName, DirectiveParam: tbtstring; var Continue: Boolean);
+begin
+ If Assigned (OnProcessDirective) then
+ OnProcessDirective (Sender, Parser, Active, DirectiveName, DirectiveParam, Continue);
+end;
+
+procedure TPSScript.DoOnProcessUnknowDirective(Sender: TPSPreProcessor;
+ Parser: TPSPascalPreProcessorParser; const Active: Boolean;
+ const DirectiveName, DirectiveParam: tbtstring; var Continue: Boolean);
+begin
+ If Assigned (OnProcessUnknowDirective) then
+ OnProcessUnknowDirective (Sender, Parser, Active, DirectiveName, DirectiveParam, Continue);
+end;
+
+function TPSScript.DoOnNeedFile(Sender: TObject;
+ const OrginFileName: tbtstring; var FileName, Output: tbtstring): Boolean;
+begin
+ If Assigned (OnNeedFile) then
+ Result := OnNeedFile(Sender, OrginFileName, FileName, Output)
+ else
+ Result := False;
+end;
+
+function TPSScript.DoOnUnknowUses(Sender: TPSPascalCompiler;
+ const Name: tbtstring): Boolean;
+var
+ lPrevAllowUnit: Boolean;
+ lData, lName: tbtstring;
+begin
+ if assigned(FOnFindUnknownFile) then begin
+ lName := Name;
+ if FOnFindUnknownFile(self, '', lName, lData) then begin
+ lPrevAllowUnit := FComp.AllowUnit;
+ FComp.AllowUnit := true;
+ if FUsePreProcessor then
+ begin
+ FPP.Defines.Assign(FDefines);
+ Fpp.MainFile := lData;
+ Fpp.MainFileName := lName;
+ Fpp.PreProcess(lName, lData);
+ Result := FComp.Compile(lData);
+ Fpp.AdjustMessages(FComp);
+ end else
+ begin
+ FComp.OnTranslateLineInfo := nil;
+ Result := FComp.Compile(lData);
+ end;
+ FComp.AllowUnit := lPrevAllowUnit;
+ end else begin
+ FComp.MakeError(FComp.UnitName, ecUnknownIdentifier, lName);
+ Result := false;
+ end;
+ end else begin
+ FComp.MakeError(FComp.UnitName, ecUnknownIdentifier, lName);
+ result := false;
+ end;
+end;
+
+procedure TPSScript.DoOnCompImport;
+begin
+ if assigned(OnCompImport) then
+ OnCompImport(Self, Comp);
+end;
+
+procedure TPSScript.DoOnCompile;
+begin
+ if assigned(OnCompile) then
+ OnCompile(Self);
+end;
+
+procedure TPSScript.DoOnExecute;
+begin
+ If Assigned (OnExecute) then
+ OnExecute (Self);
+end;
+
+procedure TPSScript.DoAfterExecute;
+begin
+ if Assigned (OnAfterExecute) then
+ OnAfterExecute(Self);
+end;
+
+function TPSScript.DoVerifyProc(Sender: TPSScript;
+ Proc: TPSInternalProcedure; const Decl: tbtstring): Boolean;
+begin
+ if Assigned(OnVerifyProc) then begin
+ Result := false;
+ OnVerifyProc(Sender, Proc, Decl, Result);
+ Result := not Result;
+ end
+ else
+ Result := True;
+end;
+
+procedure TPSScript.DoOnExecImport(
+ RunTimeImporter: TPSRuntimeClassImporter);
+begin
+ if assigned(OnExecImport) then
+ OnExecImport(Self, FExec, RunTimeImporter);
+end;
+
+function TPSScript.DoOnGetNotificationVariant(const Name: tbtstring): Variant;
+begin
+ if Not Assigned (OnGetNotificationVariant) then
+ raise Exception.Create(RPS_UnableToReadVariant);
+ Result := OnGetNotificationVariant(Self, Name);
+end;
+
+procedure TPSScript.DoOnSetNotificationVariant(const Name: tbtstring;
+ V: Variant);
+begin
+ if Not Assigned (OnSetNotificationVariant) then
+ raise Exception.Create(RPS_UnableToWriteVariant);
+ OnSetNotificationVariant(Self, Name, v);
+end;
+
+{ TPSDllPlugin }
+
+procedure TPSDllPlugin.CompOnUses;
+begin
+ CompExec.Comp.OnExternalProc := DllExternalProc;
+end;
+
+procedure TPSDllPlugin.ExecOnUses;
+begin
+ RegisterDLLRuntime(CompExec.Exec);
+end;
+
+
+
+{ TPS3DebugCompExec }
+
+procedure LineInfo(Sender: TPSDebugExec; const FileName: tbtstring; Position, Row, Col: Cardinal);
+var
+ Dc: TPSScriptDebugger;
+ h, i: Longint;
+ bi: TPSBreakPointInfo;
+ lFileName: tbtstring;
+begin
+ Dc := Sender.Id;
+ if FileName = '' then
+ lFileName := dc.MainFileName
+ else
+ lFileName := FileName;
+
+ if @dc.FOnLineInfo <> nil then dc.FOnLineInfo(dc, lFileName, Position, Row, Col);
+ if row = dc.FLastRow then exit;
+ dc.FLastRow := row;
+ h := MakeHash(lFileName);
+ bi := nil;
+ for i := DC.FBreakPoints.Count -1 downto 0 do
+ begin
+ bi := Dc.FBreakpoints[i];
+ if (h = bi.FileNameHash) and (lFileName = bi.FileName) and (Cardinal(bi.Line) = Row) then
+ begin
+ Break;
+ end;
+ Bi := nil;
+ end;
+ if bi <> nil then
+ begin
+ if @dc.FOnBreakpoint <> nil then dc.FOnBreakpoint(dc, lFileName, Position, Row, Col);
+ dc.Pause;
+ end;
+end;
+
+procedure IdleCall(Sender: TPSDebugExec);
+var
+ Dc: TPSScriptDebugger;
+begin
+ Dc := Sender.Id;
+ if @dc.FOnIdle <> nil then
+ dc.FOnIdle(DC)
+ else
+ dc.Exec.Run;
+end;
+
+procedure TPSScriptDebugger.ClearBreakPoint(const Fn: tbtstring; Line: Integer);
+var
+ h, i: Longint;
+ bi: TPSBreakPointInfo;
+begin
+ h := MakeHash(Fn);
+ for i := FBreakPoints.Count -1 downto 0 do
+ begin
+ bi := FBreakpoints[i];
+ if (h = bi.FileNameHash) and (Fn = bi.FileName) and (bi.Line = Line) then
+ begin
+ FBreakPoints.Delete(i);
+ bi.Free;
+ Break;
+ end;
+ end;
+end;
+
+procedure TPSScriptDebugger.ClearBreakPoints;
+var
+ i: Longint;
+begin
+ for i := FBreakPoints.Count -1 downto 0 do
+ TPSBreakPointInfo(FBreakPoints[i]).Free;
+ FBreakPoints.Clear;;
+end;
+
+constructor TPSScriptDebugger.Create(AOwner: TComponent);
+begin
+ inherited Create(AOwner);
+ FBreakPoints := TIFList.Create;
+ FExec.OnSourceLine := LineInfo;
+ FExec.OnIdleCall := IdleCall;
+end;
+
+destructor TPSScriptDebugger.Destroy;
+var
+ i: Longint;
+begin
+ for i := FBreakPoints.Count -1 downto 0 do
+ begin
+ TPSBreakPointInfo(FBreakPoints[i]).Free;
+ end;
+ FBreakPoints.Free;
+ inherited Destroy;
+end;
+
+function TPSScriptDebugger.GetBreakPoint(I: Integer): TPSBreakPointInfo;
+begin
+ Result := FBreakPoints[i];
+end;
+
+function TPSScriptDebugger.GetBreakPointCount: Longint;
+begin
+ Result := FBreakPoints.Count;
+end;
+
+function TPSScriptDebugger.GetVarContents(const Name: tbtstring): tbtstring;
+var
+ i: Longint;
+ pv: PIFVariant;
+ s1, s: tbtstring;
+begin
+ s := Uppercase(Name);
+ if pos('.', s) > 0 then
+ begin
+ s1 := copy(s,1,pos('.', s) -1);
+ delete(s,1,pos('.', Name));
+ end else begin
+ s1 := s;
+ s := '';
+ end;
+ pv := nil;
+ for i := 0 to Exec.CurrentProcVars.Count -1 do
+ begin
+ if Uppercase(Exec.CurrentProcVars[i]) = s1 then
+ begin
+ pv := Exec.GetProcVar(i);
+ break;
+ end;
+ end;
+ if pv = nil then
+ begin
+ for i := 0 to Exec.CurrentProcParams.Count -1 do
+ begin
+ if Uppercase(Exec.CurrentProcParams[i]) = s1 then
+ begin
+ pv := Exec.GetProcParam(i);
+ break;
+ end;
+ end;
+ end;
+ if pv = nil then
+ begin
+ for i := 0 to Exec.GlobalVarNames.Count -1 do
+ begin
+ if Uppercase(Exec.GlobalVarNames[i]) = s1 then
+ begin
+ pv := Exec.GetGlobalVar(i);
+ break;
+ end;
+ end;
+ end;
+ if pv = nil then
+ Result := RPS_UnknownIdentifier
+ else
+ Result := PSVariantToString(NewTPSVariantIFC(pv, False), s);
+end;
+
+function TPSScriptDebugger.HasBreakPoint(const Fn: tbtstring; Line: Integer): Boolean;
+var
+ h, i: Longint;
+ bi: TPSBreakPointInfo;
+begin
+ h := MakeHash(Fn);
+ for i := FBreakPoints.Count -1 downto 0 do
+ begin
+ bi := FBreakpoints[i];
+ if (h = bi.FileNameHash) and (Fn = bi.FileName) and (bi.Line = Line) then
+ begin
+ Result := true;
+ exit;
+ end;
+ end;
+ Result := False;
+end;
+
+procedure TPSScriptDebugger.Pause;
+begin
+ if FExec.Status = isRunning then
+ FExec.Pause
+ else
+ raise Exception.Create(RPS_NotRunning);
+end;
+
+procedure TPSScriptDebugger.Resume;
+begin
+ if FExec.Status = isRunning then
+ FExec.Run
+ else
+ raise Exception.Create(RPS_NotRunning);
+end;
+
+procedure TPSScriptDebugger.SetBreakPoint(const fn: tbtstring; Line: Integer);
+var
+ i, h: Longint;
+ BI: TPSBreakPointInfo;
+begin
+ h := MakeHash(fn);
+ for i := FBreakPoints.Count -1 downto 0 do
+ begin
+ bi := FBreakpoints[i];
+ if (h = bi.FileNameHash) and (fn = bi.FileName) and (bi.Line = Line) then
+ exit;
+ end;
+ bi := TPSBreakPointInfo.Create;
+ FBreakPoints.Add(bi);
+ bi.FileName := fn;
+ bi.Line := Line;
+end;
+
+procedure TPSScriptDebugger.SetMainFileName(const Value: tbtstring);
+var
+ OldFn: tbtstring;
+ h1, h2,i: Longint;
+ bi: TPSBreakPointInfo;
+begin
+ OldFn := FMainFileName;
+ inherited SetMainFileName(Value);
+ h1 := MakeHash(OldFn);
+ h2 := MakeHash(Value);
+ if OldFn <> Value then
+ begin
+ for i := FBreakPoints.Count -1 downto 0 do
+ begin
+ bi := FBreakPoints[i];
+ if (bi.FileNameHash = h1) and (bi.FileName = OldFn) then
+ begin
+ bi.FFileNameHash := h2;
+ bi.FFileName := Value;
+ end else if (bi.FileNameHash = h2) and (bi.FileName = Value) then
+ begin
+ // It's already the new filename, that can't be right, so remove all the breakpoints there
+ FBreakPoints.Delete(i);
+ bi.Free;
+ end;
+ end;
+ end;
+end;
+
+procedure TPSScriptDebugger.StepInto;
+begin
+ if (FExec.Status = isRunning) or (FExec.Status = isLoaded) then
+ FExec.StepInto
+ else
+ raise Exception.Create(RPS_NoScript);
+end;
+
+procedure TPSScriptDebugger.StepOver;
+begin
+ if (FExec.Status = isRunning) or (FExec.Status = isLoaded) then
+ FExec.StepOver
+ else
+ raise Exception.Create(RPS_NoScript);
+end;
+
+
+
+{ TPSPluginItem }
+
+procedure TPSPluginItem.Assign(Source: TPersistent); //Birb
+begin
+ if Source is TPSPluginItem then
+ plugin:=((source as TPSPluginItem).plugin)
+ else
+ inherited;
+end;
+
+function TPSPluginItem.GetDisplayName: string;
+begin
+ if FPlugin <> nil then
+ Result := string(FPlugin.Name)
+ else
+ Result := '';
+end;
+
+procedure TPSPluginItem.SetPlugin(const Value: TPSPlugin);
+begin
+ FPlugin := Value;
+ If Value <> nil then
+ Value.FreeNotification(TPSPlugins(Collection).FCompExec);
+ Changed(False);
+end;
+
+{ TPSPlugins }
+
+constructor TPSPlugins.Create(CE: TPSScript);
+begin
+ inherited Create(TPSPluginItem);
+ FCompExec := CE;
+end;
+
+function TPSPlugins.GetOwner: TPersistent;
+begin
+ Result := FCompExec;
+end;
+
+{ TPSBreakPointInfo }
+
+procedure TPSBreakPointInfo.SetFileName(const Value: tbtstring);
+begin
+ FFileName := Value;
+ FFileNameHash := MakeHash(Value);
+end;
+
+{ TPSCustomPlugin }
+procedure TPSCustumPlugin.CompileImport1(CompExec: TPSScript);
+begin
+ IF @FOnCompileImport1 <> nil then
+ FOnCompileImport1(CompExec)
+ else
+ inherited;
+end;
+
+procedure TPSCustumPlugin.CompileImport2(CompExec: TPSScript);
+begin
+ IF @FOnCompileImport2 <> nil then
+ FOnCompileImport2(CompExec)
+ else
+ inherited;
+end;
+
+procedure TPSCustumPlugin.CompOnUses(CompExec: TPSScript);
+begin
+ IF @FOnCompOnUses <> nil then
+ FOnCompOnUses(CompExec)
+ else
+ inherited;
+end;
+
+procedure TPSCustumPlugin.ExecImport1(CompExec: TPSScript;
+ const ri: TPSRuntimeClassImporter);
+begin
+ IF @FOnExecImport1 <> nil then
+ FOnExecImport1(CompExec, compExec.Exec, ri)
+ else
+ inherited;
+end;
+
+procedure TPSCustumPlugin.ExecImport2(CompExec: TPSScript;
+ const ri: TPSRuntimeClassImporter);
+begin
+ IF @FOnExecImport2 <> nil then
+ FOnExecImport1(CompExec, compExec.Exec, ri)
+ else
+ inherited;
+end;
+
+procedure TPSCustumPlugin.ExecOnUses(CompExec: TPSScript);
+begin
+ IF @FOnExecOnUses <> nil then
+ FOnExecOnUses(CompExec)
+ else
+ inherited;
+end;
+
+end.
diff --git a/Units/PascalScript/uPSComponentExt.pas b/Units/PascalScript/uPSComponentExt.pas
new file mode 100644
index 0000000..1ffe82d
--- /dev/null
+++ b/Units/PascalScript/uPSComponentExt.pas
@@ -0,0 +1,1010 @@
+{
+@abstract(Component wrapper for IFPS3 compiler and executer)
+A component wrapper for IFPS3, including debugging support.
+
+}
+{$I PascalScript.inc}
+
+unit uPSComponentExt;
+
+interface
+
+uses
+ {$IFNDEF LINUX} Windows, {$ENDIF} SysUtils, Classes, uPSRuntime, uPSDebugger, uPSUtils, uPSComponent,
+ contnrs, uPSCompiler, uPSC_dll, uPSR_dll, uPSPreProcessor, typInfo;
+
+const
+ {alias to @link(ifps3.cdRegister)}
+ cdRegister = uPSRuntime.cdRegister;
+ {alias to @link(ifps3.cdPascal)}
+ cdPascal = uPSRuntime.cdPascal;
+ { alias to ifps3.cdCdecl }
+ CdCdecl = uPSRuntime.CdCdecl;
+ {alias to @link(ifps3.cdStdcall)}
+ CdStdCall = uPSRuntime.CdStdCall;
+
+type
+ {Alias to @link(ifps3.TPSCallingConvention)}
+ TDelphiCallingConvention = uPSRuntime.TPSCallingConvention;
+ {Alias to @link(ifps3.TPSRuntimeClassImporter)}
+ TPSRuntimeClassImporter = uPSRuntime.TPSRuntimeClassImporter;
+
+ TPSScriptExtension = class;
+
+ {Base class for all plugins for the component}
+ TPSOnCompCleanup = Function (Sender: TObject; aComp: TPSPascalCompiler):Boolean of object;
+ TPSOnInsertProcedure = Procedure (Sender: TObject; aProc: tbtstring; OnTop: Boolean) of object;
+ TPSOnException = procedure (Sender: TPSExec; ExError: TPSError; const ExParam: tbtstring;
+ ExObject: TObject; ProcNo, Position: Cardinal) of object;
+
+ TMethodList = class;
+ TProcObj = Class
+ private
+ FName : tbtstring;
+ fOwner : TMethodList;
+ procedure SetName(const Value: tbtstring);
+ public
+ ProcType : TStringList;
+ Method : TMethod;
+ constructor create(aOwner: TMethodList);
+ destructor Destroy; override;
+ property Name: tbtstring read FName write SetName;
+ end;
+
+ TMethodObj = Class
+ Instance : TPersistent;
+ PropName : tbtstring;
+ ProcName : tbtstring;
+ end;
+
+ TMethodList = class
+ private
+ fOwner : TPSScriptExtension;
+ fProcList : TObjectList;
+ fEventList : TObjectList;
+ function GetObject(Index: Integer): TMethodObj; virtual;
+ function GetProcObj(Index: Integer): TProcObj;
+ function GetMethodName(Instance: TObject; PropName: tbtstring): tbtstring;
+ procedure SetMethodName(Instance: TObject; PropName: tbtstring; const Value: tbtstring);
+ procedure CreateProc(ProcName: tbtstring; aPropType: TTypeData);
+ public
+ constructor create(aOwner: TPSScriptExtension);
+ destructor Destroy; override;
+ function methodIndexOf(Instance: TObject; PropName: tbtstring):Integer;
+ Function ProcIndexOf(Name: tbtstring): Integer;
+ Procedure ListEventsName(EventType:tbtstring; List : TStrings);
+
+ Procedure AddProcedure(ProcName, ProcType:tbtstring);
+ procedure InsertMethod(NewProc: tbtstring; OnTop: Boolean = false);
+
+ Procedure FillMethods;
+ procedure ClearProcList;
+ Procedure ClearAll;
+ function ProcCount :Integer;
+ Function MethodCount :Integer;
+ property Procs[Index: Integer]: TProcObj read GetProcObj ;
+ property Methods[Index: Integer]: TMethodObj read GetObject;
+ property ProcName[Instance: TObject; PropName:tbtstring]: tbtstring read GetMethodName write SetMethodName;
+ end;
+
+ TPSScriptExtension = class(TPSScriptDebugger)
+ private
+ FOnBeforeCleanUp: TPSOnCompCleanup;
+ FMethodList : TMethodList;
+ FOnInsertMethod: TPSOnInsertProcedure;
+ FNeedCompiling :Boolean;
+ FOnScriptChance: TNotifyEvent;
+ FOnException: TPSOnException;
+
+ fItems, fInserts: TStrings;
+ fScriptPos : Cardinal;
+ fObjectNest: tbtstring;
+
+ Procedure GetCodeProps ;
+ function GetProcName(Instance: TObject; PropName: tbtstring): tbtstring;
+ procedure SetProcName(Instance: TObject; PropName: tbtstring; const Value: tbtstring);
+
+ protected
+ procedure Notification(AComponent: TComponent; Operation: TOperation); override;
+
+ procedure DoVerifyProc(Sender: TPSScript; Proc: TPSInternalProcedure;
+ const Decl: tbtstring; var Error: Boolean); reintroduce;
+ Function DoBeforeCleanup(Sender: TObject; aComp: TPSPascalCompiler):Boolean;
+ procedure DoScriptChance(sender:TObject);
+
+
+ public
+ {Create an instance of the CompExec component}
+ constructor Create(AOwner: TComponent); override;
+ {Destroy the CompExec component}
+ destructor Destroy; override;
+
+ function Compile: Boolean; Override;
+ function Execute: Boolean; Override;
+ { Create a list of all var's, const's, Type's and functions }
+ Procedure GetValueDefs(aItems, aInserts: TStrings; Const aObjectNest: tbtstring=''; aScriptPos: Integer = 0);
+
+ {Compile the source only when the source is modified}
+ procedure CompileIfNeeded;
+ {Is the source modified}
+ Property NeedCompiling : Boolean read FNeedCompiling;
+
+ {Fills all function in the script to there connected Events.
+ This is called automatic after a succesfull Compilition}
+ Procedure FillMethods;
+
+ {Removes all events from the Objects Fills all function in the script to there connected Events.
+ This function is automatic called before a Compilition}
+ procedure ClearProcList;
+ Procedure RemoveObjEvents(Obj: TObject);
+
+ {This property helps you set the events that must becalled from within the script
+ Instance is the object where the Propname must be set.
+ You need te create the function yopur self in the script.
+ When the new Procname dose not exists in the script, it is automatic created for you.}
+ property ProcName[Instance: TObject; PropName:tbtstring]: tbtstring read GetProcName write SetProcName;
+ property MethodList : TMethodList read FMethodList;
+
+ published
+
+ property OnBeforeCleanUp: TPSOnCompCleanup read FOnBeforeCleanUp write FOnBeforeCleanUp; //
+ property OnInsertMethod : TPSOnInsertProcedure read FOnInsertMethod write FOnInsertMethod;
+ Property OnScriptChance : TNotifyEvent read FOnScriptChance write fOnScriptChance;
+ property OnException : TPSOnException read FOnException write FOnException;
+ end;
+
+
+implementation
+
+resourcestring
+ sMissingEndStatment = 'Missing some ''End'' statments';
+
+
+function CompExportCheck(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure; const ProcDecl: tbtstring): Boolean;
+begin
+ TPSScriptExtension(Sender.ID).DoVerifyProc(Sender.Id, Proc, ProcDecl, Result);
+ Result := not Result;
+end;
+
+Function BeforeCleanup(Sender: TPSPascalCompiler):Boolean;
+begin
+ result := TPSScriptExtension(Sender.ID).DoBeforeCleanUp(Sender.ID,Sender);
+end;
+
+procedure CEException(Sender: TPSExec; ExError: TIFError; const ExParam: tbtstring; ExObject: TObject; ProcNo, Position: Cardinal);
+begin
+ if @TPSScriptExtension(Sender.ID).FOnException <> nil then
+ TPSScriptExtension(Sender.ID).FOnException(Sender, ExError, ExParam, ExObject, ProcNo, Position);
+end;
+
+{ TPSScriptExtension }
+
+function TPSScriptExtension.Compile: Boolean;
+begin
+ ClearProcList;
+
+ result := inherited Compile;
+ if result then FillMethods;
+
+
+ FNeedCompiling := not result;
+end;
+
+constructor TPSScriptExtension.Create(AOwner: TComponent);
+begin
+ inherited Create(AOwner);
+ Comp.OnBeforeCleanup := BeforeCleanup;
+ Comp.OnExportCheck := CompExportCheck;
+ Exec.OnException := CEException;
+
+ TStringList(script).OnChange := DoScriptChance;
+ FMethodList := TMethodList.create(Self);
+ FNeedCompiling := True;
+end;
+
+destructor TPSScriptExtension.Destroy;
+begin
+ FMethodList.Free;
+ FMethodList := nil;
+ inherited Destroy;
+end;
+
+procedure TPSScriptExtension.DoVerifyProc(Sender: TPSScript;
+ Proc: TPSInternalProcedure; const Decl: tbtstring; var Error: Boolean);
+var
+ n{,m,p} : Integer;
+ tstType : TPSProceduralType;
+begin
+ Error := False;
+ for n := 0 to sender.comp.GetTypeCount -1 do begin
+ If comp.GetType(n) is TPSProceduralType then begin
+ tstType := comp.GetType(n) as TPSProceduralType;
+ If tstType.ProcDef.Same(Proc.Decl) then begin
+ MethodList.addprocedure(Proc.OriginalName, tstType.Name);
+// Proc. aExport := etExportDecl;
+ end;
+ end;
+ end;
+ if assigned(OnVerifyProc) then
+ begin
+ onVerifyProc(Sender, Proc, Decl, Error);
+ end;
+end;
+
+type
+ TMyPascalCompiler = class(TPSPascalCompiler);
+const
+ sIFPSParameterMode : array [pmIn..pmInOut] of tbtstring = ('','\style{+B}out\style{-B} ','\style{+B}Var\style{-B} ');
+
+Procedure TPSScriptExtension.GetCodeProps;
+
+ Function existsItem(aName:tbtstring):Boolean;
+ Begin
+ result := FInserts.indexof(aName)<> -1;
+ end;
+
+ Procedure addListItem(aType, aName:tbtstring; aDef:tbtstring='');
+ var
+ x : LongInt;
+ begin
+ If not ((aName ='') or (aName[1]='!')) then begin
+ x := FInserts.Add(aName);
+ fItems.Insert(x, format('%s \column{}\style{+B}%s\style{-B} %s',[aType, aName, aDef]));
+ end;
+ end;
+
+ procedure Getdecl(decl : TPSParametersDecl; var T,v :tbtstring);
+ var
+ m : Integer;
+ begin
+ v := '';
+ for m := 0 to Decl.ParamCount-1 do begin
+ v := V +';'+sIFPSParameterMode[Decl.Params[m].Mode]+
+ Decl.Params[m].OrgName;
+ if Decl.Params[m].aType <> nil then
+ v := v +':'+ Decl.Params[m].aType.OriginalName;
+ end;
+ delete(v,1,1);
+ If v <> '' then v := '('+ v +')';
+ if Decl.Result<>nil then begin
+ v := v +':'+ Decl.Result.OriginalName;
+ t := 'Function';
+ end else t := 'Procedure';
+
+ end;
+
+ Function getTypeDef(xr: TPSType; aZoek:tbtstring = ''):Boolean; forward;
+
+ Function getClassDef(xc: TPSCompileTimeClass; aZoek:tbtstring = ''):Boolean;
+ var
+ Show : Boolean;
+ Zoek,bZoek : tbtstring;
+ tci : TPSDelphiClassItem;
+ n : Integer;
+ T,v : tbtstring;
+
+ begin
+ Show := aZoek='';
+ Zoek := aZoek;
+ If Pos('.',aZoek)>0 then begin
+ Zoek := copy(aZoek, 1 ,Pos('.',aZoek)-1);
+ bZoek := copy(aZoek, Pos('.',aZoek)+1, 999);
+ end else bZoek := '';
+
+ result := (xc <> nil) and Show;
+ if XC<> nil then begin
+ For n := 0 to xc.Count-1 do begin
+ tci := xc.Items[n];
+ If (tci = nil) or existsItem(tci.OrgName) then continue;
+ if tci is TPSDelphiClassItemConstructor then begin
+ Getdecl(tci.decl, T, V);
+ If Show then addListItem('Constructor',tci.OrgName, v);
+ end else
+ if tci is TPSDelphiClassItemMethod then begin
+ If Show then begin
+ Getdecl(tci.decl, T, V);
+ addListItem(T,tci.OrgName, v)
+ end else
+ If (tci.decl.Result <> nil) and (tci.Name = Zoek) then
+ result := getTypeDef(tci.decl.Result, bZoek);
+ end else
+ if tci is TPSDelphiClassItemProperty then begin
+ If Show then begin
+ t := '';
+ If tci.Decl.Result<> nil then t := ': '+ tci.Decl.Result.OriginalName;
+ addListItem('Property',tci.OrgName, t);
+ end else
+ If (tci.decl.Result <> nil) and (tci.Name = Zoek) then
+ result := getTypeDef(tci.decl.Result, bZoek);
+ end;
+ If result and not show then exit;
+ end;
+ result := getClassDef(XC.ClassInheritsFrom, aZoek) or result;
+ end;
+ end;
+
+ Function getTypeDef(xr: TPSType; aZoek:tbtstring = ''):Boolean;
+ var
+ Show : Boolean;
+ Zoek : tbtstring;
+ xri : PIFPSRecordFieldTypeDef;
+ n : Integer;
+ begin
+ Show := aZoek='';
+ result := (xr <> nil) and Show;
+ if xr <> nil then begin
+ If xr is TPSRecordType then begin
+ Zoek := aZoek;
+ If Pos('.',aZoek)>0 then begin
+ Zoek := copy(aZoek, 1 ,Pos('.',aZoek)-1);
+ aZoek := copy(aZoek, Pos('.',aZoek)+1, 999);
+ end else aZoek := '';
+ for n := 0 to (xr as TPSRecordType).RecValCount-1 do begin
+ xri := (xr as TPSRecordType).RecVal(n);
+ If Show then begin
+ addListItem('Var',xri.FieldOrgName,xri.aType.OriginalName)
+ end else
+ If (xri.aType <> nil) and (xri.FieldName = Zoek) then
+ result := getTypeDef(xri.aType, aZoek);
+ end;
+ end else
+ If (xr is TPSClassType) then begin
+ result := getClassDef((xr as TPSClassType).Cl, aZoek)
+ end else
+ result := False;
+ end;
+ end;
+
+ Function FindVarProc(aVarName:tbtstring; aZoek : tbtstring= ''):Boolean;
+ var
+// cv : tbtstring;
+ hh, h, i : Longint;
+ proc : TPSProcedure;
+ ip : TPSInternalProcedure;
+ ipv : PIFPSProcVar;
+ ipp : TPSParameterDecl;
+// t : tbtstring;
+ begin
+ Hh := MakeHash(aVarName);
+ result := False;
+ If FScriptPos =0 then exit;
+ for i := Comp.GetProcCount -1 downto 0 do begin
+ Proc := Comp.GetProc(i);
+ If (Proc.ClassType = TPSInternalProcedure) and
+ ((Proc as TPSInternalProcedure).DeclarePos < FScriptPos) then begin
+ ip := Proc as TPSInternalProcedure;
+ for h := 0 to ip.ProcVars.Count-1 do begin
+ ipv := PIFPSProcVar(ip.ProcVars[h]);
+ If aVarName = '' then begin
+ addListItem('Var',ipv.OrgName, ': '+ipv.AType.OriginalName);
+ end else
+ If (ipv.NameHash = HH) and (ipv.Name = aVarName) then begin
+ result := getTypeDef(ipv.aType, aZoek);
+ exit;
+ end;
+ end;
+ for h := 0 to ip.Decl.ParamCount-1 do begin
+ ipp := TPSParameterDecl(ip.Decl.Params[h]);
+ If aVarName = '' then begin
+ addListItem('Var',ipp.OrgName, ': '+ipp.aType.OriginalName);
+ end else
+ If {(ipp.Hash = HH) and} (ipp.Name = aVarName) then begin
+ result := getTypeDef(ipp.aType, aZoek);
+ exit;
+ end;
+ end;
+ end;
+ end;
+ end;
+
+ Function FindVarFunctType(aProcName:tbtstring): Boolean;
+ var
+ cv : tbtstring;
+ h, i : Longint;
+ proc : TPSProcedure;
+ xr : TPSRegProc;
+// t : tbtstring;
+ begin
+ cv := aProcName;
+ If Pos('.',aProcName)>0 then begin
+ cv := copy(aProcName, 1 ,Pos('.',aProcName)-1);
+ aProcName := copy(aProcName, Pos('.',aProcName)+1, 999);
+ end else aProcName := '';
+ H := MakeHash(Cv);
+// Result := False;
+ for i :=0 to Comp.GetVarCount -1 do begin
+ if (Comp.GetVar(I).NameHash = H) and (Comp.GetVar(I).Name = CV) then begin
+ Result := getTypeDef(Comp.GetVar(I).aType, aProcName);
+ Exit;
+ end;
+ end;
+ for i :=0 to Comp.GetTypeCount -1 do begin
+ if (Comp.GetType(I).NameHash = H) and (Comp.GetType(I).Name = CV) then begin
+ Result := getTypeDef(Comp.GetType(I), aProcName);
+ Exit;
+ end;
+ end;
+ result := FindVarProc(cv, aProcName);
+ If result then exit;
+ for i :=0 to Comp.GetProcCount -1 do begin
+ Proc := Comp.GetProc(i);
+ If Proc.ClassType = TPSInternalProcedure then begin
+ if ((Proc as TPSInternalProcedure).NameHash = H) and
+ ((Proc as TPSInternalProcedure).Name = CV) then begin
+ Result := getTypeDef((Proc as TPSInternalProcedure).Decl.Result, aProcName);
+ exit;
+ end;
+ end;
+ end;
+ with TMyPascalCompiler(Comp) do begin
+ for i := 0 to FRegProcs.Count-1 do begin
+ xr := FRegProcs[i];
+ if (xr.NameHash = H) and (xr.Name = CV) then begin
+ result := getTypeDef(xr.Decl.Result, aProcName);
+ exit;
+ end;
+ end;
+ end;
+ end;
+
+Var
+ n : Integer;
+ s, t, v : tbtstring;
+ proc : TPSProcedure;
+ xr : TPSRegProc;
+
+begin
+ If (fItems = nil) or (fInserts = Nil) then exit;
+ fItems.BeginUpdate;
+ fInserts.BeginUpdate;
+ tStringList(fInserts).Sorted := true;
+ tStringList(fInserts).Duplicates := dupAccept;
+ try
+ fInserts.Clear;
+ fItems.Clear;
+
+ If (FObjectNest <> '') then begin
+ FindVarFunctType(FastUpperCase(FObjectNest));
+ exit;
+ end;
+
+ for n := 0 to Comp.GetTypeCount-1 do begin
+ addListItem('Type',Comp.GetType(n).OriginalName);
+ end;
+ for n := 0 to Comp.GetVarCount-1 do begin
+ addListItem('Var',Comp.GetVar(n).OrgName, ': '+Comp.Getvar(n).aType.OriginalName);
+ end;
+ with TMyPascalCompiler(Comp) do begin
+ for n := 0 to FConstants.Count-1 do begin
+ addListItem('Const', TPSConstant(FConstants[n]).OrgName );
+ end;
+ for n := 0 to FRegProcs.Count-1 do begin
+ xr := FRegProcs[n];
+ Getdecl(xr.decl, T, v);
+ addListItem(t,xr.OrgName, v );
+ end;
+ end;
+ FindVarProc('');
+ for n := 0 to Comp.GetProcCount-1 do begin
+ s := '';
+ proc := Comp.GetProc(n);
+ If Proc.ClassType = TPSInternalProcedure then begin
+ s := (Proc as TPSInternalProcedure).OriginalName;
+ Getdecl((Proc as TPSInternalProcedure).decl, T, v);
+ end;
+ If s <> '' then begin
+ addListItem(t,s, v );
+ end;
+ end;
+ Finally
+ fInserts.EndUpdate;
+ fItems.EndUpdate;
+ end;
+end;
+
+procedure TPSScriptExtension.GetValueDefs(aItems, aInserts: TStrings; const aObjectNest: tbtstring; aScriptPos: Integer);
+begin
+ fItems := aItems;
+ fInserts := aInserts;
+ FScriptPos := aScriptPos;
+ fObjectNest := aObjectNest;
+ Try
+ compile;
+ finally
+ fItems := Nil;
+ fInserts := Nil;
+ FScriptPos := 0;
+ fObjectNest := '';
+ end;
+end;
+
+function TPSScriptExtension.DoBeforeCleanup(Sender: TObject;
+ aComp: TPSPascalCompiler): Boolean;
+begin
+ result := true;
+ If fItems <> nil then GetCodeProps;
+ If @FOnBeforeCleanUp<> nil then
+ result := FOnBeforeCleanUp(Sender, aComp);
+end;
+
+function TPSScriptExtension.Execute: Boolean;
+begin
+ CompileIfNeeded;
+ MethodList.FillMethods;
+ result := inherited Execute;
+end;
+
+
+procedure TPSScriptExtension.DoScriptChance(sender: TObject);
+begin
+ FNeedCompiling := True;
+ self.ClearProcList;
+ If @FOnScriptChance <> NIL then
+ FOnScriptChance(sender);
+end;
+
+procedure TPSScriptExtension.CompileIfNeeded;
+begin
+ if FNeedCompiling then begin
+ Compile;
+ end;
+end;
+
+procedure TPSScriptExtension.Notification(AComponent: TComponent;
+ Operation: TOperation);
+begin
+ inherited;
+ If Operation = opRemove then begin
+ if MethodList <> nil then
+ MethodList.SetMethodName(aComponent,'','');
+ end;
+end;
+
+function TPSScriptExtension.GetProcName(Instance: TObject; PropName: tbtstring): tbtstring;
+begin
+ Result := MethodList.ProcName[Instance, Propname];
+end;
+
+procedure TPSScriptExtension.SetProcName(Instance: TObject; PropName: tbtstring; const Value: tbtstring);
+begin
+ MethodList.ProcName[Instance, Propname] := Value;
+end;
+
+procedure TPSScriptExtension.ClearProcList;
+begin
+ MethodList.ClearProcList;
+end;
+
+procedure TPSScriptExtension.RemoveObjEvents(Obj: TObject);
+begin
+ MethodList.SetMethodName(Obj, '', '');
+end;
+
+procedure TPSScriptExtension.FillMethods;
+begin
+ MethodList.FillMethods;
+end;
+
+{ TMethodList }
+
+procedure TMethodList.AddProcedure(ProcName, ProcType: tbtstring);
+var
+ po : TProcObj;
+ x,y : Integer;
+
+begin
+ ProcType := Uppercase(ProcType);
+ x := ProcIndexOf(ProcName);
+ if x <> -1 then begin
+ y := Procs[x].ProcType.IndexOf(ProcType);
+ If y = -1 then TProcObj(fProcList.Items[x]).ProcType.add(ProcType);
+ end else begin
+ po := TProcObj.create(self);
+ po.Name := ProcName;
+ po.ProcType.add(ProcType);
+ fProcList.add(po);
+ end
+end;
+
+procedure TMethodList.ClearProcList;
+begin
+ fProcList.Clear;
+end;
+
+constructor TMethodList.create(aOwner: TPSScriptExtension);
+begin
+ inherited create;
+ fOwner := aOwner;
+ fProcList := TObjectList.create(true);
+ fEventList := TObjectList.create(true);
+end;
+
+procedure TMethodList.CreateProc(ProcName:tbtstring; aPropType: TTypeData);
+var
+ newProc: tbtstring;
+ P: PByte;
+ i: Integer;
+ pf : TParamFlags;
+
+ {$IFDEF FPC}
+ // mh: TParamFlags(P^) doesn't compile in FPC, this function will "fix" it.
+ // yes it's ugly, but I don't know an other way to fix it
+ function GetParamFlags(P: Byte): TParamFlags;
+ begin
+ result := [];
+ if (Ord(pfVar) and P <> 0) then Include(result, pfVar);
+ if (Ord(pfConst) and P <> 0) then Include(result, pfConst);
+ if (Ord(pfArray) and P <> 0) then Include(result, pfArray);
+ if (Ord(pfAddress) and P <> 0) then Include(result, pfAddress);
+ if (Ord(pfReference) and P <> 0) then Include(result, pfReference);
+ if (Ord(pfOut) and P <> 0) then Include(result, pfOut);
+ end;
+ {$ENDIF}
+
+begin
+ WITH aPropType do begin
+ if MethodKind=mkProcedure then NewProc:='procedure '
+ else NewProc:='function ';
+ NewProc:=NewProc + ProcName+'(';
+ P:=PByte(@ParamList);
+ for i:=0 to Pred(ParamCount) do
+ begin
+ {$IFDEF FPC}
+ pf:=GetParamFlags(P^);
+ {$ELSE}
+ pf:=TParamFlags(P^);
+ {$ENDIF}
+ if pfVar in pf then NewProc:=NewProc+'var ';
+ if pfConst in pf then NewProc:=NewProc+'const ';
+ Inc(P);
+ NewProc:=NewProc +PShortString(P)^ +' : ';
+ Inc(P,Succ(P^));
+ if pfArray in pf then NewProc:=NewProc+'array of ';
+ NewProc := NewProc + PShortString(P)^;
+ Inc(P,Succ(P^));
+ If i < Pred(ParamCount) then NewProc := NewProc + '; ';
+ end;
+ NewProc := NewProc +')' ;
+ if (MethodKind=mkFunction) then
+ NewProc := NewProc +':'+ PShortString(P)^;
+ NewProc:=NewProc+';'^m^j
+ +'Begin'^m^j^m^j
+ +'End;'^m^j;
+ If @fowner.FOnInsertMethod <> nil then begin
+ fowner.FOnInsertMethod(fOwner, NewProc, false);
+ end else begin
+ InsertMethod(NewProc);
+ end;
+ fowner.CompileIfNeeded;
+ end;
+end;
+
+procedure TMethodList.InsertMethod(NewProc: tbtstring; OnTop: Boolean = false);
+var
+ x : Integer;
+ sl : TStringList;
+ nBegins : Integer;
+ nProcs : Integer;
+ line, test : tbtstring;
+
+
+ function IsItem(line,item:tbtstring; First :Boolean = false):Boolean;
+ var
+ nPos : Integer;
+ begin
+ repeat
+ nPos := pos(item,line);
+ result := ((npos>0) and ((length(Line)-nPos<= length(item)) or not(line[nPos+length(item)] in ['0'..'9','A'..'Z','_'])) And
+ ((Npos = 1) or ((not first) and not(line[nPos-1] in ['0'..'9','A'..'Z','_']))));
+ if nPos <> 0 then line := copy(line,nPos+Length(Item),Length(line));
+ until (Result) or (nPos = 0);
+ end;
+
+ function DelSpaces(AText: tbtstring): tbtstring;
+ var i: Integer;
+ begin
+ Result := '';
+ for i := 1 to Length(AText) do
+ if AText[i] <> ' ' then
+ Result := Result + AText[i];
+ end;
+
+ function IsProcDecl(AnOriginalProcDecl: tbtstring): Boolean;
+ var
+ bIsFunc: Boolean;
+ iLineNo: Integer;
+ sProcKey: tbtstring;
+ sProcDecl: tbtstring;
+ begin
+ Result := false;
+ sProcDecl := Line;
+ iLineNo := x;
+ bIsFunc := isItem(AnOriginalProcDecl,'FUNCTION',true);
+
+ if bIsFunc
+ then sProcKey := 'FUNCTION'
+ else sProcKey := 'PROCEDURE';
+
+ sProcDecl := copy(sProcDecl,Pos(sProcKey,sProcDecl),Length(sProcDecl));
+
+ while not IsItem(sProcDecl,'BEGIN') do
+ begin
+ inc(iLineNo);
+ if iLineNo > (fowner.script.Count - 1) then exit;
+ sProcDecl := sProcDecl + ' ' + uppercase(trim(fowner.script[iLineNo])) + ' ';
+ end;
+
+ sProcDecl := DelSpaces(sProcDecl);
+ AnOriginalProcDecl := DelSpaces(AnOriginalProcDecl);
+
+ sProcDecl := copy(sProcDecl,1,Length(AnOriginalProcDecl));
+
+ Result := sProcDecl = AnOriginalProcDecl;
+
+ end;
+begin
+ sl := TStringList.create;
+ Try
+ sl.Text := NewProc;
+ test := uppercase(trim(sl[0]));
+ finally
+ Sl.free;
+ end;
+ nProcs := 0;
+ nBegins := 0;
+ x := 0;
+ If Not Ontop Then begin
+ for x := 0 to fOwner.script.count -1 do begin
+ Line := fowner.script[x];
+ Line := uppercase(trim(line));
+ If IsItem(line,'PROCEDURE', true) or IsItem(line,'FUNCTION', true) then begin
+ If nBegins >0 then Raise exception.create('Missing some ''end'' statments');
+ If (nProcs = 0) and IsProcDecl(test) and
+ (not IsItem(line,'FORWARD')) and (not IsItem(line,'EXTERNAL')) then
+ Exit;
+ Inc(nProcs);
+ end;
+ if IsItem(line,'FORWARD') or IsItem(line,'EXTERNAL') then
+ dec(nProcs);
+ If Pos('END',line) < Pos('BEGIN',line) then begin
+ If IsItem(line,'END') then begin
+ If (nBegins = 0) and (nProcs=0) then Break;
+ Dec(nBegins);
+ If nBegins = 0 then Dec(nProcs);
+ end;
+ If IsItem(line,'BEGIN') or IsItem(line,'TRY') or IsItem(line,'CASE') then begin
+ If nProcs = 0 then Break;
+ Inc(nBegins);
+ end;
+ end else begin
+ If IsItem(line,'BEGIN') or IsItem(line,'TRY') or IsItem(line,'CASE') then begin
+ If nProcs = 0 then Break;
+ Inc(nBegins);
+ end;
+ If IsItem(line,'END') then begin
+ If (nBegins = 0) and (nProcs=0) then Break;
+ Dec(nBegins);
+ If nBegins = 0 then Dec(nProcs);
+ end;
+ end;
+ end;
+ end;
+ FOwner.script.BeginUpdate;
+ Try
+ If (nProcs <> 0) or (nBegins<>0) then
+ Raise exception.create(sMissingEndStatment);
+ If (Not Ontop) and (x>0) and (Trim(FOwner.script[x-1])<>'') then begin
+ FOwner.script.Insert(x,'');
+ inc(x);
+ end;
+ FOwner.script.Insert(x,NewProc);
+ FOwner.script.text := FOwner.script.text;
+ finally
+ FOwner.script.EndUpdate;
+ end;
+end;
+
+destructor TMethodList.Destroy;
+begin
+ fProcList.Free; {<< Needs Eventlist for removing Methods}
+ fEventList.Free;
+ inherited;
+end;
+
+procedure TMethodList.FillMethods;
+var
+ x, y : Integer;
+ m : TMethod;
+begin
+ for x := 0 to fEventList.Count-1 do begin
+ Y := ProcIndexOf(MethodS[x].ProcName);
+ If (Y >= 0) and assigned(Methods[x].Instance) then begin
+ m := Procs[Y].Method;
+ if m.Data = nil then begin
+ m := fOwner.Exec.GetProcAsMethodN(Procs[Y].name);
+ TProcObj(fProcList.Items[Y]).Method := m;
+ end;
+ SetMethodProp(Methods[x].Instance, Methods[x].propname, m );
+ end;
+ end;
+end;
+
+function TMethodList.GetMethodName(Instance: TObject; PropName: tbtstring): tbtstring;
+var
+ x : Integer;
+begin
+ fOwner.CompileIfNeeded;
+ x := methodIndexOf(Instance,PropName);
+ If x>=0 then result := Methods[x].ProcName
+ else result := '';
+end;
+
+function TMethodList.GetObject(Index: Integer): TMethodObj;
+begin
+ result := TMethodObj(fEventList.items[Index]);
+end;
+
+function TMethodList.GetProcObj(Index: Integer): TProcObj;
+begin
+ result := TProcObj(fProcList.items[Index]);
+end;
+
+procedure TMethodList.ListEventsName(EventType: tbtstring; List: TStrings);
+var
+ x : Integer;
+begin
+ If List = nil then exit;
+ EventType := Uppercase(EventType);
+ List.Clear;
+ fOwner.CompileIfNeeded;
+ for x := 0 to fProcList.count-1 do begin
+ If Procs[x].ProcType.indexof(EventType)<> -1 then
+ List.add(Procs[x].name);
+ end;
+end;
+
+function TMethodList.MethodCount: Integer;
+begin
+ result := fEventList.count;
+end;
+
+function TMethodList.methodIndexOf(Instance: TObject;
+ PropName: tbtstring): Integer;
+var x : integer;
+begin
+ Result := -1;
+ for x := 0 to fEventList.count-1 do begin
+ if (TMethodObj(fEventList.Items[x]).Instance = Instance) and
+ ((propName='') or(TMethodObj(fEventList.Items[x]).PropName = PropName)) then begin
+ Result := x;
+ exit;
+ end;
+ end;
+end;
+
+function TMethodList.ProcCount: Integer;
+begin
+ result := fProcList.count;
+end;
+
+function TMethodList.ProcIndexOf(Name: tbtstring): Integer;
+var x : integer;
+begin
+ result := -1;
+ Name := Uppercase(name);
+ For x := 0 to fProcList.count-1 do begin
+ If Uppercase(TProcObj(fProcList.Items[x]).name) = name then begin
+ Result := x;
+ exit;
+ end;
+ end;
+end;
+
+procedure TMethodList.SetMethodName(Instance: TObject; PropName: tbtstring;
+ const Value: tbtstring);
+var
+ x, y : Integer;
+ mo : TMethodObj;
+ function TypeData(Instance: TObject; const PropName: tbtstring):PTypeData;
+ var
+ PropInfo: PPropInfo;
+ begin
+ // assume failure
+ Result := Nil;
+ PropInfo := GetPropInfo(Instance, PropName);
+ if PropInfo <> nil then
+ begin
+ Result:= GetTypeData(PropInfo^.PropType{$IFNDEF FPC}^{$ENDIF});
+ end
+ end;
+
+begin
+ If PropName = '' then begin
+ x := 0;
+ While x < MethodCount do begin
+ If (Methods[x].Instance = Instance) or (Instance = nil) then
+ fEventList.Delete(x)
+ else Inc(x);
+ end;
+ end else begin
+ x := methodIndexOf(Instance, PropName);
+ if value = '' then begin
+ if x >= 0 then fEventList.Delete(x);
+ end else begin
+ fOwner.CompileIfNeeded;
+ y := ProcIndexOf(Value);
+ If (Y = -1) then begin
+ CreateProc(Value, TypeData(Instance,propName)^);
+ y := 0;
+ end;
+ If (x = -1) then begin
+ If (Y <> -1) then begin
+ mo := TMethodObj.create;
+ mo.Instance := TPersistent(Instance);
+ mo.ProPName := Propname;
+ mo.procName := Value;
+ If (methodIndexOf(Instance,'')<>-1) and Instance.InheritsFrom(TComponent) then
+ fOwner.FreeNotification(TComponent(Instance));
+ fEventList.add(mo);
+ end;
+ end else
+ begin
+ Methods[x].procname := Value;
+ end;
+ end;
+ end;
+end;
+
+procedure TMethodList.ClearAll;
+begin
+ fProclist.clear;
+ fEventList.Clear;
+end;
+
+{ TProcObj }
+
+constructor TProcObj.create(aOwner: TMethodList);
+begin
+ inherited create();
+ fOwner := aOwner;
+ ProcType := TStringList.Create;
+end;
+
+destructor TProcObj.Destroy;
+
+var x : Integer;
+ m :TMethod;
+begin
+ m.Code := nil;
+ m.Data := nil;
+ If ((Method.Data <> nil) or (method.Code<> nil)) and (fOwner<>nil) and assigned(fOwner) then begin
+ for x := 0 to fOwner.MethodCount-1 do begin
+ If (name = fOwner.Methods[x].ProcName) and assigned(fOwner.Methods[x].Instance) then begin
+ Try
+ SetMethodProp(fOwner.Methods[x].Instance, fOwner.Methods[x].PropName,m);
+ except; end;
+ end;
+ end;
+ end;
+ ProcType.free;
+ inherited;
+end;
+
+procedure TProcObj.SetName(const Value: tbtstring);
+var
+ x : Integer;
+begin
+ If FName <> Value then begin
+ If fName<>'' then begin
+ for x := 0 to fOwner.MethodCount-1 do begin
+ If Fname = fOwner.Methods[x].ProcName then begin
+ fOwner.Methods[x].ProcName := Value;
+ end;
+ end;
+ end;
+ FName := Value;
+ end;
+end;
+
+
+end.
diff --git a/Units/PascalScript/uPSComponent_COM.pas b/Units/PascalScript/uPSComponent_COM.pas
new file mode 100644
index 0000000..1ae3533
--- /dev/null
+++ b/Units/PascalScript/uPSComponent_COM.pas
@@ -0,0 +1,38 @@
+
+unit uPSComponent_COM;
+
+interface
+uses
+ SysUtils, Classes, uPSComponent, uPSCompiler, uPSRuntime;
+type
+
+ TPSImport_ComObj = class(TPSPlugin)
+ private
+ public
+ procedure CompileImport1(CompExec: TPSScript); override;
+ procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
+ end;
+
+ TIFPS3CE_ComObj = class(TPSImport_ComObj);
+
+implementation
+uses
+ uPSC_comobj,
+ uPSR_comobj;
+
+
+{ TPSImport_ComObj }
+
+procedure TPSImport_ComObj.CompileImport1(CompExec: TPSScript);
+begin
+ SIRegister_ComObj(CompExec.Comp);
+end;
+
+
+procedure TPSImport_ComObj.ExecImport1(CompExec: TPSScript;
+ const ri: TPSRuntimeClassImporter);
+begin
+ RIRegister_ComObj(CompExec.Exec);
+end;
+
+end.
diff --git a/Units/PascalScript/uPSComponent_Controls.pas b/Units/PascalScript/uPSComponent_Controls.pas
new file mode 100644
index 0000000..fce7b29
--- /dev/null
+++ b/Units/PascalScript/uPSComponent_Controls.pas
@@ -0,0 +1,65 @@
+ unit uPSComponent_Controls;
+
+interface
+uses
+ SysUtils, Classes, uPSComponent, uPSCompiler, uPSRuntime;
+type
+
+ TPSImport_Controls = class(TPSPlugin)
+ private
+ FEnableStreams: Boolean;
+ FEnableGraphics: Boolean;
+ FEnableControls: Boolean;
+ public
+ procedure CompileImport1(CompExec: TPSScript); override;
+ procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
+ public
+ constructor Create(AOwner: TComponent); override;
+ published
+
+ property EnableStreams: Boolean read FEnableStreams write FEnableStreams;
+
+ property EnableGraphics: Boolean read FEnableGraphics write FEnableGraphics;
+
+ property EnableControls: Boolean read FEnableControls write FEnableControls;
+ end;
+
+ TIFPS3CE_Controls = class(TPSImport_Controls);
+
+implementation
+uses
+ uPSC_graphics,
+ uPSC_controls,
+ uPSR_graphics,
+ uPSR_controls;
+
+
+{ TPSImport_Controls }
+
+procedure TPSImport_Controls.CompileImport1(CompExec: TPSScript);
+begin
+ if FEnableGraphics then
+ SIRegister_Graphics(CompExec.Comp, FEnableStreams);
+ if FEnableControls then
+ SIRegister_Controls(CompExec.Comp);
+end;
+
+constructor TPSImport_Controls.Create(AOwner: TComponent);
+begin
+ inherited Create(AOwner);
+ FEnableStreams := True;
+ FEnableGraphics := True;
+ FEnableControls := True;
+end;
+
+procedure TPSImport_Controls.ExecImport1(CompExec: TPSScript;
+ const ri: TPSRuntimeClassImporter);
+begin
+ if FEnableGraphics then
+ RIRegister_Graphics(ri, FEnableStreams);
+ if FEnableControls then
+ RIRegister_Controls(ri);
+end;
+
+
+end.
diff --git a/Units/PascalScript/uPSComponent_DB.pas b/Units/PascalScript/uPSComponent_DB.pas
new file mode 100644
index 0000000..c60d06e
--- /dev/null
+++ b/Units/PascalScript/uPSComponent_DB.pas
@@ -0,0 +1,36 @@
+ unit uPSComponent_DB;
+
+interface
+{$I PascalScript.inc}
+uses
+ SysUtils, Classes, uPSComponent, uPSRuntime, uPSCompiler;
+type
+
+ TPSImport_DB = class(TPSPlugin)
+ public
+ procedure CompileImport1(CompExec: TPSScript); override;
+ procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
+ public
+ end;
+
+ TIFPS3CE_DB = class(TPSImport_DB);
+
+implementation
+uses
+ uPSC_DB,
+ uPSR_DB;
+
+{ TPSImport_DB }
+
+procedure TPSImport_DB.CompileImport1(CompExec: TPSScript);
+begin
+ SIRegister_DB(CompExec.Comp);
+end;
+
+procedure TPSImport_DB.ExecImport1(CompExec: TPSScript;
+ const ri: TPSRuntimeClassImporter);
+begin
+ RIRegister_DB(RI);
+end;
+
+end.
diff --git a/Units/PascalScript/uPSComponent_Default.pas b/Units/PascalScript/uPSComponent_Default.pas
new file mode 100644
index 0000000..e7508cf
--- /dev/null
+++ b/Units/PascalScript/uPSComponent_Default.pas
@@ -0,0 +1,81 @@
+ unit uPSComponent_Default;
+{$I PascalScript.inc}
+interface
+uses
+ SysUtils, Classes, uPSComponent, uPSCompiler, uPSRuntime;
+
+type
+
+ TPSImport_DateUtils = class(TPSPlugin)
+ public
+ procedure CompOnUses(CompExec: TPSScript); override;
+ procedure ExecOnUses(CompExec: TPSScript); override;
+ end;
+
+ TPSImport_Classes = class(TPSPlugin)
+ private
+ FEnableStreams: Boolean;
+ FEnableClasses: Boolean;
+ public
+ procedure CompileImport1(CompExec: TPSScript); override;
+ procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
+ public
+
+ constructor Create(AOwner: TComponent); override;
+ published
+
+ property EnableStreams: Boolean read FEnableStreams write FEnableStreams;
+
+ property EnableClasses: Boolean read FEnableClasses write FEnableClasses;
+ end;
+
+ TIFPS3CE_Std = class(TPSImport_Classes);
+
+ TIFPS3CE_DateUtils = class(TPSImport_DateUtils);
+
+implementation
+uses
+ uPSC_std,
+ uPSR_std,
+ uPSC_classes,
+ uPSR_classes,
+ uPSC_dateutils,
+ uPSR_dateutils;
+
+{ TPSImport_Classes }
+
+procedure TPSImport_Classes.CompileImport1(CompExec: TPSScript);
+begin
+ SIRegister_Std(CompExec.Comp);
+ if FEnableClasses then
+ SIRegister_Classes(CompExec.Comp, FEnableStreams);
+end;
+
+procedure TPSImport_Classes.ExecImport1(CompExec: TPSScript;
+ const ri: TPSRuntimeClassImporter);
+begin
+ RIRegister_Std(Ri);
+ if FEnableClasses then
+ RIRegister_Classes(ri, FEnableStreams);
+end;
+
+constructor TPSImport_Classes.Create(AOwner: TComponent);
+begin
+ inherited Create(AOwner);
+ FEnableStreams := True;
+ FEnableClasses := True;
+end;
+
+{ TPSImport_DateUtils }
+
+procedure TPSImport_DateUtils.CompOnUses(CompExec: TPSScript);
+begin
+ RegisterDateTimeLibrary_C(CompExec.Comp);
+end;
+
+procedure TPSImport_DateUtils.ExecOnUses(CompExec: TPSScript);
+begin
+ RegisterDateTimeLibrary_R(CompExec.Exec);
+end;
+
+end.
diff --git a/Units/PascalScript/uPSComponent_Forms.pas b/Units/PascalScript/uPSComponent_Forms.pas
new file mode 100644
index 0000000..418fbb2
--- /dev/null
+++ b/Units/PascalScript/uPSComponent_Forms.pas
@@ -0,0 +1,65 @@
+
+unit uPSComponent_Forms;
+
+interface
+uses
+ SysUtils, Classes, uPSRuntime, uPSCompiler, uPSComponent;
+type
+
+ TPSImport_Forms = class(TPSPlugin)
+ private
+ FEnableForms: Boolean;
+ FEnableMenus: Boolean;
+ public
+ procedure CompileImport1(CompExec: TPSScript); override;
+ procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
+ public
+ constructor Create(AOwner: TComponent); override;
+ published
+
+ property EnableForms: Boolean read FEnableForms write FEnableForms;
+
+ property EnableMenus: Boolean read FEnableMenus write FEnableMenus;
+ end;
+
+ TIFPS3CE_Forms = class(TPSImport_Forms);
+
+implementation
+uses
+ uPSC_forms,
+ uPSC_menus,
+ uPSR_forms,
+ uPSR_menus;
+
+{ TPSImport_Forms }
+
+procedure TPSImport_Forms.CompileImport1(CompExec: TPSScript);
+begin
+ if FEnableForms then
+ SIRegister_Forms(CompExec.comp);
+ if FEnableMenus then
+ SIRegister_Menus(CompExec.comp);
+end;
+
+constructor TPSImport_Forms.Create(AOwner: TComponent);
+begin
+ inherited Create(Aowner);
+ FEnableForms := True;
+ FEnableMenus := True;
+end;
+
+procedure TPSImport_Forms.ExecImport1(CompExec: TPSScript;
+ const ri: TPSRuntimeClassImporter);
+begin
+ if FEnableForms then
+ RIRegister_Forms(ri);
+
+ if FEnableMenus then
+ begin
+ RIRegister_Menus(ri);
+ RIRegister_Menus_Routines(compexec.Exec);
+ end;
+
+end;
+
+end.
diff --git a/Units/PascalScript/uPSComponent_StdCtrls.pas b/Units/PascalScript/uPSComponent_StdCtrls.pas
new file mode 100644
index 0000000..9f92923
--- /dev/null
+++ b/Units/PascalScript/uPSComponent_StdCtrls.pas
@@ -0,0 +1,65 @@
+
+unit uPSComponent_StdCtrls;
+
+interface
+uses
+ SysUtils, Classes, uPSComponent, uPSCompiler, uPSRuntime;
+type
+
+ TPSImport_StdCtrls = class(TPSPlugin)
+ private
+ FEnableButtons: Boolean;
+ FEnableExtCtrls: Boolean;
+ public
+ procedure CompileImport1(CompExec: TPSScript); override;
+ procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
+ public
+ constructor Create(AOwner: TComponent); override;
+ published
+
+ property EnableExtCtrls: Boolean read FEnableExtCtrls write FEnableExtCtrls;
+
+ property EnableButtons: Boolean read FEnableButtons write FEnableButtons;
+ end;
+
+ TIFPS3CE_StdCtrls = class(TPSImport_StdCtrls);
+
+
+implementation
+uses
+ uPSC_buttons,
+ uPSC_stdctrls,
+ uPSC_extctrls,
+ uPSR_buttons,
+ uPSR_stdctrls,
+ uPSR_extctrls;
+
+{ TPSImport_StdCtrls }
+
+procedure TPSImport_StdCtrls.CompileImport1(CompExec: TPSScript);
+begin
+ SIRegister_stdctrls(CompExec.Comp);
+ if FEnableExtCtrls then
+ SIRegister_ExtCtrls(CompExec.Comp);
+ if FEnableButtons then
+ SIRegister_Buttons(CompExec.Comp);
+end;
+
+constructor TPSImport_StdCtrls.Create(AOwner: TComponent);
+begin
+ inherited Create(Aowner);
+ FEnableButtons := True;
+ FEnableExtCtrls := True;
+end;
+
+procedure TPSImport_StdCtrls.ExecImport1(CompExec: TPSScript;
+ const ri: TPSRuntimeClassImporter);
+begin
+ RIRegister_stdctrls(RI);
+ if FEnableExtCtrls then
+ RIRegister_ExtCtrls(RI);
+ if FEnableButtons then
+ RIRegister_Buttons(RI);
+end;
+
+end.
diff --git a/Units/PascalScript/uPSDebugger.pas b/Units/PascalScript/uPSDebugger.pas
new file mode 100644
index 0000000..3b58393
--- /dev/null
+++ b/Units/PascalScript/uPSDebugger.pas
@@ -0,0 +1,654 @@
+
+unit uPSDebugger;
+{$I PascalScript.inc}
+interface
+uses
+ SysUtils, uPSRuntime, uPSUtils;
+
+type
+
+ TDebugMode = (dmRun
+ , dmStepOver
+ , dmStepInto
+ , dmPaused
+ );
+
+ TPSCustomDebugExec = class(TPSExec)
+ protected
+ FDebugDataForProcs: TIfList;
+ FLastProc: TPSProcRec;
+ FCurrentDebugProc: Pointer;
+ FProcNames: TIFStringList;
+ FGlobalVarNames: TIfStringList;
+ FCurrentSourcePos, FCurrentRow, FCurrentCol: Cardinal;
+ FCurrentFile: tbtstring;
+
+ function GetCurrentProcParams: TIfStringList;
+
+ function GetCurrentProcVars: TIfStringList;
+ protected
+
+ procedure ClearDebug; virtual;
+ public
+
+ function GetCurrentProcNo: Cardinal;
+
+ function GetCurrentPosition: Cardinal;
+
+ function TranslatePosition(Proc, Position: Cardinal): Cardinal;
+
+ function TranslatePositionEx(Proc, Position: Cardinal; var Pos, Row, Col: Cardinal; var Fn: tbtstring): Boolean;
+
+ procedure LoadDebugData(const Data: tbtstring);
+
+ procedure Clear; override;
+
+ property GlobalVarNames: TIfStringList read FGlobalVarNames;
+
+ property ProcNames: TIfStringList read FProcNames;
+
+ property CurrentProcVars: TIfStringList read GetCurrentProcVars;
+
+ property CurrentProcParams: TIfStringList read GetCurrentProcParams;
+
+ function GetGlobalVar(I: Cardinal): PIfVariant;
+
+ function GetProcVar(I: Cardinal): PIfVariant;
+
+ function GetProcParam(I: Cardinal): PIfVariant;
+
+ constructor Create;
+
+ destructor Destroy; override;
+ end;
+ TPSDebugExec = class;
+
+ TOnSourceLine = procedure (Sender: TPSDebugExec; const Name: tbtstring; Position, Row, Col: Cardinal);
+
+ TOnIdleCall = procedure (Sender: TPSDebugExec);
+
+ TPSDebugExec = class(TPSCustomDebugExec)
+ private
+ FDebugMode: TDebugMode;
+ FStepOverProc: TPSInternalProcRec;
+ FStepOverStackBase: Cardinal;
+ FOnIdleCall: TOnIdleCall;
+ FOnSourceLine: TOnSourceLine;
+ FDebugEnabled: Boolean;
+ protected
+
+ procedure SourceChanged;
+ procedure ClearDebug; override;
+ procedure RunLine; override;
+ public
+ constructor Create;
+
+ function LoadData(const s: tbtstring): Boolean; override;
+
+ procedure Pause; override;
+
+ procedure Run;
+
+ procedure StepInto;
+
+ procedure StepOver;
+
+ procedure Stop; override;
+
+ property DebugMode: TDebugMode read FDebugMode;
+
+ property OnSourceLine: TOnSourceLine read FOnSourceLine write FOnSourceLine;
+
+ property OnIdleCall: TOnIdleCall read FOnIdleCall write FOnIdleCall;
+
+ property DebugEnabled: Boolean read FDebugEnabled write FDebugEnabled;
+ end;
+ TIFPSDebugExec = TPSDebugExec;
+
+implementation
+
+{$IFDEF DELPHI3UP }
+resourceString
+{$ELSE }
+const
+{$ENDIF }
+
+ RPS_ExpectedReturnAddressStackBase = 'Expected return address at stack base';
+
+type
+ PPositionData = ^TPositionData;
+ TPositionData = packed record
+ FileName: tbtstring;
+ Position,
+ Row,
+ Col,
+ SourcePosition: Cardinal;
+ end;
+ PFunctionInfo = ^TFunctionInfo;
+ TFunctionInfo = packed record
+ Func: TPSProcRec;
+ FParamNames: TIfStringList;
+ FVariableNames: TIfStringList;
+ FPositionTable: TIfList;
+ end;
+
+{ TPSCustomDebugExec }
+
+procedure TPSCustomDebugExec.Clear;
+begin
+ inherited Clear;
+ if FGlobalVarNames <> nil then ClearDebug;
+end;
+
+procedure TPSCustomDebugExec.ClearDebug;
+var
+ i, j: Longint;
+ p: PFunctionInfo;
+begin
+ FCurrentDebugProc := nil;
+ FLastProc := nil;
+ FProcNames.Clear;
+ FGlobalVarNames.Clear;
+ FCurrentSourcePos := 0;
+ FCurrentRow := 0;
+ FCurrentCol := 0;
+ FCurrentFile := '';
+ for i := 0 to FDebugDataForProcs.Count -1 do
+ begin
+ p := FDebugDataForProcs[I];
+ for j := 0 to p^.FPositionTable.Count -1 do
+ begin
+ Dispose(PPositionData(P^.FPositionTable[J]));
+ end;
+ p^.FPositionTable.Free;
+ p^.FParamNames.Free;
+ p^.FVariableNames.Free;
+ Dispose(p);
+ end;
+ FDebugDataForProcs.Clear;
+end;
+
+constructor TPSCustomDebugExec.Create;
+begin
+ inherited Create;
+ FCurrentSourcePos := 0;
+ FCurrentRow := 0;
+ FCurrentCol := 0;
+ FCurrentFile := '';
+ FDebugDataForProcs := TIfList.Create;
+ FLastProc := nil;
+ FCurrentDebugProc := nil;
+ FProcNames := TIFStringList.Create;
+ FGlobalVarNames := TIfStringList.Create;
+end;
+
+destructor TPSCustomDebugExec.Destroy;
+begin
+ Clear;
+ FDebugDataForProcs.Free;
+ FProcNames.Free;
+ FGlobalVarNames.Free;
+ FGlobalVarNames := nil;
+ inherited Destroy;
+end;
+
+function TPSCustomDebugExec.GetCurrentPosition: Cardinal;
+begin
+ Result := TranslatePosition(GetCurrentProcNo, 0);
+end;
+
+function TPSCustomDebugExec.GetCurrentProcNo: Cardinal;
+var
+ i: Longint;
+begin
+ for i := 0 to FProcs.Count -1 do
+ begin
+ if FProcs[i]= FCurrProc then
+ begin
+ Result := I;
+ Exit;
+ end;
+ end;
+ Result := Cardinal(-1);
+end;
+
+function TPSCustomDebugExec.GetCurrentProcParams: TIfStringList;
+begin
+ if FCurrentDebugProc <> nil then
+ begin
+ Result := PFunctionInfo(FCurrentDebugProc)^.FParamNames;
+ end else Result := nil;
+end;
+
+function TPSCustomDebugExec.GetCurrentProcVars: TIfStringList;
+begin
+ if FCurrentDebugProc <> nil then
+ begin
+ Result := PFunctionInfo(FCurrentDebugProc)^.FVariableNames;
+ end else Result := nil;
+end;
+
+function TPSCustomDebugExec.GetGlobalVar(I: Cardinal): PIfVariant;
+begin
+ Result := FGlobalVars[I];
+end;
+
+function TPSCustomDebugExec.GetProcParam(I: Cardinal): PIfVariant;
+begin
+ Result := FStack[Cardinal(Longint(FCurrStackBase) - Longint(I) - 1)];
+end;
+
+function TPSCustomDebugExec.GetProcVar(I: Cardinal): PIfVariant;
+begin
+ Result := FStack[Cardinal(Longint(FCurrStackBase) + Longint(I) + 1)];
+end;
+
+function GetProcDebugInfo(FProcs: TIFList; Proc: TPSProcRec): PFunctionInfo;
+var
+ i: Longint;
+ c: PFunctionInfo;
+begin
+ if Proc = nil then
+ begin
+ Result := nil;
+ exit;
+ end;
+ for i := FProcs.Count -1 downto 0 do
+ begin
+ c := FProcs.Data^[I];
+ if c^.Func = Proc then
+ begin
+ Result := c;
+ exit;
+ end;
+ end;
+ new(c);
+ c^.Func := Proc;
+ c^.FPositionTable := TIfList.Create;
+ c^.FVariableNames := TIfStringList.Create;
+ c^.FParamNames := TIfStringList.Create;
+ FProcs.Add(c);
+ REsult := c;
+end;
+
+procedure TPSCustomDebugExec.LoadDebugData(const Data: tbtstring);
+var
+ CP, I: Longint;
+ c: tbtchar;
+ CurrProcNo, LastProcNo: Cardinal;
+ LastProc: PFunctionInfo;
+ NewLoc: PPositionData;
+ s: tbtstring;
+begin
+ ClearDebug;
+ if FStatus = isNotLoaded then exit;
+ CP := 1;
+ LastProcNo := Cardinal(-1);
+ LastProc := nil;
+ while CP <= length(Data) do
+ begin
+ c := Data[CP];
+ inc(cp);
+ case c of
+ #0:
+ begin
+ i := cp;
+ if i > length(data) then exit;
+ while Data[i] <> #0 do
+ begin
+ if Data[i] = #1 then
+ begin
+ FProcNames.Add(Copy(Data, cp, i-cp));
+ cp := I + 1;
+ end;
+ inc(I);
+ if I > length(data) then exit;
+ end;
+ cp := i + 1;
+ end;
+ #1:
+ begin
+ i := cp;
+ if i > length(data) then exit;
+ while Data[i] <> #0 do
+ begin
+ if Data[i] = #1 then
+ begin
+ FGlobalVarNames.Add(Copy(Data, cp, i-cp));
+ cp := I + 1;
+ end;
+ inc(I);
+ if I > length(data) then exit;
+ end;
+ cp := i + 1;
+ end;
+ #2:
+ begin
+ if cp + 4 > Length(data) then exit;
+ CurrProcNo := Cardinal((@Data[cp])^);
+ if CurrProcNo = Cardinal(-1) then Exit;
+ if CurrProcNo <> LastProcNo then
+ begin
+ LastProcNo := CurrProcNo;
+ LastProc := GetProcDebugInfo(FDebugDataForProcs, FProcs[CurrProcNo]);
+ if LastProc = nil then exit;
+ end;
+ inc(cp, 4);
+
+ i := cp;
+ if i > length(data) then exit;
+ while Data[i] <> #0 do
+ begin
+ if Data[i] = #1 then
+ begin
+ LastProc^.FParamNames.Add(Copy(Data, cp, i-cp));
+ cp := I + 1;
+ end;
+ inc(I);
+ if I > length(data) then exit;
+ end;
+ cp := i + 1;
+ end;
+ #3:
+ begin
+ if cp + 4 > Length(data) then exit;
+ CurrProcNo := Cardinal((@Data[cp])^);
+ if CurrProcNo = Cardinal(-1) then Exit;
+ if CurrProcNo <> LastProcNo then
+ begin
+ LastProcNo := CurrProcNo;
+ LastProc := GetProcDebugInfo(FDebugDataForProcs, FProcs[CurrProcNo]);
+ if LastProc = nil then exit;
+ end;
+ inc(cp, 4);
+
+ i := cp;
+ if i > length(data) then exit;
+ while Data[i] <> #0 do
+ begin
+ if Data[i] = #1 then
+ begin
+ LastProc^.FVariableNames.Add(Copy(Data, cp, i-cp));
+ cp := I + 1;
+ end;
+ inc(I);
+ if I > length(data) then exit;
+ end;
+ cp := i + 1;
+ end;
+ #4:
+ begin
+ i := cp;
+ if i > length(data) then exit;
+ while Data[i] <> #0 do
+ begin
+ if Data[i] = #1 then
+ begin
+ s := Copy(Data, cp, i-cp);
+ cp := I + 1;
+ Break;
+ end;
+ inc(I);
+ if I > length(data) then exit;
+ end;
+ if cp + 4 > Length(data) then exit;
+ CurrProcNo := Cardinal((@Data[cp])^);
+ if CurrProcNo = Cardinal(-1) then Exit;
+ if CurrProcNo <> LastProcNo then
+ begin
+ LastProcNo := CurrProcNo;
+ LastProc := GetProcDebugInfo(FDebugDataForProcs, FProcs[CurrProcNo]);
+ if LastProc = nil then exit;
+ end;
+ inc(cp, 4);
+ if cp + 16 > Length(data) then exit;
+ new(NewLoc);
+ NewLoc^.Position := Cardinal((@Data[Cp])^);
+ NewLoc^.FileName := s;
+ NewLoc^.SourcePosition := Cardinal((@Data[Cp+4])^);
+ NewLoc^.Row := Cardinal((@Data[Cp+8])^);
+ NewLoc^.Col := Cardinal((@Data[Cp+12])^);
+ inc(cp, 16);
+ LastProc^.FPositionTable.Add(NewLoc);
+ end;
+ else
+ begin
+ ClearDebug;
+ Exit;
+ end;
+ end;
+
+ end;
+end;
+
+
+
+
+
+
+function TPSCustomDebugExec.TranslatePosition(Proc, Position: Cardinal): Cardinal;
+var
+ D1, D2: Cardinal;
+ s: tbtstring;
+begin
+ if not TranslatePositionEx(Proc, Position, Result, D1, D2, s) then
+ Result := 0;
+end;
+
+function TPSCustomDebugExec.TranslatePositionEx(Proc, Position: Cardinal;
+ var Pos, Row, Col: Cardinal; var Fn: tbtstring): Boolean;
+// Made by Martijn Laan (mlaan@wintax.nl)
+var
+ i: LongInt;
+ fi: PFunctionInfo;
+ pt: TIfList;
+ r: PPositionData;
+ lastfn: tbtstring;
+ LastPos, LastRow, LastCol: Cardinal;
+ pp: TPSProcRec;
+begin
+ fi := nil;
+ pp := FProcs[Proc];
+ for i := 0 to FDebugDataForProcs.Count -1 do
+ begin
+ fi := FDebugDataForProcs[i];
+ if fi^.Func = pp then
+ Break;
+ fi := nil;
+ end;
+ LastPos := 0;
+ LastRow := 0;
+ LastCol := 0;
+ if fi <> nil then begin
+ pt := fi^.FPositionTable;
+ for i := 0 to pt.Count -1 do
+ begin
+ r := pt[I];
+ if r^.Position >= Position then
+ begin
+ if r^.Position = Position then
+ begin
+ Pos := r^.SourcePosition;
+ Row := r^.Row;
+ Col := r^.Col;
+ Fn := r^.Filename;
+ end
+ else
+ begin
+ Pos := LastPos;
+ Row := LastRow;
+ Col := LastCol;
+ Fn := LastFn;
+ end;
+ Result := True;
+ exit;
+ end else
+ begin
+ LastPos := r^.SourcePosition;
+ LastRow := r^.Row;
+ LastCol := r^.Col;
+ LastFn := r^.FileName;
+ end;
+ end;
+ Pos := LastPos;
+ Row := LastRow;
+ Col := LastCol;
+ Result := True;
+ end else
+ begin
+ Result := False;
+ end;
+end;
+
+{ TPSDebugExec }
+procedure TPSDebugExec.ClearDebug;
+begin
+ inherited;
+ FDebugMode := dmRun;
+end;
+
+function TPSDebugExec.LoadData(const s: tbtstring): Boolean;
+begin
+ Result := inherited LoadData(s);
+ FDebugMode := dmRun;
+end;
+
+procedure TPSDebugExec.RunLine;
+var
+ i: Longint;
+ pt: TIfList;
+ r: PPositionData;
+begin
+ inherited RunLine;
+ if not DebugEnabled then exit;
+ if FCurrProc <> FLastProc then
+ begin
+ FLastProc := FCurrProc;
+ FCurrentDebugProc := nil;
+ for i := 0 to FDebugDataForProcs.Count -1 do
+ begin
+ if PFunctionInfo(FDebugDataForProcs[I])^.Func = FLastProc then
+ begin
+ FCurrentDebugProc := FDebugDataForProcs[I];
+ break;
+ end;
+ end;
+ end;
+ if FCurrentDebugProc <> nil then
+ begin
+ pt := PFunctionInfo(FCurrentDebugProc)^.FPositionTable;
+ for i := 0 to pt.Count -1 do
+ begin
+ r := pt[I];
+ if r^.Position = FCurrentPosition then
+ begin
+ FCurrentSourcePos := r^.SourcePosition;
+ FCurrentRow := r^.Row;
+ FCurrentCol := r^.Col;
+ FCurrentFile := r^.FileName;
+ SourceChanged;
+ break;
+ end;
+ end;
+ end else
+ begin
+ FCurrentSourcePos := 0;
+ FCurrentRow := 0;
+ FCurrentCol := 0;
+ FCurrentFile := '';
+ end;
+ while FDebugMode = dmPaused do
+ begin
+ if @FOnIdleCall <> nil then
+ begin
+ FOnIdleCall(Self);
+ end else break; // endless loop
+ end;
+end;
+
+
+procedure TPSDebugExec.SourceChanged;
+
+ function StepOverShouldPause: Boolean;
+ var
+ I: Cardinal;
+ V: PPSVariant;
+ begin
+ if (FCurrProc <> FStepOverProc) or (FCurrStackBase <> FStepOverStackBase) then
+ begin
+ { We're not inside the function being stepped, so scan the call stack to
+ see if we're inside a function called by the function being stepped }
+ I := FCurrStackBase;
+ while Longint(I) > Longint(FStepOverStackBase) do
+ begin
+ V := FStack.Items[I];
+ if (V = nil) or (V.FType <> FReturnAddressType) then
+ raise Exception.Create(RPS_ExpectedReturnAddressStackBase);
+ if (PPSVariantReturnAddress(V).Addr.ProcNo = FStepOverProc) and
+ (PPSVariantReturnAddress(V).Addr.StackBase = FStepOverStackBase) then
+ begin
+ { We are, so don't pause }
+ Result := False;
+ Exit;
+ end;
+ I := PPSVariantReturnAddress(V).Addr.StackBase;
+ end;
+ end;
+ Result := True;
+ end;
+
+begin
+ case FDebugMode of
+ dmStepInto:
+ begin
+ FDebugMode := dmPaused;
+ end;
+ dmStepOver:
+ begin
+ if StepOverShouldPause then
+ begin
+ FDebugMode := dmPaused;
+ end;
+ end;
+ end;
+ if @FOnSourceLine <> nil then
+ FOnSourceLine(Self, FCurrentFile, FCurrentSourcePos, FCurrentRow, FCurrentCol);
+end;
+
+
+procedure TPSDebugExec.Pause;
+begin
+ FDebugMode := dmPaused;
+end;
+
+procedure TPSDebugExec.Stop;
+begin
+ FDebugMode := dmRun;
+ inherited Stop;
+end;
+
+procedure TPSDebugExec.Run;
+begin
+ FDebugMode := dmRun;
+end;
+
+procedure TPSDebugExec.StepInto;
+begin
+ FDebugMode := dmStepInto;
+end;
+
+procedure TPSDebugExec.StepOver;
+begin
+ FStepOverProc := FCurrProc;
+ FStepOverStackBase := FCurrStackBase;
+ FDebugMode := dmStepOver;
+end;
+
+
+constructor TPSDebugExec.Create;
+begin
+ inherited Create;
+ FDebugEnabled := True;
+end;
+
+end.
diff --git a/Units/PascalScript/uPSDisassembly.pas b/Units/PascalScript/uPSDisassembly.pas
new file mode 100644
index 0000000..5e19d71
--- /dev/null
+++ b/Units/PascalScript/uPSDisassembly.pas
@@ -0,0 +1,499 @@
+
+
+unit uPSDisassembly;
+{$I PascalScript.inc}
+
+interface
+uses
+ uPSRuntime, uPSUtils, sysutils;
+
+function IFPS3DataToText(const Input: tbtstring; var Output: string): Boolean;
+implementation
+
+type
+ TMyPSExec = class(TPSExec)
+ function ImportProc(const Name: ShortString; proc: TIFExternalProcRec): Boolean; override;
+ end;
+
+function Debug2Str(const s: string): string;
+var
+ i: Integer;
+begin
+ result := '';
+ for i := 1 to length(s) do
+ begin
+ if (s[i] < #32) or (s[i] > #128) then
+ result := result + '\'+inttohex(ord(s[i]), 2)
+ else if s[i] = '\' then
+ result := result + '\\'
+ else
+ result := result + s[i];
+ end;
+
+end;
+
+function SpecImportProc(Sender: TObject; p: TIFExternalProcRec): Boolean; forward;
+
+function FloatToStr(Value: Extended): string;
+begin
+ try
+ Result := SysUtils.FloatToStr(Value);
+ except
+ Result := 'NaNa';
+ end;
+end;
+
+
+function IFPS3DataToText(const Input: tbtstring; var Output: string): Boolean;
+var
+ I: TMyPSExec;
+
+ procedure Writeln(const s: string);
+ begin
+ Output := Output + s + #13#10;
+ end;
+ function BT2S(P: PIFTypeRec): string;
+ var
+ i: Longint;
+ begin
+ case p.BaseType of
+ btU8: Result := 'U8';
+ btS8: Result := 'S8';
+ btU16: Result := 'U16';
+ btS16: Result := 'S16';
+ btU32: Result := 'U32';
+ btS32: Result := 'S32';
+ {$IFNDEF PS_NOINT64}bts64: Result := 'S64'; {$ENDIF}
+ btChar: Result := {$IFDEF UNICODE}'AnsiChar'{$ELSE}'Char'{$ENDIF};
+ {$IFNDEF PS_NOWIDESTRING}
+ btWideChar: Result := 'WideChar';
+ btWideString: Result := 'WideString';
+ {$ENDIF}
+ btSet: Result := 'Set';
+ btSingle: Result := 'Single';
+ btDouble: Result := 'Double';
+ btExtended: Result := 'Extended';
+ btString: Result := 'String';
+ btRecord:
+ begin
+ Result := 'Record(';
+ for i := 0 to TPSTypeRec_Record(p).FieldTypes.Count-1 do
+ begin
+ if i <> 0 then Result := Result+',';
+ Result := Result + BT2S(PIFTypeRec(TPSTypeRec_Record(p).FieldTypes[i]));
+ end;
+ Result := Result + ')';
+ end;
+ btArray: Result := 'Array of '+BT2S(TPSTypeRec_Array(p).ArrayType);
+ btResourcePointer: Result := 'ResourcePointer';
+ btPointer: Result := 'Pointer';
+ btVariant: Result := 'Variant';
+ btClass: Result := 'Class';
+ btProcPtr: Result := 'ProcPtr';
+ btStaticArray: Result := 'StaticArray['+inttostR(TPSTypeRec_StaticArray(p).Size)+'] of '+BT2S(TPSTypeRec_Array(p).ArrayType);
+ else
+ Result := 'Unknown '+inttostr(p.BaseType);
+ end;
+ end;
+ procedure WriteTypes;
+ var
+ T: Longint;
+ begin
+ Writeln('[TYPES]');
+ for T := 0 to i.FTypes.Count -1 do
+ begin
+ if PIFTypeRec(i.FTypes[t]).ExportName <> '' then
+ Writeln('Type ['+inttostr(t)+']: '+bt2s(PIFTypeRec(i.FTypes[t]))+' Export: '+PIFTypeRec(i.FTypes[t]).ExportName)
+ else
+ Writeln('Type ['+inttostr(t)+']: '+bt2s(PIFTypeRec(i.FTypes[t])));
+ end;
+ end;
+ procedure WriteVars;
+ var
+ T: Longint;
+ function FindType(p: Pointer): Cardinal;
+ var
+ T: Longint;
+ begin
+ Result := Cardinal(-1);
+ for T := 0 to i.FTypes.Count -1 do
+ begin
+ if p = i.FTypes[t] then begin
+ result := t;
+ exit;
+ end;
+ end;
+ end;
+ begin
+ Writeln('[VARS]');
+ for t := 0 to i.FGlobalVars.count -1 do
+ begin
+ Writeln('Var ['+inttostr(t)+']: '+ IntToStr(FindType(PIFVariant(i.FGlobalVars[t])^.FType)) + ' '+ bt2s(PIFVariant(i.FGlobalVars[t])^.Ftype) + ' '+ PIFVariant(i.FGlobalVars[t])^.Ftype.ExportName);
+ end;
+ end;
+
+ procedure WriteProcs;
+ var
+ t: Longint;
+ procedure WriteProc(proc: TPSProcRec);
+ var
+ sc, CP: Cardinal;
+ function ReadData(var Data; Len: Cardinal): Boolean;
+ begin
+ if CP + Len <= TPSInternalProcRec(PROC).Length then begin
+ Move(TPSInternalProcRec(Proc).Data[CP], Data, Len);
+ CP := CP + Len;
+ Result := True;
+ end else Result := False;
+ end;
+ function ReadByte(var B: Byte): Boolean;
+ begin
+ if CP < TPSInternalProcRec(Proc).Length then begin
+ b := TPSInternalProcRec(Proc).Data^[cp];
+ Inc(CP);
+ Result := True;
+ end else Result := False;
+ end;
+
+ function ReadLong(var B: Cardinal): Boolean;
+ begin
+ if CP + 3 < TPSInternalProcRec(Proc).Length then begin
+ b := Cardinal((@TPSInternalProcRec(Proc).Data[CP])^);
+ Inc(CP, 4);
+ Result := True;
+ end else Result := False;
+ end;
+ function ReadWriteVariable: string;
+ var
+ VarType: byte;
+ L1, L2: Cardinal;
+ function ReadVar(FType: Cardinal): string;
+ var
+ F: PIFTypeRec;
+ b: byte;
+ w: word;
+ l: Cardinal;
+ {$IFNDEF PS_NOINT64}ff: Int64;{$ENDIF}
+ e: extended;
+ ss: single;
+ d: double;
+ s: ansistring;
+ c: char;
+ {$IFNDEF PS_NOWIDESTRING}
+ wc: WideChar;
+ ws: WideString;
+ {$ENDIF}
+
+ begin
+ result := '';
+ F:= i.FTypes[Ftype];
+ if f = nil then exit;
+ case f.BaseType of
+ btProcPtr: begin if not ReadData(l, 4) then exit; Result := 'PROC: '+inttostr(l); end;
+ btU8: begin if not ReadData(b, 1) then exit; Result := IntToStr(tbtu8(B)); end;
+ btS8: begin if not ReadData(b, 1) then exit; Result := IntToStr(tbts8(B)); end;
+ btU16: begin if not ReadData(w, 2) then exit; Result := IntToStr(tbtu16(w)); end;
+ btS16: begin if not ReadData(w, 2) then exit; Result := IntToStr(tbts16(w)); end;
+ btU32: begin if not ReadData(l, 4) then exit; Result := IntToStr(tbtu32(l)); end;
+ btS32: begin if not ReadData(l, 4) then exit; Result := IntToStr(tbts32(l)); end;
+ {$IFNDEF PS_NOINT64}bts64: begin if not ReadData(ff, 8) then exit; Result := IntToStr(ff); end;{$ENDIF}
+ btSingle: begin if not ReadData(ss, Sizeof(tbtsingle)) then exit; Result := FloatToStr(ss); end;
+ btDouble: begin if not ReadData(d, Sizeof(tbtdouble)) then exit; Result := FloatToStr(d); end;
+ btExtended: begin if not ReadData(e, Sizeof(tbtextended)) then exit; Result := FloatToStr(e); end;
+ btPChar, btString: begin if not ReadData(l, 4) then exit; SetLength(s, l); if not readData(s[1], l) then exit; Result := MakeString(s); end;
+ btSet:
+ begin
+ SetLength(s, TPSTypeRec_Set(f).aByteSize);
+ if not ReadData(s[1], length(s)) then exit;
+ result := MakeString(s);
+
+ end;
+ btChar: begin if not ReadData(c, 1) then exit; Result := '#'+IntToStr(ord(c)); end;
+ {$IFNDEF PS_NOWIDESTRING}
+ btWideChar: begin if not ReadData(wc, 2) then exit; Result := '#'+IntToStr(ord(wc)); end;
+ btWideString: begin if not ReadData(l, 4) then exit; SetLength(ws, l); if not readData(ws[1], l*2) then exit; Result := MakeWString(ws); end;
+ {$ENDIF}
+ end;
+ end;
+ function AddressToStr(a: Cardinal): String;
+ begin
+ if a < PSAddrNegativeStackStart then
+ Result := 'GlobalVar['+inttostr(a)+']'
+ else
+ Result := 'Base['+inttostr(Longint(A-PSAddrStackStart))+']';
+ end;
+
+ begin
+ Result := '';
+ if not ReadByte(VarType) then Exit;
+ case VarType of
+ 0:
+ begin
+
+ if not ReadLong(L1) then Exit;
+ Result := AddressToStr(L1);
+ end;
+ 1:
+ begin
+ if not ReadLong(L1) then Exit;
+ Result := '['+ReadVar(l1)+']';
+ end;
+ 2:
+ begin
+ if not ReadLong(L1) then Exit;
+ if not ReadLong(L2) then Exit;
+ Result := AddressToStr(L1)+'.['+inttostr(l2)+']';
+ end;
+ 3:
+ begin
+ if not ReadLong(l1) then Exit;
+ if not ReadLong(l2) then Exit;
+ Result := AddressToStr(L1)+'.'+AddressToStr(l2);
+ end;
+ end;
+ end;
+
+ var
+ b: Byte;
+ s: string;
+ DP, D1, D2, d3, d4: Cardinal;
+
+ begin
+ CP := 0;
+ sc := 0;
+ while true do
+ begin
+ DP := cp;
+ if not ReadByte(b) then Exit;
+ case b of
+ CM_A:
+ begin
+ {$IFDEF FPC}
+ Output := Output + ' ['+inttostr(dp)+'] ASSIGN '+ ReadWriteVariable;
+ Output := Output + ', ' + ReadWriteVariable + #13#10;
+ {$ELSE}
+ Writeln(' ['+inttostr(dp)+'] ASSIGN '+ReadWriteVariable+ ', ' + ReadWriteVariable);
+ {$ENDIF}
+ end;
+ CM_CA:
+ begin
+ if not ReadByte(b) then exit;
+ case b of
+ 0: s:= '+';
+ 1: s := '-';
+ 2: s := '*';
+ 3: s:= '/';
+ 4: s:= 'MOD';
+ 5: s:= 'SHL';
+ 6: s:= 'SHR';
+ 7: s:= 'AND';
+ 8: s:= 'OR';
+ 9: s:= 'XOR';
+ else
+ exit;
+ end;
+ Writeln(' ['+inttostr(dp)+'] CALC '+ReadWriteVariable+ ' '+s+' ' + ReadWriteVariable);
+ end;
+ CM_P:
+ begin
+ Inc(sc);
+ Writeln(' ['+inttostr(dp)+'] PUSH '+ReadWriteVariable + ' // '+inttostr(sc));
+ end;
+ CM_PV:
+ begin
+ Inc(sc);
+ Writeln(' ['+inttostr(dp)+'] PUSHVAR '+ReadWriteVariable + ' // '+inttostr(sc));
+ end;
+ CM_PO:
+ begin
+ Dec(Sc);
+ Writeln(' ['+inttostr(dp)+'] POP // '+inttostr(sc));
+ end;
+ Cm_C:
+ begin
+ if not ReadLong(D1) then exit;
+ Writeln(' ['+inttostr(dp)+'] CALL '+inttostr(d1));
+ end;
+ Cm_PG:
+ begin
+ if not ReadLong(D1) then exit;
+ Writeln(' ['+inttostr(dp)+'] POP/GOTO currpos + '+IntToStr(d1)+' ['+IntToStr(CP+d1)+']');
+ end;
+ Cm_P2G:
+ begin
+ if not ReadLong(D1) then exit;
+ Writeln(' ['+inttostr(dp)+'] POP2/GOTO currpos + '+IntToStr(d1)+' ['+IntToStr(CP+d1)+']');
+ end;
+ Cm_G:
+ begin
+ if not ReadLong(D1) then exit;
+ Writeln(' ['+inttostr(dp)+'] GOTO currpos + '+IntToStr(d1)+' ['+IntToStr(CP+d1)+']');
+ end;
+ Cm_CG:
+ begin
+ if not ReadLong(D1) then exit;
+ Writeln(' ['+inttostr(dp)+'] COND_GOTO currpos + '+IntToStr(d1)+' '+ReadWriteVariable+' ['+IntToStr(CP+d1)+']');
+ end;
+ Cm_CNG:
+ begin
+ if not ReadLong(D1) then exit;
+ Writeln(' ['+inttostr(dp)+'] COND_NOT_GOTO currpos + '+IntToStr(d1)+' '+ReadWriteVariable+' ['+IntToStr(CP+d1)+']');
+ end;
+ Cm_R: Writeln(' ['+inttostr(dp)+'] RET');
+ Cm_ST:
+ begin
+ if not ReadLong(d1) or not readLong(d2) then exit;
+ Writeln(' ['+inttostr(dp)+'] SETSTACKTYPE Base['+inttostr(d1)+'] '+inttostr(d2));
+ end;
+ Cm_Pt:
+ begin
+ Inc(sc);
+ if not ReadLong(D1) then exit;
+ Writeln(' ['+inttostr(dp)+'] PUSHTYPE '+inttostr(d1) + '('+BT2S(TPSTypeRec(I.FTypes[d1]))+') // '+inttostr(sc));
+ end;
+ CM_CO:
+ begin
+ if not readByte(b) then exit;
+ case b of
+ 0: s := '>=';
+ 1: s := '<=';
+ 2: s := '>';
+ 3: s := '<';
+ 4: s := '<>';
+ 5: s := '=';
+ else exit;
+ end;
+ Writeln(' ['+inttostr(dp)+'] COMPARE into '+ReadWriteVariable+': '+ReadWriteVariable+' '+s+' '+ReadWriteVariable);
+ end;
+ Cm_cv:
+ begin
+ Writeln(' ['+inttostr(dp)+'] CALLVAR '+ReadWriteVariable);
+ end;
+ Cm_inc:
+ begin
+ Writeln(' ['+inttostr(dp)+'] INC '+ReadWriteVariable);
+ end;
+ Cm_dec:
+ begin
+ Writeln(' ['+inttostr(dp)+'] DEC '+ReadWriteVariable);
+ end;
+ cm_sp:
+ begin
+ Writeln(' ['+inttostr(dp)+'] SETPOINTER '+ReadWriteVariable+': '+ReadWriteVariable);
+ end;
+ cm_spc:
+ begin
+ Writeln(' ['+inttostr(dp)+'] SETCOPYPOINTER '+ReadWriteVariable+': '+ReadWriteVariable);
+ end;
+ cm_in:
+ begin
+ Writeln(' ['+inttostr(dp)+'] INOT '+ReadWriteVariable);
+ end;
+ cm_bn:
+ begin
+ Writeln(' ['+inttostr(dp)+'] BNOT '+ReadWriteVariable);
+ end;
+ cm_vm:
+ begin
+ Writeln(' ['+inttostr(dp)+'] MINUS '+ReadWriteVariable);
+ end;
+ cm_sf:
+ begin
+ s := ReadWriteVariable;
+ if not ReadByte(b) then exit;
+ if b = 0 then
+ Writeln(' ['+inttostr(dp)+'] SETFLAG '+s)
+ else
+ Writeln(' ['+inttostr(dp)+'] SETFLAG NOT '+s);
+ end;
+ cm_fg:
+ begin
+ if not ReadLong(D1) then exit;
+ Writeln(' ['+inttostr(dp)+'] FLAGGOTO currpos + '+IntToStr(d1)+' ['+IntToStr(CP+d1)+']');
+ end;
+ cm_puexh:
+ begin
+ if not ReadLong(D1) then exit;
+ if not ReadLong(D2) then exit;
+ if not ReadLong(D3) then exit;
+ if not ReadLong(D4) then exit;
+ Writeln(' ['+inttostr(dp)+'] PUSHEXCEPTION '+inttostr(d1)+' '+inttostr(d2)+' '+inttostr(d3)+' '+inttostr(d4));
+ end;
+ cm_poexh:
+ begin
+ if not ReadByte(b) then exit;
+ Writeln(' ['+inttostr(dp)+'] POPEXCEPTION '+inttostr(b));
+ end;
+ else
+ begin
+ Writeln(' Disasm Error');
+ Break;
+ end;
+ end;
+ end;
+ end;
+
+ begin
+ Writeln('[PROCS]');
+ for t := 0 to i.FProcs.Count -1 do
+ begin
+ if TPSProcRec(i.FProcs[t]).ClassType = TIFExternalProcRec then
+ begin
+ if TPSExternalProcRec(i.FProcs[t]). Decl = '' then
+ Writeln('Proc ['+inttostr(t)+']: External: '+TPSExternalProcRec(i.FProcs[t]).Name)
+ else
+ Writeln('Proc ['+inttostr(t)+']: External Decl: '+Debug2Str(TIFExternalProcRec(i.FProcs[t]).Decl) + ' ' + TIFExternalProcRec(i.FProcs[t]).Name);
+ end else begin
+ if TPSInternalProcRec(i.FProcs[t]).ExportName <> '' then
+ begin
+ Writeln('Proc ['+inttostr(t)+'] Export: '+TPSInternalProcRec(i.FProcs[t]).ExportName+' '+TPSInternalProcRec(i.FProcs[t]).ExportDecl);
+ end else
+ Writeln('Proc ['+inttostr(t)+']');
+ Writeproc(i.FProcs[t]);
+ end;
+ end;
+ end;
+
+begin
+ Result := False;
+ try
+ I := TMyPSExec.Create;
+ I.AddSpecialProcImport('', @SpecImportProc, nil);
+
+ if not I.LoadData(Input) then begin
+ I.Free;
+ Exit;
+ end;
+ Output := '';
+ WriteTypes;
+ WriteVars;
+ WriteProcs;
+ I.Free;
+ except
+ exit;
+ end;
+ result := true;
+end;
+
+{ TMyIFPSExec }
+
+function MyDummyProc(Caller: TPSExec; p: TIFExternalProcRec; Global, Stack: TPSStack): Boolean;
+begin
+ Result := False;
+end;
+
+
+function TMyPSExec.ImportProc(const Name: ShortString;
+ proc: TIFExternalProcRec): Boolean;
+begin
+ Proc.ProcPtr := MyDummyProc;
+ result := true;
+end;
+
+function SpecImportProc(Sender: TObject; p: TIFExternalProcRec): Boolean;
+begin
+ p.ProcPtr := MyDummyProc;
+ Result := True;
+end;
+
+end.
diff --git a/Units/PascalScript/uPSI_Dialogs.pas b/Units/PascalScript/uPSI_Dialogs.pas
new file mode 100644
index 0000000..d93f226
--- /dev/null
+++ b/Units/PascalScript/uPSI_Dialogs.pas
@@ -0,0 +1,741 @@
+unit uPSI_Dialogs;
+{
+This file has been generated by UnitParser v0.5, written by M. Knight
+and updated by NP. v/d Spek.
+Source Code from Carlo Kok has been used to implement various sections of
+UnitParser. Components of ifps3 are used in the construction of UnitParser,
+code implementing the class wrapper is taken from Carlo Kok''s conv unility
+}
+interface
+
+uses
+ SysUtils, Classes, uPSComponent, uPSCompiler, uPSRuntime;
+
+type
+(*----------------------------------------------------------------------------*)
+ TPSImport_Dialogs = class(TPSPlugin)
+ protected
+ procedure CompOnUses(CompExec: TPSScript); override;
+ procedure ExecOnUses(CompExec: TPSScript); override;
+ procedure CompileImport1(CompExec: TPSScript); override;
+ procedure CompileImport2(CompExec: TPSScript); override;
+ procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
+ procedure ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
+ end;
+
+implementation
+
+uses
+ Windows ,Messages ,CommDlg ,Graphics ,Controls ,Forms ,StdCtrls ,Dialogs;
+
+(* === compile-time registration functions === *)
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TReplaceDialog(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TFindDialog', 'TReplaceDialog') do
+ with CL.AddClassN(CL.FindClass('TFindDialog'),'TReplaceDialog') do
+ begin
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TFindDialog(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TCommonDialog', 'TFindDialog') do
+ with CL.AddClassN(CL.FindClass('TCommonDialog'),'TFindDialog') do
+ begin
+ RegisterMethod('Procedure CloseDialog');
+ RegisterProperty('Left', 'Integer', iptrw);
+ RegisterProperty('Position', 'TPoint', iptrw);
+ RegisterProperty('Top', 'Integer', iptrw);
+ RegisterProperty('FindText', 'string', iptrw);
+ RegisterProperty('Options', 'TFindOptions', iptrw);
+ RegisterProperty('OnFind', 'TNotifyEvent', iptrw);
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TPrintDialog(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TCommonDialog', 'TPrintDialog') do
+ with CL.AddClassN(CL.FindClass('TCommonDialog'),'TPrintDialog') do
+ begin
+ RegisterProperty('Collate', 'Boolean', iptrw);
+ RegisterProperty('Copies', 'Integer', iptrw);
+ RegisterProperty('FromPage', 'Integer', iptrw);
+ RegisterProperty('MinPage', 'Integer', iptrw);
+ RegisterProperty('MaxPage', 'Integer', iptrw);
+ RegisterProperty('Options', 'TPrintDialogOptions', iptrw);
+ RegisterProperty('PrintToFile', 'Boolean', iptrw);
+ RegisterProperty('PrintRange', 'TPrintRange', iptrw);
+ RegisterProperty('ToPage', 'Integer', iptrw);
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TPrinterSetupDialog(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TCommonDialog', 'TPrinterSetupDialog') do
+ with CL.AddClassN(CL.FindClass('TCommonDialog'),'TPrinterSetupDialog') do
+ begin
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TFontDialog(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TCommonDialog', 'TFontDialog') do
+ with CL.AddClassN(CL.FindClass('TCommonDialog'),'TFontDialog') do
+ begin
+ RegisterProperty('Font', 'TFont', iptrw);
+ RegisterProperty('Device', 'TFontDialogDevice', iptrw);
+ RegisterProperty('MinFontSize', 'Integer', iptrw);
+ RegisterProperty('MaxFontSize', 'Integer', iptrw);
+ RegisterProperty('Options', 'TFontDialogOptions', iptrw);
+ RegisterProperty('OnApply', 'TFDApplyEvent', iptrw);
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TColorDialog(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TCommonDialog', 'TColorDialog') do
+ with CL.AddClassN(CL.FindClass('TCommonDialog'),'TColorDialog') do
+ begin
+ RegisterProperty('Color', 'TColor', iptrw);
+ RegisterProperty('CustomColors', 'TStrings', iptrw);
+ RegisterProperty('Options', 'TColorDialogOptions', iptrw);
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TSaveDialog(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TOpenDialog', 'TSaveDialog') do
+ with CL.AddClassN(CL.FindClass('TOpenDialog'),'TSaveDialog') do
+ begin
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TOpenDialog(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TCommonDialog', 'TOpenDialog') do
+ with CL.AddClassN(CL.FindClass('TCommonDialog'),'TOpenDialog') do
+ begin
+ RegisterProperty('FileEditStyle', 'TFileEditStyle', iptrw);
+ RegisterProperty('Files', 'TStrings', iptr);
+ RegisterProperty('HistoryList', 'TStrings', iptrw);
+ RegisterProperty('DefaultExt', 'string', iptrw);
+ RegisterProperty('FileName', 'TFileName', iptrw);
+ RegisterProperty('Filter', 'string', iptrw);
+ RegisterProperty('FilterIndex', 'Integer', iptrw);
+ RegisterProperty('InitialDir', 'string', iptrw);
+ RegisterProperty('Options', 'TOpenOptions', iptrw);
+ RegisterProperty('Title', 'string', iptrw);
+ RegisterProperty('OnCanClose', 'TCloseQueryEvent', iptrw);
+ RegisterProperty('OnFolderChange', 'TNotifyEvent', iptrw);
+ RegisterProperty('OnSelectionChange', 'TNotifyEvent', iptrw);
+ RegisterProperty('OnTypeChange', 'TNotifyEvent', iptrw);
+ RegisterProperty('OnIncludeItem', 'TIncludeItemEvent', iptrw);
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TCommonDialog(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TComponent', 'TCommonDialog') do
+ with CL.AddClassN(CL.FindClass('TComponent'),'TCommonDialog') do
+ begin
+ RegisterProperty('Handle', 'HWnd', iptr);
+ RegisterProperty('Ctl3D', 'Boolean', iptrw);
+ RegisterProperty('HelpContext', 'THelpContext', iptrw);
+ RegisterProperty('OnClose', 'TNotifyEvent', iptrw);
+ RegisterProperty('OnShow', 'TNotifyEvent', iptrw);
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_Dialogs(CL: TPSPascalCompiler);
+begin
+ CL.AddConstantN('MaxCustomColors','LongInt').SetInt( 16);
+ SIRegister_TCommonDialog(CL);
+ CL.AddTypeS('TOpenOption', '( ofReadOnly, ofOverwritePrompt, ofHideReadOnly, '
+ +'ofNoChangeDir, ofShowHelp, ofNoValidate, ofAllowMultiSelect, ofExtensionDi'
+ +'fferent, ofPathMustExist, ofFileMustExist, ofCreatePrompt, ofShareAware, o'
+ +'fNoReadOnlyReturn, ofNoTestFileCreate, ofNoNetworkButton, ofNoLongNames, o'
+ +'fOldStyleDialog, ofNoDereferenceLinks, ofEnableIncludeNotify, ofEnableSizi'
+ +'ng )');
+ CL.AddTypeS('TOpenOptions', 'set of TOpenOption');
+ CL.AddTypeS('TFileEditStyle', '( fsEdit, fsComboBox )');
+ CL.AddTypeS('TIncludeItemEvent', 'Procedure ( const OFN : TOFNotifyEx; var In'
+ +'clude : Boolean)');
+ SIRegister_TOpenDialog(CL);
+ SIRegister_TSaveDialog(CL);
+ CL.AddTypeS('TColorDialogOption', '( cdFullOpen, cdPreventFullOpen, cdShowHel'
+ +'p, cdSolidColor, cdAnyColor )');
+ CL.AddTypeS('TColorDialogOptions', 'set of TColorDialogOption');
+ SIRegister_TColorDialog(CL);
+ CL.AddTypeS('TFontDialogOption', '( fdAnsiOnly, fdTrueTypeOnly, fdEffects, fd'
+ +'FixedPitchOnly, fdForceFontExist, fdNoFaceSel, fdNoOEMFonts, fdNoSimulatio'
+ +'ns, fdNoSizeSel, fdNoStyleSel, fdNoVectorFonts, fdShowHelp, fdWysiwyg, fdL'
+ +'imitSize, fdScalableOnly, fdApplyButton )');
+ CL.AddTypeS('TFontDialogOptions', 'set of TFontDialogOption');
+ CL.AddTypeS('TFontDialogDevice', '( fdScreen, fdPrinter, fdBoth )');
+ CL.AddTypeS('TFDApplyEvent', 'Procedure ( Sender : TObject; Wnd : HWND)');
+ SIRegister_TFontDialog(CL);
+ SIRegister_TPrinterSetupDialog(CL);
+ CL.AddTypeS('TPrintRange', '( prAllPages, prSelection, prPageNums )');
+ CL.AddTypeS('TPrintDialogOption', '( poPrintToFile, poPageNums, poSelection, '
+ +'poWarning, poHelp, poDisablePrintToFile )');
+ CL.AddTypeS('TPrintDialogOptions', 'set of TPrintDialogOption');
+ SIRegister_TPrintDialog(CL);
+ CL.AddTypeS('TFindOption', '( frDown, frFindNext, frHideMatchCase, frHideWhol'
+ +'eWord, frHideUpDown, frMatchCase, frDisableMatchCase, frDisableUpDown, frD'
+ +'isableWholeWord, frReplace, frReplaceAll, frWholeWord, frShowHelp )');
+ CL.AddTypeS('TFindOptions', 'set of TFindOption');
+ SIRegister_TFindDialog(CL);
+ SIRegister_TReplaceDialog(CL);
+ CL.AddTypeS('TMsgDlgType', '( mtWarning, mtError, mtInformation, mtConfirmati'
+ +'on, mtCustom )');
+ CL.AddTypeS('TMsgDlgBtn', '( mbYes, mbNo, mbOK, mbCancel, mbAbort, mbRetry, m'
+ +'bIgnore, mbAll, mbNoToAll, mbYesToAll, mbHelp )');
+ CL.AddTypeS('TMsgDlgButtons', 'set of TMsgDlgBtn');
+ CL.AddConstantN('mbYesNoCancel','LongInt').Value.ts32 := ord(mbYes) or ord(mbNo) or ord(mbCancel);
+ CL.AddConstantN('mbOKCancel','LongInt').Value.ts32 := ord(mbOK) or ord(mbCancel);
+ CL.AddConstantN('mbAbortRetryIgnore','LongInt').Value.ts32 := ord(mbAbort) or ord(mbRetry) or ord(mbIgnore);
+ CL.AddDelphiFunction('Function CreateMessageDialog( const Msg : string; DlgType : TMsgDlgType; Buttons : TMsgDlgButtons) : TForm');
+ CL.AddDelphiFunction('Function MessageDlg( const Msg : string; DlgType : TMsgDlgType; Buttons : TMsgDlgButtons; HelpCtx : Longint) : Integer');
+ CL.AddDelphiFunction('Function MessageDlgPos( const Msg : string; DlgType : TMsgDlgType; Buttons : TMsgDlgButtons; HelpCtx : Longint; X, Y : Integer) : Integer');
+ CL.AddDelphiFunction('Function MessageDlgPosHelp( const Msg : string; DlgType : TMsgDlgType; Buttons : TMsgDlgButtons; HelpCtx : Longint; X, Y : Integer; const HelpFileName : string) : Integer');
+ CL.AddDelphiFunction('Procedure ShowMessage( const Msg : string)');
+ CL.AddDelphiFunction('Procedure ShowMessagePos( const Msg : string; X, Y : Integer)');
+ CL.AddDelphiFunction('Function InputBox( const ACaption, APrompt, ADefault : string) : string');
+ CL.AddDelphiFunction('Function InputQuery( const ACaption, APrompt : string; var Value : string) : Boolean');
+end;
+
+(* === run-time registration functions === *)
+(*----------------------------------------------------------------------------*)
+procedure TFindDialogOnFind_W(Self: TFindDialog; const T: TNotifyEvent);
+begin Self.OnFind := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TFindDialogOnFind_R(Self: TFindDialog; var T: TNotifyEvent);
+begin T := Self.OnFind; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TFindDialogOptions_W(Self: TFindDialog; const T: TFindOptions);
+begin Self.Options := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TFindDialogOptions_R(Self: TFindDialog; var T: TFindOptions);
+begin T := Self.Options; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TFindDialogFindText_W(Self: TFindDialog; const T: string);
+begin Self.FindText := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TFindDialogFindText_R(Self: TFindDialog; var T: string);
+begin T := Self.FindText; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TFindDialogTop_W(Self: TFindDialog; const T: Integer);
+begin Self.Top := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TFindDialogTop_R(Self: TFindDialog; var T: Integer);
+begin T := Self.Top; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TFindDialogPosition_W(Self: TFindDialog; const T: TPoint);
+begin Self.Position := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TFindDialogPosition_R(Self: TFindDialog; var T: TPoint);
+begin T := Self.Position; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TFindDialogLeft_W(Self: TFindDialog; const T: Integer);
+begin Self.Left := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TFindDialogLeft_R(Self: TFindDialog; var T: Integer);
+begin T := Self.Left; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TPrintDialogToPage_W(Self: TPrintDialog; const T: Integer);
+begin Self.ToPage := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TPrintDialogToPage_R(Self: TPrintDialog; var T: Integer);
+begin T := Self.ToPage; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TPrintDialogPrintRange_W(Self: TPrintDialog; const T: TPrintRange);
+begin Self.PrintRange := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TPrintDialogPrintRange_R(Self: TPrintDialog; var T: TPrintRange);
+begin T := Self.PrintRange; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TPrintDialogPrintToFile_W(Self: TPrintDialog; const T: Boolean);
+begin Self.PrintToFile := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TPrintDialogPrintToFile_R(Self: TPrintDialog; var T: Boolean);
+begin T := Self.PrintToFile; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TPrintDialogOptions_W(Self: TPrintDialog; const T: TPrintDialogOptions);
+begin Self.Options := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TPrintDialogOptions_R(Self: TPrintDialog; var T: TPrintDialogOptions);
+begin T := Self.Options; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TPrintDialogMaxPage_W(Self: TPrintDialog; const T: Integer);
+begin Self.MaxPage := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TPrintDialogMaxPage_R(Self: TPrintDialog; var T: Integer);
+begin T := Self.MaxPage; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TPrintDialogMinPage_W(Self: TPrintDialog; const T: Integer);
+begin Self.MinPage := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TPrintDialogMinPage_R(Self: TPrintDialog; var T: Integer);
+begin T := Self.MinPage; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TPrintDialogFromPage_W(Self: TPrintDialog; const T: Integer);
+begin Self.FromPage := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TPrintDialogFromPage_R(Self: TPrintDialog; var T: Integer);
+begin T := Self.FromPage; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TPrintDialogCopies_W(Self: TPrintDialog; const T: Integer);
+begin Self.Copies := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TPrintDialogCopies_R(Self: TPrintDialog; var T: Integer);
+begin T := Self.Copies; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TPrintDialogCollate_W(Self: TPrintDialog; const T: Boolean);
+begin Self.Collate := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TPrintDialogCollate_R(Self: TPrintDialog; var T: Boolean);
+begin T := Self.Collate; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TFontDialogOnApply_W(Self: TFontDialog; const T: TFDApplyEvent);
+begin Self.OnApply := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TFontDialogOnApply_R(Self: TFontDialog; var T: TFDApplyEvent);
+begin T := Self.OnApply; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TFontDialogOptions_W(Self: TFontDialog; const T: TFontDialogOptions);
+begin Self.Options := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TFontDialogOptions_R(Self: TFontDialog; var T: TFontDialogOptions);
+begin T := Self.Options; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TFontDialogMaxFontSize_W(Self: TFontDialog; const T: Integer);
+begin Self.MaxFontSize := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TFontDialogMaxFontSize_R(Self: TFontDialog; var T: Integer);
+begin T := Self.MaxFontSize; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TFontDialogMinFontSize_W(Self: TFontDialog; const T: Integer);
+begin Self.MinFontSize := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TFontDialogMinFontSize_R(Self: TFontDialog; var T: Integer);
+begin T := Self.MinFontSize; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TFontDialogDevice_W(Self: TFontDialog; const T: TFontDialogDevice);
+begin Self.Device := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TFontDialogDevice_R(Self: TFontDialog; var T: TFontDialogDevice);
+begin T := Self.Device; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TFontDialogFont_W(Self: TFontDialog; const T: TFont);
+begin Self.Font := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TFontDialogFont_R(Self: TFontDialog; var T: TFont);
+begin T := Self.Font; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TColorDialogOptions_W(Self: TColorDialog; const T: TColorDialogOptions);
+begin Self.Options := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TColorDialogOptions_R(Self: TColorDialog; var T: TColorDialogOptions);
+begin T := Self.Options; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TColorDialogCustomColors_W(Self: TColorDialog; const T: TStrings);
+begin Self.CustomColors := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TColorDialogCustomColors_R(Self: TColorDialog; var T: TStrings);
+begin T := Self.CustomColors; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TColorDialogColor_W(Self: TColorDialog; const T: TColor);
+begin Self.Color := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TColorDialogColor_R(Self: TColorDialog; var T: TColor);
+begin T := Self.Color; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TOpenDialogOnIncludeItem_W(Self: TOpenDialog; const T: TIncludeItemEvent);
+begin Self.OnIncludeItem := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TOpenDialogOnIncludeItem_R(Self: TOpenDialog; var T: TIncludeItemEvent);
+begin T := Self.OnIncludeItem; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TOpenDialogOnTypeChange_W(Self: TOpenDialog; const T: TNotifyEvent);
+begin Self.OnTypeChange := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TOpenDialogOnTypeChange_R(Self: TOpenDialog; var T: TNotifyEvent);
+begin T := Self.OnTypeChange; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TOpenDialogOnSelectionChange_W(Self: TOpenDialog; const T: TNotifyEvent);
+begin Self.OnSelectionChange := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TOpenDialogOnSelectionChange_R(Self: TOpenDialog; var T: TNotifyEvent);
+begin T := Self.OnSelectionChange; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TOpenDialogOnFolderChange_W(Self: TOpenDialog; const T: TNotifyEvent);
+begin Self.OnFolderChange := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TOpenDialogOnFolderChange_R(Self: TOpenDialog; var T: TNotifyEvent);
+begin T := Self.OnFolderChange; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TOpenDialogOnCanClose_W(Self: TOpenDialog; const T: TCloseQueryEvent);
+begin Self.OnCanClose := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TOpenDialogOnCanClose_R(Self: TOpenDialog; var T: TCloseQueryEvent);
+begin T := Self.OnCanClose; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TOpenDialogTitle_W(Self: TOpenDialog; const T: string);
+begin Self.Title := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TOpenDialogTitle_R(Self: TOpenDialog; var T: string);
+begin T := Self.Title; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TOpenDialogOptions_W(Self: TOpenDialog; const T: TOpenOptions);
+begin Self.Options := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TOpenDialogOptions_R(Self: TOpenDialog; var T: TOpenOptions);
+begin T := Self.Options; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TOpenDialogInitialDir_W(Self: TOpenDialog; const T: string);
+begin Self.InitialDir := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TOpenDialogInitialDir_R(Self: TOpenDialog; var T: string);
+begin T := Self.InitialDir; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TOpenDialogFilterIndex_W(Self: TOpenDialog; const T: Integer);
+begin Self.FilterIndex := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TOpenDialogFilterIndex_R(Self: TOpenDialog; var T: Integer);
+begin T := Self.FilterIndex; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TOpenDialogFilter_W(Self: TOpenDialog; const T: string);
+begin Self.Filter := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TOpenDialogFilter_R(Self: TOpenDialog; var T: string);
+begin T := Self.Filter; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TOpenDialogFileName_W(Self: TOpenDialog; const T: TFileName);
+begin Self.FileName := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TOpenDialogFileName_R(Self: TOpenDialog; var T: TFileName);
+begin T := Self.FileName; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TOpenDialogDefaultExt_W(Self: TOpenDialog; const T: string);
+begin Self.DefaultExt := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TOpenDialogDefaultExt_R(Self: TOpenDialog; var T: string);
+begin T := Self.DefaultExt; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TOpenDialogHistoryList_W(Self: TOpenDialog; const T: TStrings);
+begin Self.HistoryList := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TOpenDialogHistoryList_R(Self: TOpenDialog; var T: TStrings);
+begin T := Self.HistoryList; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TOpenDialogFiles_R(Self: TOpenDialog; var T: TStrings);
+begin T := Self.Files; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TOpenDialogFileEditStyle_W(Self: TOpenDialog; const T: TFileEditStyle);
+begin Self.FileEditStyle := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TOpenDialogFileEditStyle_R(Self: TOpenDialog; var T: TFileEditStyle);
+begin T := Self.FileEditStyle; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TCommonDialogOnShow_W(Self: TCommonDialog; const T: TNotifyEvent);
+begin Self.OnShow := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TCommonDialogOnShow_R(Self: TCommonDialog; var T: TNotifyEvent);
+begin T := Self.OnShow; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TCommonDialogOnClose_W(Self: TCommonDialog; const T: TNotifyEvent);
+begin Self.OnClose := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TCommonDialogOnClose_R(Self: TCommonDialog; var T: TNotifyEvent);
+begin T := Self.OnClose; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TCommonDialogHelpContext_W(Self: TCommonDialog; const T: THelpContext);
+begin Self.HelpContext := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TCommonDialogHelpContext_R(Self: TCommonDialog; var T: THelpContext);
+begin T := Self.HelpContext; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TCommonDialogCtl3D_W(Self: TCommonDialog; const T: Boolean);
+begin Self.Ctl3D := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TCommonDialogCtl3D_R(Self: TCommonDialog; var T: Boolean);
+begin T := Self.Ctl3D; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TCommonDialogHandle_R(Self: TCommonDialog; var T: HWnd);
+begin T := Self.Handle; end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_Dialogs_Routines(S: TPSExec);
+begin
+ S.RegisterDelphiFunction(@CreateMessageDialog, 'CreateMessageDialog', cdRegister);
+ S.RegisterDelphiFunction(@MessageDlg, 'MessageDlg', cdRegister);
+ S.RegisterDelphiFunction(@MessageDlgPos, 'MessageDlgPos', cdRegister);
+ S.RegisterDelphiFunction(@MessageDlgPosHelp, 'MessageDlgPosHelp', cdRegister);
+ S.RegisterDelphiFunction(@ShowMessage, 'ShowMessage', cdRegister);
+ S.RegisterDelphiFunction(@ShowMessagePos, 'ShowMessagePos', cdRegister);
+ S.RegisterDelphiFunction(@InputBox, 'InputBox', cdRegister);
+ S.RegisterDelphiFunction(@InputQuery, 'InputQuery', cdRegister);
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TReplaceDialog(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TReplaceDialog) do
+ begin
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TFindDialog(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TFindDialog) do
+ begin
+ RegisterMethod(@TFindDialog.CloseDialog, 'CloseDialog');
+ RegisterPropertyHelper(@TFindDialogLeft_R,@TFindDialogLeft_W,'Left');
+ RegisterPropertyHelper(@TFindDialogPosition_R,@TFindDialogPosition_W,'Position');
+ RegisterPropertyHelper(@TFindDialogTop_R,@TFindDialogTop_W,'Top');
+ RegisterPropertyHelper(@TFindDialogFindText_R,@TFindDialogFindText_W,'FindText');
+ RegisterPropertyHelper(@TFindDialogOptions_R,@TFindDialogOptions_W,'Options');
+ RegisterPropertyHelper(@TFindDialogOnFind_R,@TFindDialogOnFind_W,'OnFind');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TPrintDialog(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TPrintDialog) do
+ begin
+ RegisterPropertyHelper(@TPrintDialogCollate_R,@TPrintDialogCollate_W,'Collate');
+ RegisterPropertyHelper(@TPrintDialogCopies_R,@TPrintDialogCopies_W,'Copies');
+ RegisterPropertyHelper(@TPrintDialogFromPage_R,@TPrintDialogFromPage_W,'FromPage');
+ RegisterPropertyHelper(@TPrintDialogMinPage_R,@TPrintDialogMinPage_W,'MinPage');
+ RegisterPropertyHelper(@TPrintDialogMaxPage_R,@TPrintDialogMaxPage_W,'MaxPage');
+ RegisterPropertyHelper(@TPrintDialogOptions_R,@TPrintDialogOptions_W,'Options');
+ RegisterPropertyHelper(@TPrintDialogPrintToFile_R,@TPrintDialogPrintToFile_W,'PrintToFile');
+ RegisterPropertyHelper(@TPrintDialogPrintRange_R,@TPrintDialogPrintRange_W,'PrintRange');
+ RegisterPropertyHelper(@TPrintDialogToPage_R,@TPrintDialogToPage_W,'ToPage');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TPrinterSetupDialog(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TPrinterSetupDialog) do
+ begin
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TFontDialog(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TFontDialog) do
+ begin
+ RegisterPropertyHelper(@TFontDialogFont_R,@TFontDialogFont_W,'Font');
+ RegisterPropertyHelper(@TFontDialogDevice_R,@TFontDialogDevice_W,'Device');
+ RegisterPropertyHelper(@TFontDialogMinFontSize_R,@TFontDialogMinFontSize_W,'MinFontSize');
+ RegisterPropertyHelper(@TFontDialogMaxFontSize_R,@TFontDialogMaxFontSize_W,'MaxFontSize');
+ RegisterPropertyHelper(@TFontDialogOptions_R,@TFontDialogOptions_W,'Options');
+ RegisterPropertyHelper(@TFontDialogOnApply_R,@TFontDialogOnApply_W,'OnApply');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TColorDialog(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TColorDialog) do
+ begin
+ RegisterPropertyHelper(@TColorDialogColor_R,@TColorDialogColor_W,'Color');
+ RegisterPropertyHelper(@TColorDialogCustomColors_R,@TColorDialogCustomColors_W,'CustomColors');
+ RegisterPropertyHelper(@TColorDialogOptions_R,@TColorDialogOptions_W,'Options');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TSaveDialog(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TSaveDialog) do
+ begin
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TOpenDialog(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TOpenDialog) do
+ begin
+ RegisterPropertyHelper(@TOpenDialogFileEditStyle_R,@TOpenDialogFileEditStyle_W,'FileEditStyle');
+ RegisterPropertyHelper(@TOpenDialogFiles_R,nil,'Files');
+ RegisterPropertyHelper(@TOpenDialogHistoryList_R,@TOpenDialogHistoryList_W,'HistoryList');
+ RegisterPropertyHelper(@TOpenDialogDefaultExt_R,@TOpenDialogDefaultExt_W,'DefaultExt');
+ RegisterPropertyHelper(@TOpenDialogFileName_R,@TOpenDialogFileName_W,'FileName');
+ RegisterPropertyHelper(@TOpenDialogFilter_R,@TOpenDialogFilter_W,'Filter');
+ RegisterPropertyHelper(@TOpenDialogFilterIndex_R,@TOpenDialogFilterIndex_W,'FilterIndex');
+ RegisterPropertyHelper(@TOpenDialogInitialDir_R,@TOpenDialogInitialDir_W,'InitialDir');
+ RegisterPropertyHelper(@TOpenDialogOptions_R,@TOpenDialogOptions_W,'Options');
+ RegisterPropertyHelper(@TOpenDialogTitle_R,@TOpenDialogTitle_W,'Title');
+ RegisterPropertyHelper(@TOpenDialogOnCanClose_R,@TOpenDialogOnCanClose_W,'OnCanClose');
+ RegisterPropertyHelper(@TOpenDialogOnFolderChange_R,@TOpenDialogOnFolderChange_W,'OnFolderChange');
+ RegisterPropertyHelper(@TOpenDialogOnSelectionChange_R,@TOpenDialogOnSelectionChange_W,'OnSelectionChange');
+ RegisterPropertyHelper(@TOpenDialogOnTypeChange_R,@TOpenDialogOnTypeChange_W,'OnTypeChange');
+ RegisterPropertyHelper(@TOpenDialogOnIncludeItem_R,@TOpenDialogOnIncludeItem_W,'OnIncludeItem');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TCommonDialog(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TCommonDialog) do
+ begin
+ RegisterPropertyHelper(@TCommonDialogHandle_R,nil,'Handle');
+ RegisterPropertyHelper(@TCommonDialogCtl3D_R,@TCommonDialogCtl3D_W,'Ctl3D');
+ RegisterPropertyHelper(@TCommonDialogHelpContext_R,@TCommonDialogHelpContext_W,'HelpContext');
+ RegisterPropertyHelper(@TCommonDialogOnClose_R,@TCommonDialogOnClose_W,'OnClose');
+ RegisterPropertyHelper(@TCommonDialogOnShow_R,@TCommonDialogOnShow_W,'OnShow');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_Dialogs(CL: TPSRuntimeClassImporter);
+begin
+ RIRegister_TCommonDialog(CL);
+ RIRegister_TOpenDialog(CL);
+ RIRegister_TSaveDialog(CL);
+ RIRegister_TColorDialog(CL);
+ RIRegister_TFontDialog(CL);
+ RIRegister_TPrinterSetupDialog(CL);
+ RIRegister_TPrintDialog(CL);
+ RIRegister_TFindDialog(CL);
+ RIRegister_TReplaceDialog(CL);
+end;
+
+
+
+{ TPSImport_Dialogs }
+(*----------------------------------------------------------------------------*)
+procedure TPSImport_Dialogs.CompOnUses(CompExec: TPSScript);
+begin
+ { nothing }
+end;
+(*----------------------------------------------------------------------------*)
+procedure TPSImport_Dialogs.ExecOnUses(CompExec: TPSScript);
+begin
+ { nothing }
+end;
+(*----------------------------------------------------------------------------*)
+procedure TPSImport_Dialogs.CompileImport1(CompExec: TPSScript);
+begin
+ SIRegister_Dialogs(CompExec.Comp);
+end;
+(*----------------------------------------------------------------------------*)
+procedure TPSImport_Dialogs.CompileImport2(CompExec: TPSScript);
+begin
+ { nothing }
+end;
+(*----------------------------------------------------------------------------*)
+procedure TPSImport_Dialogs.ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter);
+begin
+ RIRegister_Dialogs(ri);
+ RIRegister_Dialogs_Routines(CompExec.Exec); // comment it if no routines
+end;
+(*----------------------------------------------------------------------------*)
+procedure TPSImport_Dialogs.ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter);
+begin
+ { nothing }
+end;
+
+end.
diff --git a/Units/PascalScript/uPSI_IBX.pas b/Units/PascalScript/uPSI_IBX.pas
new file mode 100644
index 0000000..7d1836a
--- /dev/null
+++ b/Units/PascalScript/uPSI_IBX.pas
@@ -0,0 +1,2153 @@
+unit uPSI_IBX;
+{
+This file has been generated by UnitParser v0.4, written by M. Knight.
+Source Code from Carlo Kok has been used to implement various sections of
+UnitParser. Components of ifps3 are used in the construction of UnitParser,
+code implementing the class wrapper is taken from Carlo Kok''s conv unility
+}
+
+interface
+
+uses
+ SysUtils, Classes, uPSComponent, uPSCompiler, uPSRuntime;
+
+type
+ TPSImport_IBX = class(TPSPlugin)
+ protected
+ procedure CompOnUses(CompExec: TPSScript); override;
+ procedure ExecOnUses(CompExec: TPSScript); override;
+ procedure CompileImport1(CompExec: TPSScript); override;
+ procedure CompileImport2(CompExec: TPSScript); override;
+ procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
+ procedure ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
+ end;
+
+
+
+implementation
+
+
+uses
+ WINDOWS
+ ,CONTROLS
+ ,IBEXTERNALS
+ ,IB
+ ,IBDatabase
+ ,IBHEADER
+ ,STDVCL
+ ,IBSQL
+ ,DB
+ ,IBUTILS
+ ,IBBLOB
+ ,IBCustomDataSet
+ ,IBTable
+ ,IBQuery
+ ;
+
+(* === compile-time registration functions === *)
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TIBDATASET(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TIBCUSTOMDATASET', 'TIBDATASET') do
+ with CL.AddClassN(CL.FindClass('TIBCUSTOMDATASET'),'TIBDATASET') do
+ begin
+ RegisterMethod('Procedure PREPARE');
+ RegisterMethod('Procedure UNPREPARE');
+ RegisterMethod('Procedure BATCHINPUT( INPUTOBJECT : TIBBATCHINPUT)');
+ RegisterMethod('Procedure BATCHOUTPUT( OUTPUTOBJECT : TIBBATCHOUTPUT)');
+ RegisterMethod('Procedure EXECSQL');
+ RegisterMethod('Function PARAMBYNAME( IDX : STRING) : TIBXSQLVAR');
+ RegisterProperty('PREPARED', 'BOOLEAN', iptr);
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TIBCUSTOMDATASET(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TDATASET', 'TIBCUSTOMDATASET') do
+ with CL.AddClassN(CL.FindClass('TDATASET'),'TIBCUSTOMDATASET') do
+ begin
+ RegisterMethod('Procedure APPLYUPDATES');
+ RegisterMethod('Function CACHEDUPDATESTATUS : TCACHEDUPDATESTATUS');
+ RegisterMethod('Procedure CANCELUPDATES');
+ RegisterMethod('Procedure FETCHALL');
+ RegisterMethod('Function LOCATENEXT( const KEYFIELDS : STRING; const KEYVALUES : VARIANT; OPTIONS : TLOCATEOPTIONS) : BOOLEAN');
+// RegisterMethod('Function LOCATE( const KEYFIELDS : STRING; const KEYVALUES : VARIANT; OPTIONS : TLOCATEOPTIONS) : BOOLEAN');
+ RegisterMethod('Procedure RECORDMODIFIED( VALUE : BOOLEAN)');
+ RegisterMethod('Procedure REVERTRECORD');
+ RegisterMethod('Procedure UNDELETE');
+ RegisterMethod('Function CURRENT : TIBXSQLDA');
+ RegisterMethod('Function SQLTYPE : TIBSQLTYPES');
+ RegisterProperty('DBHANDLE', 'PISC_DB_HANDLE', iptr);
+ RegisterProperty('TRHANDLE', 'PISC_TR_HANDLE', iptr);
+ RegisterProperty('UPDATEOBJECT', 'TIBDATASETUPDATEOBJECT', iptrw);
+ RegisterProperty('UPDATESPENDING', 'BOOLEAN', iptr);
+ RegisterProperty('UPDATERECORDTYPES', 'TIBUPDATERECORDTYPES', iptrw);
+ RegisterProperty('ROWSAFFECTED', 'INTEGER', iptr);
+ RegisterProperty('PLAN', 'STRING', iptr);
+ RegisterProperty('DATABASE', 'TIBDATABASE', iptrw);
+ RegisterProperty('TRANSACTION', 'TIBTRANSACTION', iptrw);
+ RegisterProperty('FORCEDREFRESH', 'BOOLEAN', iptrw);
+ RegisterProperty('ONUPDATEERROR', 'TIBUPDATEERROREVENT', iptrw);
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TIBGENERATORFIELD(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TPERSISTENT', 'TIBGENERATORFIELD') do
+ with CL.AddClassN(CL.FindClass('TPERSISTENT'),'TIBGENERATORFIELD') do
+ begin
+ RegisterMethod('Constructor CREATE( ADATASET : TIBCUSTOMDATASET)');
+ RegisterMethod('Function VALUENAME : STRING');
+ RegisterMethod('Procedure APPLY');
+ RegisterProperty('FIELD', 'STRING', iptrw);
+ RegisterProperty('GENERATOR', 'STRING', iptrw);
+ RegisterProperty('INCREMENTBY', 'INTEGER', iptrw);
+ RegisterProperty('APPLYEVENT', 'TIBGENERATORAPPLYEVENT', iptrw);
+ end;
+end;
+
+(* === compile-time registration functions === *)
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TIBBASE(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TOBJECT', 'TIBBASE') do
+ with CL.AddClassN(CL.FindClass('TOBJECT'),'TIBBASE') do
+ begin
+ RegisterMethod('Constructor CREATE( AOWNER : TOBJECT)');
+ RegisterMethod('Procedure CHECKDATABASE');
+ RegisterMethod('Procedure CHECKTRANSACTION');
+ RegisterProperty('BEFOREDATABASEDISCONNECT', 'TNOTIFYEVENT', iptrw);
+ RegisterProperty('AFTERDATABASEDISCONNECT', 'TNOTIFYEVENT', iptrw);
+ RegisterProperty('ONDATABASEFREE', 'TNOTIFYEVENT', iptrw);
+ RegisterProperty('BEFORETRANSACTIONEND', 'TNOTIFYEVENT', iptrw);
+ RegisterProperty('AFTERTRANSACTIONEND', 'TNOTIFYEVENT', iptrw);
+ RegisterProperty('ONTRANSACTIONFREE', 'TNOTIFYEVENT', iptrw);
+ RegisterProperty('DATABASE', 'TIBDATABASE', iptrw);
+ RegisterProperty('DBHANDLE', 'PISC_DB_HANDLE', iptr);
+ RegisterProperty('OWNER', 'TOBJECT', iptr);
+ RegisterProperty('TRHANDLE', 'PISC_TR_HANDLE', iptr);
+ RegisterProperty('TRANSACTION', 'TIBTRANSACTION', iptrw);
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TIBTRANSACTION(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TCOMPONENT', 'TIBTRANSACTION') do
+ with CL.AddClassN(CL.FindClass('TCOMPONENT'),'TIBTRANSACTION') do
+ begin
+ RegisterMethod('Function CALL( ERRCODE : ISC_STATUS; RAISEERROR : BOOLEAN) : ISC_STATUS');
+ RegisterMethod('Procedure COMMIT');
+ RegisterMethod('Procedure COMMITRETAINING');
+ RegisterMethod('Procedure ROLLBACK');
+ RegisterMethod('Procedure ROLLBACKRETAINING');
+ RegisterMethod('Procedure STARTTRANSACTION');
+ RegisterMethod('Procedure CHECKINTRANSACTION');
+ RegisterMethod('Procedure CHECKNOTINTRANSACTION');
+ RegisterMethod('Procedure CHECKAUTOSTOP');
+ RegisterMethod('Function ADDDATABASE( DB : TIBDATABASE) : INTEGER');
+ RegisterMethod('Function FINDDATABASE( DB : TIBDATABASE) : INTEGER');
+ RegisterMethod('Function FINDDEFAULTDATABASE : TIBDATABASE');
+ RegisterMethod('Procedure REMOVEDATABASE( IDX : INTEGER)');
+ RegisterMethod('Procedure REMOVEDATABASES');
+ RegisterMethod('Procedure CHECKDATABASESINLIST');
+ RegisterProperty('DATABASECOUNT', 'INTEGER', iptr);
+ RegisterProperty('DATABASES', 'TIBDATABASE INTEGER', iptr);
+ RegisterProperty('SQLOBJECTCOUNT', 'INTEGER', iptr);
+ RegisterProperty('SQLOBJECTS', 'TIBBASE INTEGER', iptr);
+ RegisterProperty('HANDLE', 'TISC_TR_HANDLE', iptr);
+ RegisterProperty('HANDLEISSHARED', 'BOOLEAN', iptr);
+ RegisterProperty('INTRANSACTION', 'BOOLEAN', iptr);
+ RegisterProperty('TPB', 'PCHAR', iptr);
+ RegisterProperty('TPBLENGTH', 'SHORT', iptr);
+ RegisterProperty('ACTIVE', 'BOOLEAN', iptrw);
+ RegisterProperty('DEFAULTDATABASE', 'TIBDATABASE', iptrw);
+ RegisterProperty('IDLETIMER', 'INTEGER', iptrw);
+ RegisterProperty('DEFAULTACTION', 'TTRANSACTIONACTION', iptrw);
+ RegisterProperty('PARAMS', 'TSTRINGS', iptrw);
+ RegisterProperty('AUTOSTOPACTION', 'TAUTOSTOPACTION', iptrw);
+ RegisterProperty('ONIDLETIMER', 'TNOTIFYEVENT', iptrw);
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TIBDATABASE(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TCUSTOMCONNECTION', 'TIBDATABASE') do
+ with CL.AddClassN(CL.FindClass('TCUSTOMCONNECTION'),'TIBDATABASE') do
+ begin
+ RegisterMethod('Procedure ADDEVENTNOTIFIER( NOTIFIER : IIBEVENTNOTIFIER)');
+ RegisterMethod('Procedure REMOVEEVENTNOTIFIER( NOTIFIER : IIBEVENTNOTIFIER)');
+ RegisterMethod('Procedure APPLYUPDATES( const DATASETS : array of TDATASET)');
+ RegisterMethod('Procedure CLOSEDATASETS');
+ RegisterMethod('Procedure CHECKACTIVE');
+ RegisterMethod('Procedure CHECKINACTIVE');
+ RegisterMethod('Procedure CREATEDATABASE');
+ RegisterMethod('Procedure DROPDATABASE');
+ RegisterMethod('Procedure FORCECLOSE');
+ RegisterMethod('Procedure GETFIELDNAMES( const TABLENAME : STRING; LIST : TSTRINGS)');
+ RegisterMethod('Procedure GETTABLENAMES( LIST : TSTRINGS; SYSTEMTABLES : BOOLEAN)');
+ RegisterMethod('Function INDEXOFDBCONST( ST : STRING) : INTEGER');
+ RegisterMethod('Function TESTCONNECTED : BOOLEAN');
+ RegisterMethod('Procedure CHECKDATABASENAME');
+ RegisterMethod('Function CALL( ERRCODE : ISC_STATUS; RAISEERROR : BOOLEAN) : ISC_STATUS');
+ RegisterMethod('Function ADDTRANSACTION( TR : TIBTRANSACTION) : INTEGER');
+ RegisterMethod('Function FINDTRANSACTION( TR : TIBTRANSACTION) : INTEGER');
+ RegisterMethod('Function FINDDEFAULTTRANSACTION( ) : TIBTRANSACTION');
+ RegisterMethod('Procedure REMOVETRANSACTION( IDX : INTEGER)');
+ RegisterMethod('Procedure REMOVETRANSACTIONS');
+ RegisterMethod('Procedure SETHANDLE( VALUE : TISC_DB_HANDLE)');
+ RegisterMethod('procedure Open');
+ RegisterMethod('procedure Close');
+ RegisterProperty('Connected','BOOLEAN',iptrw);
+ RegisterProperty('HANDLE', 'TISC_DB_HANDLE', iptr);
+ RegisterProperty('ISREADONLY', 'BOOLEAN', iptr);
+ RegisterProperty('DBPARAMBYDPB', 'STRING INTEGER', iptrw);
+ RegisterProperty('SQLOBJECTCOUNT', 'INTEGER', iptr);
+ RegisterProperty('SQLOBJECTS', 'TIBBASE INTEGER', iptr);
+ RegisterProperty('HANDLEISSHARED', 'BOOLEAN', iptr);
+ RegisterProperty('TRANSACTIONCOUNT', 'INTEGER', iptr);
+ RegisterProperty('TRANSACTIONS', 'TIBTRANSACTION INTEGER', iptr);
+ RegisterProperty('INTERNALTRANSACTION', 'TIBTRANSACTION', iptr);
+ RegisterMethod('Function HAS_DEFAULT_VALUE( RELATION, FIELD : STRING) : BOOLEAN');
+ RegisterMethod('Function HAS_COMPUTED_BLR( RELATION, FIELD : STRING) : BOOLEAN');
+ RegisterMethod('Procedure FLUSHSCHEMA');
+ RegisterProperty('DATABASENAME', 'TIBFILENAME', iptrw);
+ RegisterProperty('PARAMS', 'TSTRINGS', iptrw);
+ RegisterProperty('DEFAULTTRANSACTION', 'TIBTRANSACTION', iptrw);
+ RegisterProperty('IDLETIMER', 'INTEGER', iptrw);
+ RegisterProperty('SQLDIALECT', 'INTEGER', iptrw);
+ RegisterProperty('DBSQLDIALECT', 'INTEGER', iptr);
+ RegisterProperty('TRACEFLAGS', 'TTRACEFLAGS', iptrw);
+ RegisterProperty('ALLOWSTREAMEDCONNECTED', 'BOOLEAN', iptrw);
+ RegisterProperty('ONLOGIN', 'TIBDATABASELOGINEVENT', iptrw);
+ RegisterProperty('ONIDLETIMER', 'TNOTIFYEVENT', iptrw);
+ RegisterProperty('ONDIALECTDOWNGRADEWARNING', 'TNOTIFYEVENT', iptrw);
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TIBSCHEMA(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TOBJECT', 'TIBSCHEMA') do
+ with CL.AddClassN(CL.FindClass('TOBJECT'),'TIBSCHEMA') do
+ begin
+ RegisterMethod('Procedure FREENODES');
+ RegisterMethod('Function HAS_DEFAULT_VALUE( RELATION, FIELD : STRING) : BOOLEAN');
+ RegisterMethod('Function HAS_COMPUTED_BLR( RELATION, FIELD : STRING) : BOOLEAN');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_IBDatabase(CL: TPSPascalCompiler);
+begin
+ CL.AddClassN(CL.FindClass('TOBJECT'),'TIBDATABASE');
+ CL.AddClassN(CL.FindClass('TOBJECT'),'TIBTRANSACTION');
+ CL.AddClassN(CL.FindClass('TOBJECT'),'TIBBASE');
+ CL.AddTypeS('TIBDATABASELOGINEVENT', 'Procedure ( DATABASE : TIBDATABASE; LOG'
+ +'INPARAMS : TSTRINGS)');
+ SIRegister_TIBSCHEMA(CL);
+ CL.AddTypeS('TIBFILENAME', 'STRING');
+ SIRegister_TIBDATABASE(CL);
+ CL.AddTypeS('TTRANSACTIONACTION', '( TAROLLBACK, TACOMMIT, TAROLLBACKRETAININ'
+ +'G, TACOMMITRETAINING )');
+ CL.AddTypeS('TAUTOSTOPACTION', '( SANONE, SAROLLBACK, SACOMMIT, SAROLLBACKRET'
+ +'AINING, SACOMMITRETAINING )');
+ SIRegister_TIBTRANSACTION(CL);
+ SIRegister_TIBBASE(CL);
+end;
+
+(* === run-time registration functions === *)
+(*----------------------------------------------------------------------------*)
+procedure TIBBASETRANSACTION_W(Self: TIBBASE; const T: TIBTRANSACTION);
+begin Self.TRANSACTION := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBBASETRANSACTION_R(Self: TIBBASE; var T: TIBTRANSACTION);
+begin T := Self.TRANSACTION; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBBASETRHANDLE_R(Self: TIBBASE; var T: PISC_TR_HANDLE);
+begin T := Self.TRHANDLE; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBBASEOWNER_R(Self: TIBBASE; var T: TOBJECT);
+begin T := Self.OWNER; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBBASEDBHANDLE_R(Self: TIBBASE; var T: PISC_DB_HANDLE);
+begin T := Self.DBHANDLE; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBBASEDATABASE_W(Self: TIBBASE; const T: TIBDATABASE);
+begin Self.DATABASE := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBBASEDATABASE_R(Self: TIBBASE; var T: TIBDATABASE);
+begin T := Self.DATABASE; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBBASEONTRANSACTIONFREE_W(Self: TIBBASE; const T: TNOTIFYEVENT);
+begin Self.ONTRANSACTIONFREE := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBBASEONTRANSACTIONFREE_R(Self: TIBBASE; var T: TNOTIFYEVENT);
+begin T := Self.ONTRANSACTIONFREE; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBBASEAFTERTRANSACTIONEND_W(Self: TIBBASE; const T: TNOTIFYEVENT);
+begin Self.AFTERTRANSACTIONEND := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBBASEAFTERTRANSACTIONEND_R(Self: TIBBASE; var T: TNOTIFYEVENT);
+begin T := Self.AFTERTRANSACTIONEND; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBBASEBEFORETRANSACTIONEND_W(Self: TIBBASE; const T: TNOTIFYEVENT);
+begin Self.BEFORETRANSACTIONEND := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBBASEBEFORETRANSACTIONEND_R(Self: TIBBASE; var T: TNOTIFYEVENT);
+begin T := Self.BEFORETRANSACTIONEND; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBBASEONDATABASEFREE_W(Self: TIBBASE; const T: TNOTIFYEVENT);
+begin Self.ONDATABASEFREE := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBBASEONDATABASEFREE_R(Self: TIBBASE; var T: TNOTIFYEVENT);
+begin T := Self.ONDATABASEFREE; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBBASEAFTERDATABASEDISCONNECT_W(Self: TIBBASE; const T: TNOTIFYEVENT);
+begin Self.AFTERDATABASEDISCONNECT := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBBASEAFTERDATABASEDISCONNECT_R(Self: TIBBASE; var T: TNOTIFYEVENT);
+begin T := Self.AFTERDATABASEDISCONNECT; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBBASEBEFOREDATABASEDISCONNECT_W(Self: TIBBASE; const T: TNOTIFYEVENT);
+begin Self.BEFOREDATABASEDISCONNECT := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBBASEBEFOREDATABASEDISCONNECT_R(Self: TIBBASE; var T: TNOTIFYEVENT);
+begin T := Self.BEFOREDATABASEDISCONNECT; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTRANSACTIONONIDLETIMER_W(Self: TIBTRANSACTION; const T: TNOTIFYEVENT);
+begin Self.ONIDLETIMER := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTRANSACTIONONIDLETIMER_R(Self: TIBTRANSACTION; var T: TNOTIFYEVENT);
+begin T := Self.ONIDLETIMER; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTRANSACTIONAUTOSTOPACTION_W(Self: TIBTRANSACTION; const T: TAUTOSTOPACTION);
+begin Self.AUTOSTOPACTION := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTRANSACTIONAUTOSTOPACTION_R(Self: TIBTRANSACTION; var T: TAUTOSTOPACTION);
+begin T := Self.AUTOSTOPACTION; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTRANSACTIONPARAMS_W(Self: TIBTRANSACTION; const T: TSTRINGS);
+begin Self.PARAMS := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTRANSACTIONPARAMS_R(Self: TIBTRANSACTION; var T: TSTRINGS);
+begin T := Self.PARAMS; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTRANSACTIONDEFAULTACTION_W(Self: TIBTRANSACTION; const T: TTRANSACTIONACTION);
+begin Self.DEFAULTACTION := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTRANSACTIONDEFAULTACTION_R(Self: TIBTRANSACTION; var T: TTRANSACTIONACTION);
+begin T := Self.DEFAULTACTION; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTRANSACTIONIDLETIMER_W(Self: TIBTRANSACTION; const T: INTEGER);
+begin Self.IDLETIMER := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTRANSACTIONIDLETIMER_R(Self: TIBTRANSACTION; var T: INTEGER);
+begin T := Self.IDLETIMER; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTRANSACTIONDEFAULTDATABASE_W(Self: TIBTRANSACTION; const T: TIBDATABASE);
+begin Self.DEFAULTDATABASE := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTRANSACTIONDEFAULTDATABASE_R(Self: TIBTRANSACTION; var T: TIBDATABASE);
+begin T := Self.DEFAULTDATABASE; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTRANSACTIONACTIVE_W(Self: TIBTRANSACTION; const T: BOOLEAN);
+begin Self.ACTIVE := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTRANSACTIONACTIVE_R(Self: TIBTRANSACTION; var T: BOOLEAN);
+begin T := Self.ACTIVE; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTRANSACTIONTPBLENGTH_R(Self: TIBTRANSACTION; var T: SHORT);
+begin T := Self.TPBLENGTH; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTRANSACTIONTPB_R(Self: TIBTRANSACTION; var T: PCHAR);
+begin T := Self.TPB; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTRANSACTIONINTRANSACTION_R(Self: TIBTRANSACTION; var T: BOOLEAN);
+begin T := Self.INTRANSACTION; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTRANSACTIONHANDLEISSHARED_R(Self: TIBTRANSACTION; var T: BOOLEAN);
+begin T := Self.HANDLEISSHARED; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTRANSACTIONHANDLE_R(Self: TIBTRANSACTION; var T: TISC_TR_HANDLE);
+begin T := Self.HANDLE; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTRANSACTIONSQLOBJECTS_R(Self: TIBTRANSACTION; var T: TIBBASE; const t1: INTEGER);
+begin T := Self.SQLOBJECTS[t1]; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTRANSACTIONSQLOBJECTCOUNT_R(Self: TIBTRANSACTION; var T: INTEGER);
+begin T := Self.SQLOBJECTCOUNT; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTRANSACTIONDATABASES_R(Self: TIBTRANSACTION; var T: TIBDATABASE; const t1: INTEGER);
+begin T := Self.DATABASES[t1]; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTRANSACTIONDATABASECOUNT_R(Self: TIBTRANSACTION; var T: INTEGER);
+begin T := Self.DATABASECOUNT; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASEONDIALECTDOWNGRADEWARNING_W(Self: TIBDATABASE; const T: TNOTIFYEVENT);
+begin Self.ONDIALECTDOWNGRADEWARNING := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASEONDIALECTDOWNGRADEWARNING_R(Self: TIBDATABASE; var T: TNOTIFYEVENT);
+begin T := Self.ONDIALECTDOWNGRADEWARNING; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASEONIDLETIMER_W(Self: TIBDATABASE; const T: TNOTIFYEVENT);
+begin Self.ONIDLETIMER := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASEONIDLETIMER_R(Self: TIBDATABASE; var T: TNOTIFYEVENT);
+begin T := Self.ONIDLETIMER; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASEONLOGIN_W(Self: TIBDATABASE; const T: TIBDATABASELOGINEVENT);
+begin Self.ONLOGIN := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASEONLOGIN_R(Self: TIBDATABASE; var T: TIBDATABASELOGINEVENT);
+begin T := Self.ONLOGIN; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASECONNECTED_W(Self: TIBDATABASE; const T: Boolean);
+begin Self.Connected := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASECONNECTED_R(Self: TIBDATABASE; var T: Boolean);
+begin T := Self.Connected; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASEALLOWSTREAMEDCONNECTED_W(Self: TIBDATABASE; const T: BOOLEAN);
+begin Self.ALLOWSTREAMEDCONNECTED := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASEALLOWSTREAMEDCONNECTED_R(Self: TIBDATABASE; var T: BOOLEAN);
+begin T := Self.ALLOWSTREAMEDCONNECTED; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASETRACEFLAGS_W(Self: TIBDATABASE; const T: TTRACEFLAGS);
+begin Self.TRACEFLAGS := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASETRACEFLAGS_R(Self: TIBDATABASE; var T: TTRACEFLAGS);
+begin T := Self.TRACEFLAGS; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASEDBSQLDIALECT_R(Self: TIBDATABASE; var T: INTEGER);
+begin T := Self.DBSQLDIALECT; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASESQLDIALECT_W(Self: TIBDATABASE; const T: INTEGER);
+begin Self.SQLDIALECT := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASESQLDIALECT_R(Self: TIBDATABASE; var T: INTEGER);
+begin T := Self.SQLDIALECT; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASEIDLETIMER_W(Self: TIBDATABASE; const T: INTEGER);
+begin Self.IDLETIMER := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASEIDLETIMER_R(Self: TIBDATABASE; var T: INTEGER);
+begin T := Self.IDLETIMER; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASEDEFAULTTRANSACTION_W(Self: TIBDATABASE; const T: TIBTRANSACTION);
+begin Self.DEFAULTTRANSACTION := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASEDEFAULTTRANSACTION_R(Self: TIBDATABASE; var T: TIBTRANSACTION);
+begin T := Self.DEFAULTTRANSACTION; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASEPARAMS_W(Self: TIBDATABASE; const T: TSTRINGS);
+begin Self.PARAMS := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASEPARAMS_R(Self: TIBDATABASE; var T: TSTRINGS);
+begin T := Self.PARAMS; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASEDATABASENAME_W(Self: TIBDATABASE; const T: TIBFILENAME);
+begin Self.DATABASENAME := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASEDATABASENAME_R(Self: TIBDATABASE; var T: TIBFILENAME);
+begin T := Self.DATABASENAME; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASEINTERNALTRANSACTION_R(Self: TIBDATABASE; var T: TIBTRANSACTION);
+begin T := Self.INTERNALTRANSACTION; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASETRANSACTIONS_R(Self: TIBDATABASE; var T: TIBTRANSACTION; const t1: INTEGER);
+begin T := Self.TRANSACTIONS[t1]; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASETRANSACTIONCOUNT_R(Self: TIBDATABASE; var T: INTEGER);
+begin T := Self.TRANSACTIONCOUNT; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASEHANDLEISSHARED_R(Self: TIBDATABASE; var T: BOOLEAN);
+begin T := Self.HANDLEISSHARED; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASESQLOBJECTS_R(Self: TIBDATABASE; var T: TIBBASE; const t1: INTEGER);
+begin T := Self.SQLOBJECTS[t1]; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASESQLOBJECTCOUNT_R(Self: TIBDATABASE; var T: INTEGER);
+begin T := Self.SQLOBJECTCOUNT; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASEDBPARAMBYDPB_W(Self: TIBDATABASE; const T: STRING; const t1: INTEGER);
+begin Self.DBPARAMBYDPB[t1] := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASEDBPARAMBYDPB_R(Self: TIBDATABASE; var T: STRING; const t1: INTEGER);
+begin T := Self.DBPARAMBYDPB[t1]; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASEISREADONLY_R(Self: TIBDATABASE; var T: BOOLEAN);
+begin T := Self.ISREADONLY; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATABASEHANDLE_R(Self: TIBDATABASE; var T: TISC_DB_HANDLE);
+begin T := Self.HANDLE; end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TIBDATALINK(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TDETAILDATALINK', 'TIBDATALINK') do
+ with CL.AddClassN(CL.FindClass('TDETAILDATALINK'),'TIBDATALINK') do
+ begin
+ RegisterMethod('Constructor CREATE( ADATASET : TIBCUSTOMDATASET)');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TIBBCDFIELD(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TBCDFIELD', 'TIBBCDFIELD') do
+ with CL.AddClassN(CL.FindClass('TBCDFIELD'),'TIBBCDFIELD') do
+ begin
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TIBSTRINGFIELD(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TSTRINGFIELD', 'TIBSTRINGFIELD') do
+ with CL.AddClassN(CL.FindClass('TSTRINGFIELD'),'TIBSTRINGFIELD') do
+ begin
+ RegisterMethod('Function GETVALUE( var VALUE : STRING) : BOOLEAN');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TIBDATASETUPDATEOBJECT(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TCOMPONENT', 'TIBDATASETUPDATEOBJECT') do
+ with CL.AddClassN(CL.FindClass('TCOMPONENT'),'TIBDATASETUPDATEOBJECT') do
+ begin
+ RegisterProperty('REFRESHSQL', 'TSTRINGS', iptrw);
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_IBCustomDataSet(CL: TPSPascalCompiler);
+begin
+ CL.AddConstantN('BUFFERCACHESIZE','LONGINT').SetInt( 1000);
+ CL.AddConstantN('UNICACHE','LONGINT').SetInt( 2);
+ CL.AddClassN(CL.FindClass('TOBJECT'),'TIBCUSTOMDATASET');
+ CL.AddClassN(CL.FindClass('TOBJECT'),'TIBDATASET');
+ SIRegister_TIBDATASETUPDATEOBJECT(CL);
+ CL.AddTypeS('TCACHEDUPDATESTATUS', '( CUSUNMODIFIED, CUSMODIFIED, CUSINSERTED'
+ +', CUSDELETED, CUSUNINSERTED )');
+ SIRegister_TIBSTRINGFIELD(CL);
+ SIRegister_TIBBCDFIELD(CL);
+ SIRegister_TIBDATALINK(CL);
+ CL.AddTypeS('TIBGENERATORAPPLYEVENT', '( GAMONNEWRECORD, GAMONPOST, GAMONSERV'
+ +'ER )');
+ SIRegister_TIBGENERATORFIELD(CL);
+ CL.AddTypeS('TIBUPDATEACTION', '( UAFAIL, UAABORT, UASKIP, UARETRY, UAAPPLY, '
+ +'UAAPPLIED )');
+ CL.AddTypeS('TIBUPDATERECORDTYPES', 'set of TCACHEDUPDATESTATUS');
+ CL.AddTypeS('TLIVEMODE', '( LMINSERT, LMMODIFY, LMDELETE, LMREFRESH )');
+ CL.AddTypeS('TLIVEMODES', 'set of TLIVEMODE');
+ SIRegister_TIBCUSTOMDATASET(CL);
+ SIRegister_TIBDATASET(CL);
+end;
+
+(* === run-time registration functions === *)
+(*----------------------------------------------------------------------------*)
+procedure TIBDATASETPREPARED_R(Self: TIBDATASET; var T: BOOLEAN);
+begin T := Self.PREPARED; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBCUSTOMDATASETFORCEDREFRESH_W(Self: TIBCUSTOMDATASET; const T: BOOLEAN);
+begin Self.FORCEDREFRESH := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBCUSTOMDATASETFORCEDREFRESH_R(Self: TIBCUSTOMDATASET; var T: BOOLEAN);
+begin T := Self.FORCEDREFRESH; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBCUSTOMDATASETTRANSACTION_W(Self: TIBCUSTOMDATASET; const T: TIBTRANSACTION);
+begin Self.TRANSACTION := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBCUSTOMDATASETTRANSACTION_R(Self: TIBCUSTOMDATASET; var T: TIBTRANSACTION);
+begin T := Self.TRANSACTION; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBCUSTOMDATASETDATABASE_W(Self: TIBCUSTOMDATASET; const T: TIBDATABASE);
+begin Self.DATABASE := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBCUSTOMDATASETDATABASE_R(Self: TIBCUSTOMDATASET; var T: TIBDATABASE);
+begin T := Self.DATABASE; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBCUSTOMDATASETPLAN_R(Self: TIBCUSTOMDATASET; var T: STRING);
+begin T := Self.PLAN; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBCUSTOMDATASETROWSAFFECTED_R(Self: TIBCUSTOMDATASET; var T: INTEGER);
+begin T := Self.ROWSAFFECTED; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBCUSTOMDATASETUPDATERECORDTYPES_W(Self: TIBCUSTOMDATASET; const T: TIBUPDATERECORDTYPES);
+begin Self.UPDATERECORDTYPES := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBCUSTOMDATASETUPDATERECORDTYPES_R(Self: TIBCUSTOMDATASET; var T: TIBUPDATERECORDTYPES);
+begin T := Self.UPDATERECORDTYPES; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBCUSTOMDATASETUPDATESPENDING_R(Self: TIBCUSTOMDATASET; var T: BOOLEAN);
+begin T := Self.UPDATESPENDING; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBCUSTOMDATASETUPDATEOBJECT_W(Self: TIBCUSTOMDATASET; const T: TIBDATASETUPDATEOBJECT);
+begin Self.UPDATEOBJECT := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBCUSTOMDATASETUPDATEOBJECT_R(Self: TIBCUSTOMDATASET; var T: TIBDATASETUPDATEOBJECT);
+begin T := Self.UPDATEOBJECT; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBCUSTOMDATASETTRHANDLE_R(Self: TIBCUSTOMDATASET; var T: PISC_TR_HANDLE);
+begin T := Self.TRHANDLE; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBCUSTOMDATASETDBHANDLE_R(Self: TIBCUSTOMDATASET; var T: PISC_DB_HANDLE);
+begin T := Self.DBHANDLE; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBGENERATORFIELDAPPLYEVENT_W(Self: TIBGENERATORFIELD; const T: TIBGENERATORAPPLYEVENT);
+begin Self.APPLYEVENT := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBGENERATORFIELDAPPLYEVENT_R(Self: TIBGENERATORFIELD; var T: TIBGENERATORAPPLYEVENT);
+begin T := Self.APPLYEVENT; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBGENERATORFIELDINCREMENTBY_W(Self: TIBGENERATORFIELD; const T: INTEGER);
+begin Self.INCREMENTBY := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBGENERATORFIELDINCREMENTBY_R(Self: TIBGENERATORFIELD; var T: INTEGER);
+begin T := Self.INCREMENTBY; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBGENERATORFIELDGENERATOR_W(Self: TIBGENERATORFIELD; const T: STRING);
+begin Self.GENERATOR := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBGENERATORFIELDGENERATOR_R(Self: TIBGENERATORFIELD; var T: STRING);
+begin T := Self.GENERATOR; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBGENERATORFIELDFIELD_W(Self: TIBGENERATORFIELD; const T: STRING);
+begin Self.FIELD := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBGENERATORFIELDFIELD_R(Self: TIBGENERATORFIELD; var T: STRING);
+begin T := Self.FIELD; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATASETUPDATEOBJECTREFRESHSQL_W(Self: TIBDATASETUPDATEOBJECT; const T: TSTRINGS);
+begin Self.REFRESHSQL := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBDATASETUPDATEOBJECTREFRESHSQL_R(Self: TIBDATASETUPDATEOBJECT; var T: TSTRINGS);
+begin T := Self.REFRESHSQL; end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TIBDATASET(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TIBDATASET) do
+ begin
+ RegisterMethod(@TIBDATASET.PREPARE, 'PREPARE');
+ RegisterMethod(@TIBDATASET.UNPREPARE, 'UNPREPARE');
+ RegisterMethod(@TIBDATASET.BATCHINPUT, 'BATCHINPUT');
+ RegisterMethod(@TIBDATASET.BATCHOUTPUT, 'BATCHOUTPUT');
+ RegisterMethod(@TIBDATASET.EXECSQL, 'EXECSQL');
+ RegisterMethod(@TIBDATASET.PARAMBYNAME, 'PARAMBYNAME');
+ RegisterPropertyHelper(@TIBDATASETPREPARED_R,nil,'PREPARED');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TIBCUSTOMDATASET(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TIBCUSTOMDATASET) do
+ begin
+ RegisterMethod(@TIBCUSTOMDATASET.APPLYUPDATES, 'APPLYUPDATES');
+ RegisterMethod(@TIBCUSTOMDATASET.CACHEDUPDATESTATUS, 'CACHEDUPDATESTATUS');
+ RegisterMethod(@TIBCUSTOMDATASET.CANCELUPDATES, 'CANCELUPDATES');
+ RegisterMethod(@TIBCUSTOMDATASET.FETCHALL, 'FETCHALL');
+ RegisterMethod(@TIBCUSTOMDATASET.LOCATENEXT, 'LOCATENEXT');
+// RegisterMethod(@TIBCUSTOMDATASET.LOCATE, 'LOCATE');
+ RegisterMethod(@TIBCUSTOMDATASET.RECORDMODIFIED, 'RECORDMODIFIED');
+ RegisterMethod(@TIBCUSTOMDATASET.REVERTRECORD, 'REVERTRECORD');
+ RegisterMethod(@TIBCUSTOMDATASET.UNDELETE, 'UNDELETE');
+ RegisterMethod(@TIBCUSTOMDATASET.CURRENT, 'CURRENT');
+ RegisterMethod(@TIBCUSTOMDATASET.SQLTYPE, 'SQLTYPE');
+ RegisterPropertyHelper(@TIBCUSTOMDATASETDBHANDLE_R,nil,'DBHANDLE');
+ RegisterPropertyHelper(@TIBCUSTOMDATASETTRHANDLE_R,nil,'TRHANDLE');
+ RegisterPropertyHelper(@TIBCUSTOMDATASETUPDATEOBJECT_R,@TIBCUSTOMDATASETUPDATEOBJECT_W,'UPDATEOBJECT');
+ RegisterPropertyHelper(@TIBCUSTOMDATASETUPDATESPENDING_R,nil,'UPDATESPENDING');
+ RegisterPropertyHelper(@TIBCUSTOMDATASETUPDATERECORDTYPES_R,@TIBCUSTOMDATASETUPDATERECORDTYPES_W,'UPDATERECORDTYPES');
+ RegisterPropertyHelper(@TIBCUSTOMDATASETROWSAFFECTED_R,nil,'ROWSAFFECTED');
+ RegisterPropertyHelper(@TIBCUSTOMDATASETPLAN_R,nil,'PLAN');
+ RegisterPropertyHelper(@TIBCUSTOMDATASETDATABASE_R,@TIBCUSTOMDATASETDATABASE_W,'DATABASE');
+ RegisterPropertyHelper(@TIBCUSTOMDATASETTRANSACTION_R,@TIBCUSTOMDATASETTRANSACTION_W,'TRANSACTION');
+ RegisterPropertyHelper(@TIBCUSTOMDATASETFORCEDREFRESH_R,@TIBCUSTOMDATASETFORCEDREFRESH_W,'FORCEDREFRESH');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TIBGENERATORFIELD(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TIBGENERATORFIELD) do
+ begin
+ RegisterConstructor(@TIBGENERATORFIELD.CREATE, 'CREATE');
+ RegisterMethod(@TIBGENERATORFIELD.VALUENAME, 'VALUENAME');
+ RegisterMethod(@TIBGENERATORFIELD.APPLY, 'APPLY');
+ RegisterPropertyHelper(@TIBGENERATORFIELDFIELD_R,@TIBGENERATORFIELDFIELD_W,'FIELD');
+ RegisterPropertyHelper(@TIBGENERATORFIELDGENERATOR_R,@TIBGENERATORFIELDGENERATOR_W,'GENERATOR');
+ RegisterPropertyHelper(@TIBGENERATORFIELDINCREMENTBY_R,@TIBGENERATORFIELDINCREMENTBY_W,'INCREMENTBY');
+ RegisterPropertyHelper(@TIBGENERATORFIELDAPPLYEVENT_R,@TIBGENERATORFIELDAPPLYEVENT_W,'APPLYEVENT');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TIBDATALINK(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TIBDATALINK) do
+ begin
+ RegisterConstructor(@TIBDATALINK.CREATE, 'CREATE');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TIBBCDFIELD(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TIBBCDFIELD) do
+ begin
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TIBSTRINGFIELD(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TIBSTRINGFIELD) do
+ begin
+ RegisterMethod(@TIBSTRINGFIELD.GETVALUE, 'GETVALUE');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TIBDATASETUPDATEOBJECT(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TIBDATASETUPDATEOBJECT) do
+ begin
+ RegisterPropertyHelper(@TIBDATASETUPDATEOBJECTREFRESHSQL_R,@TIBDATASETUPDATEOBJECTREFRESHSQL_W,'REFRESHSQL');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_IBCustomDataSet(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TIBCUSTOMDATASET) do
+ with CL.Add(TIBDATASET) do
+ RIRegister_TIBDATASETUPDATEOBJECT(CL);
+ RIRegister_TIBSTRINGFIELD(CL);
+ RIRegister_TIBBCDFIELD(CL);
+ RIRegister_TIBDATALINK(CL);
+ RIRegister_TIBGENERATORFIELD(CL);
+ RIRegister_TIBCUSTOMDATASET(CL);
+ RIRegister_TIBDATASET(CL);
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TIBBASE(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TIBBASE) do
+ begin
+ RegisterConstructor(@TIBBASE.CREATE, 'CREATE');
+ RegisterVirtualMethod(@TIBBASE.CHECKDATABASE, 'CHECKDATABASE');
+ RegisterVirtualMethod(@TIBBASE.CHECKTRANSACTION, 'CHECKTRANSACTION');
+ RegisterPropertyHelper(@TIBBASEBEFOREDATABASEDISCONNECT_R,@TIBBASEBEFOREDATABASEDISCONNECT_W,'BEFOREDATABASEDISCONNECT');
+ RegisterPropertyHelper(@TIBBASEAFTERDATABASEDISCONNECT_R,@TIBBASEAFTERDATABASEDISCONNECT_W,'AFTERDATABASEDISCONNECT');
+ RegisterEventPropertyHelper(@TIBBASEONDATABASEFREE_R,@TIBBASEONDATABASEFREE_W,'ONDATABASEFREE');
+ RegisterPropertyHelper(@TIBBASEBEFORETRANSACTIONEND_R,@TIBBASEBEFORETRANSACTIONEND_W,'BEFORETRANSACTIONEND');
+ RegisterPropertyHelper(@TIBBASEAFTERTRANSACTIONEND_R,@TIBBASEAFTERTRANSACTIONEND_W,'AFTERTRANSACTIONEND');
+ RegisterEventPropertyHelper(@TIBBASEONTRANSACTIONFREE_R,@TIBBASEONTRANSACTIONFREE_W,'ONTRANSACTIONFREE');
+ RegisterPropertyHelper(@TIBBASEDATABASE_R,@TIBBASEDATABASE_W,'DATABASE');
+ RegisterPropertyHelper(@TIBBASEDBHANDLE_R,nil,'DBHANDLE');
+ RegisterPropertyHelper(@TIBBASEOWNER_R,nil,'OWNER');
+ RegisterPropertyHelper(@TIBBASETRHANDLE_R,nil,'TRHANDLE');
+ RegisterPropertyHelper(@TIBBASETRANSACTION_R,@TIBBASETRANSACTION_W,'TRANSACTION');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TIBTRANSACTION(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TIBTRANSACTION) do
+ begin
+ RegisterMethod(@TIBTRANSACTION.CALL, 'CALL');
+ RegisterMethod(@TIBTRANSACTION.COMMIT, 'COMMIT');
+ RegisterMethod(@TIBTRANSACTION.COMMITRETAINING, 'COMMITRETAINING');
+ RegisterMethod(@TIBTRANSACTION.ROLLBACK, 'ROLLBACK');
+ RegisterMethod(@TIBTRANSACTION.ROLLBACKRETAINING, 'ROLLBACKRETAINING');
+ RegisterMethod(@TIBTRANSACTION.STARTTRANSACTION, 'STARTTRANSACTION');
+ RegisterMethod(@TIBTRANSACTION.CHECKINTRANSACTION, 'CHECKINTRANSACTION');
+ RegisterMethod(@TIBTRANSACTION.CHECKNOTINTRANSACTION, 'CHECKNOTINTRANSACTION');
+ RegisterMethod(@TIBTRANSACTION.CHECKAUTOSTOP, 'CHECKAUTOSTOP');
+ RegisterMethod(@TIBTRANSACTION.ADDDATABASE, 'ADDDATABASE');
+ RegisterMethod(@TIBTRANSACTION.FINDDATABASE, 'FINDDATABASE');
+ RegisterMethod(@TIBTRANSACTION.FINDDEFAULTDATABASE, 'FINDDEFAULTDATABASE');
+ RegisterMethod(@TIBTRANSACTION.REMOVEDATABASE, 'REMOVEDATABASE');
+ RegisterMethod(@TIBTRANSACTION.REMOVEDATABASES, 'REMOVEDATABASES');
+ RegisterMethod(@TIBTRANSACTION.CHECKDATABASESINLIST, 'CHECKDATABASESINLIST');
+ RegisterPropertyHelper(@TIBTRANSACTIONDATABASECOUNT_R,nil,'DATABASECOUNT');
+ RegisterPropertyHelper(@TIBTRANSACTIONDATABASES_R,nil,'DATABASES');
+ RegisterPropertyHelper(@TIBTRANSACTIONSQLOBJECTCOUNT_R,nil,'SQLOBJECTCOUNT');
+ RegisterPropertyHelper(@TIBTRANSACTIONSQLOBJECTS_R,nil,'SQLOBJECTS');
+ RegisterPropertyHelper(@TIBTRANSACTIONHANDLE_R,nil,'HANDLE');
+ RegisterPropertyHelper(@TIBTRANSACTIONHANDLEISSHARED_R,nil,'HANDLEISSHARED');
+ RegisterPropertyHelper(@TIBTRANSACTIONINTRANSACTION_R,nil,'INTRANSACTION');
+ RegisterPropertyHelper(@TIBTRANSACTIONTPB_R,nil,'TPB');
+ RegisterPropertyHelper(@TIBTRANSACTIONTPBLENGTH_R,nil,'TPBLENGTH');
+ RegisterPropertyHelper(@TIBTRANSACTIONACTIVE_R,@TIBTRANSACTIONACTIVE_W,'ACTIVE');
+ RegisterPropertyHelper(@TIBTRANSACTIONDEFAULTDATABASE_R,@TIBTRANSACTIONDEFAULTDATABASE_W,'DEFAULTDATABASE');
+ RegisterPropertyHelper(@TIBTRANSACTIONIDLETIMER_R,@TIBTRANSACTIONIDLETIMER_W,'IDLETIMER');
+ RegisterPropertyHelper(@TIBTRANSACTIONDEFAULTACTION_R,@TIBTRANSACTIONDEFAULTACTION_W,'DEFAULTACTION');
+ RegisterPropertyHelper(@TIBTRANSACTIONPARAMS_R,@TIBTRANSACTIONPARAMS_W,'PARAMS');
+ RegisterPropertyHelper(@TIBTRANSACTIONAUTOSTOPACTION_R,@TIBTRANSACTIONAUTOSTOPACTION_W,'AUTOSTOPACTION');
+ RegisterEventPropertyHelper(@TIBTRANSACTIONONIDLETIMER_R,@TIBTRANSACTIONONIDLETIMER_W,'ONIDLETIMER');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TIBDATABASE(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TIBDATABASE) do
+ begin
+ RegisterMethod(@TIBDATABASE.ADDEVENTNOTIFIER, 'ADDEVENTNOTIFIER');
+ RegisterMethod(@TIBDATABASE.REMOVEEVENTNOTIFIER, 'REMOVEEVENTNOTIFIER');
+ RegisterMethod(@TIBDATABASE.APPLYUPDATES, 'APPLYUPDATES');
+ RegisterMethod(@TIBDATABASE.CLOSEDATASETS, 'CLOSEDATASETS');
+ RegisterMethod(@TIBDATABASE.CHECKACTIVE, 'CHECKACTIVE');
+ RegisterMethod(@TIBDATABASE.CHECKINACTIVE, 'CHECKINACTIVE');
+ RegisterMethod(@TIBDATABASE.CREATEDATABASE, 'CREATEDATABASE');
+ RegisterMethod(@TIBDATABASE.DROPDATABASE, 'DROPDATABASE');
+ RegisterMethod(@TIBDATABASE.FORCECLOSE, 'FORCECLOSE');
+ RegisterMethod(@TIBDATABASE.GETFIELDNAMES, 'GETFIELDNAMES');
+ RegisterMethod(@TIBDATABASE.GETTABLENAMES, 'GETTABLENAMES');
+ RegisterMethod(@TIBDATABASE.INDEXOFDBCONST, 'INDEXOFDBCONST');
+ RegisterMethod(@TIBDATABASE.TESTCONNECTED, 'TESTCONNECTED');
+ RegisterMethod(@TIBDATABASE.CHECKDATABASENAME, 'CHECKDATABASENAME');
+ RegisterMethod(@TIBDATABASE.CALL, 'CALL');
+ RegisterMethod(@TIBDATABASE.Open, 'OPEN');
+ RegisterMethod(@TIBDATABASE.Close, 'CLOSE');
+ RegisterMethod(@TIBDATABASE.ADDTRANSACTION, 'ADDTRANSACTION');
+ RegisterMethod(@TIBDATABASE.FINDTRANSACTION, 'FINDTRANSACTION');
+ RegisterMethod(@TIBDATABASE.FINDDEFAULTTRANSACTION, 'FINDDEFAULTTRANSACTION');
+ RegisterMethod(@TIBDATABASE.REMOVETRANSACTION, 'REMOVETRANSACTION');
+ RegisterMethod(@TIBDATABASE.REMOVETRANSACTIONS, 'REMOVETRANSACTIONS');
+ RegisterMethod(@TIBDATABASE.SETHANDLE, 'SETHANDLE');
+ RegisterPropertyHelper(@TIBDATABASEHANDLE_R,nil,'HANDLE');
+ RegisterPropertyHelper(@TIBDATABASEISREADONLY_R,nil,'ISREADONLY');
+ RegisterPropertyHelper(@TIBDATABASEDBPARAMBYDPB_R,@TIBDATABASEDBPARAMBYDPB_W,'DBPARAMBYDPB');
+ RegisterPropertyHelper(@TIBDATABASESQLOBJECTCOUNT_R,nil,'SQLOBJECTCOUNT');
+ RegisterPropertyHelper(@TIBDATABASESQLOBJECTS_R,nil,'SQLOBJECTS');
+ RegisterPropertyHelper(@TIBDATABASEHANDLEISSHARED_R,nil,'HANDLEISSHARED');
+ RegisterPropertyHelper(@TIBDATABASETRANSACTIONCOUNT_R,nil,'TRANSACTIONCOUNT');
+ RegisterPropertyHelper(@TIBDATABASETRANSACTIONS_R,nil,'TRANSACTIONS');
+ RegisterPropertyHelper(@TIBDATABASEINTERNALTRANSACTION_R,nil,'INTERNALTRANSACTION');
+ RegisterMethod(@TIBDATABASE.HAS_DEFAULT_VALUE, 'HAS_DEFAULT_VALUE');
+ RegisterMethod(@TIBDATABASE.HAS_COMPUTED_BLR, 'HAS_COMPUTED_BLR');
+ RegisterMethod(@TIBDATABASE.FLUSHSCHEMA, 'FLUSHSCHEMA');
+ RegisterPropertyHelper(@TIBDATABASEDATABASENAME_R,@TIBDATABASEDATABASENAME_W,'DATABASENAME');
+ RegisterPropertyHelper(@TIBDATABASECONNECTED_R,@TIBDATABASECONNECTED_W,'CONNECTED');
+ RegisterPropertyHelper(@TIBDATABASEPARAMS_R,@TIBDATABASEPARAMS_W,'PARAMS');
+ RegisterPropertyHelper(@TIBDATABASEDEFAULTTRANSACTION_R,@TIBDATABASEDEFAULTTRANSACTION_W,'DEFAULTTRANSACTION');
+ RegisterPropertyHelper(@TIBDATABASEIDLETIMER_R,@TIBDATABASEIDLETIMER_W,'IDLETIMER');
+ RegisterPropertyHelper(@TIBDATABASESQLDIALECT_R,@TIBDATABASESQLDIALECT_W,'SQLDIALECT');
+ RegisterPropertyHelper(@TIBDATABASEDBSQLDIALECT_R,nil,'DBSQLDIALECT');
+ RegisterPropertyHelper(@TIBDATABASETRACEFLAGS_R,@TIBDATABASETRACEFLAGS_W,'TRACEFLAGS');
+ RegisterPropertyHelper(@TIBDATABASEALLOWSTREAMEDCONNECTED_R,@TIBDATABASEALLOWSTREAMEDCONNECTED_W,'ALLOWSTREAMEDCONNECTED');
+ RegisterEventPropertyHelper(@TIBDATABASEONLOGIN_R,@TIBDATABASEONLOGIN_W,'ONLOGIN');
+ RegisterEventPropertyHelper(@TIBDATABASEONIDLETIMER_R,@TIBDATABASEONIDLETIMER_W,'ONIDLETIMER');
+ RegisterEventPropertyHelper(@TIBDATABASEONDIALECTDOWNGRADEWARNING_R,@TIBDATABASEONDIALECTDOWNGRADEWARNING_W,'ONDIALECTDOWNGRADEWARNING');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_IBDatabase(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TIBDATABASE) do
+ with CL.Add(TIBTRANSACTION) do
+ with CL.Add(TIBBASE) do
+ RIRegister_TIBDATABASE(CL);
+ RIRegister_TIBTRANSACTION(CL);
+ RIRegister_TIBBASE(CL);
+end;
+
+(* === compile-time registration functions === *)
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TIBTABLE(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TIBCUSTOMDATASET', 'TIBTABLE') do
+ with CL.AddClassN(CL.FindClass('TIBCUSTOMDATASET'),'TIBTABLE') do
+ begin
+ RegisterMethod('Procedure ADDINDEX( const NAME, FIELDS : STRING; OPTIONS : TINDEXOPTIONS; const DESCFIELDS : STRING)');
+ RegisterMethod('Procedure CREATETABLE');
+ RegisterMethod('Procedure DELETEINDEX( const NAME : STRING)');
+ RegisterMethod('Procedure DELETETABLE');
+ RegisterMethod('Procedure EMPTYTABLE');
+ RegisterMethod('Procedure GETINDEXNAMES( LIST : TSTRINGS)');
+ RegisterMethod('Procedure GOTOCURRENT( TABLE : TIBTABLE)');
+ RegisterProperty('CURRENTDBKEY', 'TIBDBKEY', iptr);
+ RegisterProperty('EXISTS', 'BOOLEAN', iptr);
+ RegisterProperty('INDEXFIELDCOUNT', 'INTEGER', iptr);
+ RegisterProperty('INDEXFIELDS', 'TFIELD INTEGER', iptrw);
+ RegisterProperty('TABLENAMES', 'TSTRINGS', iptr);
+ RegisterProperty('DEFAULTINDEX', 'BOOLEAN', iptrw);
+ RegisterProperty('INDEXDEFS', 'TINDEXDEFS', iptrw);
+ RegisterProperty('INDEXFIELDNAMES', 'STRING', iptrw);
+ RegisterProperty('INDEXNAME', 'STRING', iptrw);
+ RegisterProperty('MASTERFIELDS', 'STRING', iptrw);
+ RegisterProperty('MASTERSOURCE', 'TDATASOURCE', iptrw);
+ RegisterProperty('READONLY', 'BOOLEAN', iptrw);
+ RegisterProperty('STOREDEFS', 'BOOLEAN', iptrw);
+ RegisterProperty('TABLENAME', 'STRING', iptrw);
+ RegisterProperty('TABLETYPES', 'TIBTABLETYPES', iptrw);
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_IBTable(CL: TPSPascalCompiler);
+begin
+ CL.AddTypeS('TIBTABLETYPE', '( TTSYSTEM, TTVIEW )');
+ CL.AddTypeS('TIBTABLETYPES', 'set of TIBTABLETYPE');
+ CL.AddTypeS('TINDEXNAME', 'STRING');
+ CL.AddClassN(CL.FindClass('TOBJECT'),'TIBTABLE');
+ SIRegister_TIBTABLE(CL);
+end;
+
+(* === run-time registration functions === *)
+(*----------------------------------------------------------------------------*)
+procedure TIBTABLETABLETYPES_W(Self: TIBTABLE; const T: TIBTABLETYPES);
+begin Self.TABLETYPES := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTABLETABLETYPES_R(Self: TIBTABLE; var T: TIBTABLETYPES);
+begin T := Self.TABLETYPES; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTABLETABLENAME_W(Self: TIBTABLE; const T: STRING);
+begin Self.TABLENAME := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTABLETABLENAME_R(Self: TIBTABLE; var T: STRING);
+begin T := Self.TABLENAME; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTABLESTOREDEFS_W(Self: TIBTABLE; const T: BOOLEAN);
+begin Self.STOREDEFS := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTABLESTOREDEFS_R(Self: TIBTABLE; var T: BOOLEAN);
+begin T := Self.STOREDEFS; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTABLEREADONLY_W(Self: TIBTABLE; const T: BOOLEAN);
+begin Self.READONLY := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTABLEREADONLY_R(Self: TIBTABLE; var T: BOOLEAN);
+begin T := Self.READONLY; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTABLEMASTERSOURCE_W(Self: TIBTABLE; const T: TDATASOURCE);
+begin Self.MASTERSOURCE := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTABLEMASTERSOURCE_R(Self: TIBTABLE; var T: TDATASOURCE);
+begin T := Self.MASTERSOURCE; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTABLEMASTERFIELDS_W(Self: TIBTABLE; const T: STRING);
+begin Self.MASTERFIELDS := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTABLEMASTERFIELDS_R(Self: TIBTABLE; var T: STRING);
+begin T := Self.MASTERFIELDS; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTABLEINDEXNAME_W(Self: TIBTABLE; const T: STRING);
+begin Self.INDEXNAME := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTABLEINDEXNAME_R(Self: TIBTABLE; var T: STRING);
+begin T := Self.INDEXNAME; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTABLEINDEXFIELDNAMES_W(Self: TIBTABLE; const T: STRING);
+begin Self.INDEXFIELDNAMES := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTABLEINDEXFIELDNAMES_R(Self: TIBTABLE; var T: STRING);
+begin T := Self.INDEXFIELDNAMES; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTABLEINDEXDEFS_W(Self: TIBTABLE; const T: TINDEXDEFS);
+begin Self.INDEXDEFS := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTABLEINDEXDEFS_R(Self: TIBTABLE; var T: TINDEXDEFS);
+begin T := Self.INDEXDEFS; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTABLEDEFAULTINDEX_W(Self: TIBTABLE; const T: BOOLEAN);
+begin Self.DEFAULTINDEX := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTABLEDEFAULTINDEX_R(Self: TIBTABLE; var T: BOOLEAN);
+begin T := Self.DEFAULTINDEX; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTABLETABLENAMES_R(Self: TIBTABLE; var T: TSTRINGS);
+begin T := Self.TABLENAMES; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTABLEINDEXFIELDS_W(Self: TIBTABLE; const T: TFIELD; const t1: INTEGER);
+begin Self.INDEXFIELDS[t1] := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTABLEINDEXFIELDS_R(Self: TIBTABLE; var T: TFIELD; const t1: INTEGER);
+begin T := Self.INDEXFIELDS[t1]; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTABLEINDEXFIELDCOUNT_R(Self: TIBTABLE; var T: INTEGER);
+begin T := Self.INDEXFIELDCOUNT; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTABLEEXISTS_R(Self: TIBTABLE; var T: BOOLEAN);
+begin T := Self.EXISTS; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBTABLECURRENTDBKEY_R(Self: TIBTABLE; var T: TIBDBKEY);
+begin T := Self.CURRENTDBKEY; end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TIBTABLE(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TIBTABLE) do
+ begin
+ RegisterMethod(@TIBTABLE.ADDINDEX, 'ADDINDEX');
+ RegisterMethod(@TIBTABLE.CREATETABLE, 'CREATETABLE');
+ RegisterMethod(@TIBTABLE.DELETEINDEX, 'DELETEINDEX');
+ RegisterMethod(@TIBTABLE.DELETETABLE, 'DELETETABLE');
+ RegisterMethod(@TIBTABLE.EMPTYTABLE, 'EMPTYTABLE');
+ RegisterMethod(@TIBTABLE.GETINDEXNAMES, 'GETINDEXNAMES');
+ RegisterMethod(@TIBTABLE.GOTOCURRENT, 'GOTOCURRENT');
+ RegisterPropertyHelper(@TIBTABLECURRENTDBKEY_R,nil,'CURRENTDBKEY');
+ RegisterPropertyHelper(@TIBTABLEEXISTS_R,nil,'EXISTS');
+ RegisterPropertyHelper(@TIBTABLEINDEXFIELDCOUNT_R,nil,'INDEXFIELDCOUNT');
+ RegisterPropertyHelper(@TIBTABLEINDEXFIELDS_R,@TIBTABLEINDEXFIELDS_W,'INDEXFIELDS');
+ RegisterPropertyHelper(@TIBTABLETABLENAMES_R,nil,'TABLENAMES');
+ RegisterPropertyHelper(@TIBTABLEDEFAULTINDEX_R,@TIBTABLEDEFAULTINDEX_W,'DEFAULTINDEX');
+ RegisterPropertyHelper(@TIBTABLEINDEXDEFS_R,@TIBTABLEINDEXDEFS_W,'INDEXDEFS');
+ RegisterPropertyHelper(@TIBTABLEINDEXFIELDNAMES_R,@TIBTABLEINDEXFIELDNAMES_W,'INDEXFIELDNAMES');
+ RegisterPropertyHelper(@TIBTABLEINDEXNAME_R,@TIBTABLEINDEXNAME_W,'INDEXNAME');
+ RegisterPropertyHelper(@TIBTABLEMASTERFIELDS_R,@TIBTABLEMASTERFIELDS_W,'MASTERFIELDS');
+ RegisterPropertyHelper(@TIBTABLEMASTERSOURCE_R,@TIBTABLEMASTERSOURCE_W,'MASTERSOURCE');
+ RegisterPropertyHelper(@TIBTABLEREADONLY_R,@TIBTABLEREADONLY_W,'READONLY');
+ RegisterPropertyHelper(@TIBTABLESTOREDEFS_R,@TIBTABLESTOREDEFS_W,'STOREDEFS');
+ RegisterPropertyHelper(@TIBTABLETABLENAME_R,@TIBTABLETABLENAME_W,'TABLENAME');
+ RegisterPropertyHelper(@TIBTABLETABLETYPES_R,@TIBTABLETABLETYPES_W,'TABLETYPES');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_IBTable(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TIBTABLE) do
+ RIRegister_TIBTABLE(CL);
+end;
+
+(* === compile-time registration functions === *)
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TIBSQL(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TCOMPONENT', 'TIBSQL') do
+ with CL.AddClassN(CL.FindClass('TCOMPONENT'),'TIBSQL') do
+ begin
+ RegisterMethod('Procedure BATCHINPUT( INPUTOBJECT : TIBBATCHINPUT)');
+ RegisterMethod('Procedure BATCHOUTPUT( OUTPUTOBJECT : TIBBATCHOUTPUT)');
+ RegisterMethod('Function CALL( ERRCODE : ISC_STATUS; RAISEERROR : BOOLEAN) : ISC_STATUS');
+ RegisterMethod('Procedure CHECKCLOSED');
+ RegisterMethod('Procedure CHECKOPEN');
+ RegisterMethod('Procedure CHECKVALIDSTATEMENT');
+ RegisterMethod('Procedure CLOSE');
+ RegisterMethod('Function CURRENT : TIBXSQLDA');
+ RegisterMethod('Procedure EXECQUERY');
+ RegisterMethod('Function FIELDBYNAME( FIELDNAME : STRING) : TIBXSQLVAR');
+ RegisterMethod('Procedure FREEHANDLE');
+ RegisterMethod('Function NEXT : TIBXSQLDA');
+ RegisterMethod('Procedure PREPARE');
+ RegisterMethod('Function GETUNIQUERELATIONNAME : STRING');
+ RegisterMethod('Function PARAMBYNAME( IDX : STRING) : TIBXSQLVAR');
+ RegisterProperty('BOF', 'BOOLEAN', iptr);
+ RegisterProperty('DBHANDLE', 'PISC_DB_HANDLE', iptr);
+ RegisterProperty('EOF', 'BOOLEAN', iptr);
+ RegisterProperty('FIELDS', 'TIBXSQLVAR INTEGER', iptr);
+ RegisterProperty('FIELDINDEX', 'INTEGER STRING', iptr);
+ RegisterProperty('OPEN', 'BOOLEAN', iptr);
+ RegisterProperty('PARAMS', 'TIBXSQLDA', iptr);
+ RegisterProperty('PLAN', 'STRING', iptr);
+ RegisterProperty('PREPARED', 'BOOLEAN', iptr);
+ RegisterProperty('RECORDCOUNT', 'INTEGER', iptr);
+ RegisterProperty('ROWSAFFECTED', 'INTEGER', iptr);
+ RegisterProperty('SQLTYPE', 'TIBSQLTYPES', iptr);
+ RegisterProperty('TRHANDLE', 'PISC_TR_HANDLE', iptr);
+ RegisterProperty('HANDLE', 'TISC_STMT_HANDLE', iptr);
+ RegisterProperty('GENERATEPARAMNAMES', 'BOOLEAN', iptrw);
+ RegisterProperty('UNIQUERELATIONNAME', 'STRING', iptr);
+ RegisterProperty('DATABASE', 'TIBDATABASE', iptrw);
+ RegisterProperty('GOTOFIRSTRECORDONEXECUTE', 'BOOLEAN', iptrw);
+ RegisterProperty('PARAMCHECK', 'BOOLEAN', iptrw);
+ RegisterProperty('SQL', 'TSTRINGS', iptrw);
+ RegisterProperty('TRANSACTION', 'TIBTRANSACTION', iptrw);
+ RegisterProperty('ONSQLCHANGING', 'TNOTIFYEVENT', iptrw);
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TIBOUTPUTXML(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TOBJECT', 'TIBOUTPUTXML') do
+ with CL.AddClassN(CL.FindClass('TOBJECT'),'TIBOUTPUTXML') do
+ begin
+ RegisterMethod('Procedure WRITEXML( SQL : TIBSQL)');
+ RegisterProperty('HEADERTAG', 'STRING', iptrw);
+ RegisterProperty('DATABASETAG', 'STRING', iptrw);
+ RegisterProperty('STREAM', 'TSTREAM', iptrw);
+ RegisterProperty('TABLETAG', 'STRING', iptrw);
+ RegisterProperty('ROWTAG', 'STRING', iptrw);
+ RegisterProperty('FLAGS', 'TIBXMLFLAGS', iptrw);
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TIBINPUTRAWFILE(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TIBBATCHINPUT', 'TIBINPUTRAWFILE') do
+ with CL.AddClassN(CL.FindClass('TIBBATCHINPUT'),'TIBINPUTRAWFILE') do
+ begin
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TIBOUTPUTRAWFILE(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TIBBATCHOUTPUT', 'TIBOUTPUTRAWFILE') do
+ with CL.AddClassN(CL.FindClass('TIBBATCHOUTPUT'),'TIBOUTPUTRAWFILE') do
+ begin
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TIBINPUTDELIMITEDFILE(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TIBBATCHINPUT', 'TIBINPUTDELIMITEDFILE') do
+ with CL.AddClassN(CL.FindClass('TIBBATCHINPUT'),'TIBINPUTDELIMITEDFILE') do
+ begin
+ RegisterMethod('Function GETCOLUMN( var COL : STRING) : INTEGER');
+ RegisterProperty('COLDELIMITER', 'STRING', iptrw);
+ RegisterProperty('READBLANKSASNULL', 'BOOLEAN', iptrw);
+ RegisterProperty('ROWDELIMITER', 'STRING', iptrw);
+ RegisterProperty('SKIPTITLES', 'BOOLEAN', iptrw);
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TIBOUTPUTDELIMITEDFILE(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TIBBATCHOUTPUT', 'TIBOUTPUTDELIMITEDFILE') do
+ with CL.AddClassN(CL.FindClass('TIBBATCHOUTPUT'),'TIBOUTPUTDELIMITEDFILE') do
+ begin
+ RegisterProperty('COLDELIMITER', 'STRING', iptrw);
+ RegisterProperty('OUTPUTTITLES', 'BOOLEAN', iptrw);
+ RegisterProperty('ROWDELIMITER', 'STRING', iptrw);
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TIBBATCHOUTPUT(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TIBBATCH', 'TIBBATCHOUTPUT') do
+ with CL.AddClassN(CL.FindClass('TIBBATCH'),'TIBBATCHOUTPUT') do
+ begin
+ RegisterMethod('Function WRITECOLUMNS : BOOLEAN');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TIBBATCHINPUT(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TIBBATCH', 'TIBBATCHINPUT') do
+ with CL.AddClassN(CL.FindClass('TIBBATCH'),'TIBBATCHINPUT') do
+ begin
+ RegisterMethod('Function READPARAMETERS : BOOLEAN');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TIBBATCH(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TOBJECT', 'TIBBATCH') do
+ with CL.AddClassN(CL.FindClass('TOBJECT'),'TIBBATCH') do
+ begin
+ RegisterMethod('Procedure READYFILE');
+ RegisterProperty('COLUMNS', 'TIBXSQLDA', iptrw);
+ RegisterProperty('FILENAME', 'STRING', iptrw);
+ RegisterProperty('PARAMS', 'TIBXSQLDA', iptrw);
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TIBXSQLDA(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TOBJECT', 'TIBXSQLDA') do
+ with CL.AddClassN(CL.FindClass('TOBJECT'),'TIBXSQLDA') do
+ begin
+ RegisterMethod('Constructor CREATE( QUERY : TIBSQL)');
+ RegisterMethod('Procedure ADDNAME( FIELDNAME : STRING; IDX : INTEGER)');
+ RegisterMethod('Function BYNAME( IDX : STRING) : TIBXSQLVAR');
+ RegisterProperty('ASXSQLDA', 'PXSQLDA', iptr);
+ RegisterProperty('COUNT', 'INTEGER', iptrw);
+ RegisterProperty('MODIFIED', 'BOOLEAN', iptr);
+ RegisterProperty('NAMES', 'STRING', iptr);
+ RegisterProperty('RECORDSIZE', 'INTEGER', iptr);
+ RegisterProperty('VARS', 'TIBXSQLVAR INTEGER', iptr);
+ SetDefaultPropery('VARS');
+ RegisterProperty('UNIQUERELATIONNAME', 'STRING', iptr);
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TIBXSQLVAR(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TOBJECT', 'TIBXSQLVAR') do
+ with CL.AddClassN(CL.FindClass('TOBJECT'),'TIBXSQLVAR') do
+ begin
+ RegisterMethod('Constructor CREATE( PARENT : TIBXSQLDA; QUERY : TIBSQL)');
+ RegisterMethod('Procedure ASSIGN( SOURCE : TIBXSQLVAR)');
+ RegisterMethod('Procedure LOADFROMFILE( const FILENAME : STRING)');
+ RegisterMethod('Procedure LOADFROMSTREAM( STREAM : TSTREAM)');
+ RegisterMethod('Procedure SAVETOFILE( const FILENAME : STRING)');
+ RegisterMethod('Procedure SAVETOSTREAM( STREAM : TSTREAM)');
+ RegisterMethod('Procedure CLEAR');
+ RegisterProperty('ASDATE', 'TDATETIME', iptrw);
+ RegisterProperty('ASTIME', 'TDATETIME', iptrw);
+ RegisterProperty('ASDATETIME', 'TDATETIME', iptrw);
+ RegisterProperty('ASDOUBLE', 'DOUBLE', iptrw);
+ RegisterProperty('ASFLOAT', 'FLOAT', iptrw);
+ RegisterProperty('ASCURRENCY', 'CURRENCY', iptrw);
+ RegisterProperty('ASINT64', 'INT64', iptrw);
+ RegisterProperty('ASINTEGER', 'INTEGER', iptrw);
+ RegisterProperty('ASLONG', 'LONG', iptrw);
+ RegisterProperty('ASPOINTER', 'POINTER', iptrw);
+ RegisterProperty('ASQUAD', 'TISC_QUAD', iptrw);
+ RegisterProperty('ASSHORT', 'SHORT', iptrw);
+ RegisterProperty('ASSTRING', 'STRING', iptrw);
+ RegisterProperty('ASTRIMSTRING', 'STRING', iptrw);
+ RegisterProperty('ASVARIANT', 'VARIANT', iptrw);
+ RegisterProperty('ASXSQLVAR', 'PXSQLVAR', iptrw);
+ RegisterProperty('DATA', 'PXSQLVAR', iptrw);
+ RegisterProperty('ISNULL', 'BOOLEAN', iptrw);
+ RegisterProperty('ISNULLABLE', 'BOOLEAN', iptrw);
+ RegisterProperty('INDEX', 'INTEGER', iptr);
+ RegisterProperty('MODIFIED', 'BOOLEAN', iptrw);
+ RegisterProperty('NAME', 'STRING', iptr);
+ RegisterProperty('SIZE', 'INTEGER', iptr);
+ RegisterProperty('SQLTYPE', 'INTEGER', iptr);
+ RegisterProperty('VALUE', 'VARIANT', iptrw);
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_IBSQL(CL: TPSPascalCompiler);
+begin
+ CL.AddClassN(CL.FindClass('TOBJECT'),'TIBSQL');
+ CL.AddClassN(CL.FindClass('TOBJECT'),'TIBXSQLDA');
+ SIRegister_TIBXSQLVAR(CL);
+ CL.AddTypeS('TIBXSQLVARARRAY', 'array of TIBXSQLVAR');
+ SIRegister_TIBXSQLDA(CL);
+ SIRegister_TIBBATCH(CL);
+ SIRegister_TIBBATCHINPUT(CL);
+ SIRegister_TIBBATCHOUTPUT(CL);
+ SIRegister_TIBOUTPUTDELIMITEDFILE(CL);
+ SIRegister_TIBINPUTDELIMITEDFILE(CL);
+ SIRegister_TIBOUTPUTRAWFILE(CL);
+ SIRegister_TIBINPUTRAWFILE(CL);
+ CL.AddTypeS('TIBXMLFLAG', '( XMLATTRIBUTE, XMLDISPLAYNULL, XMLNOHEADER )');
+ CL.AddTypeS('TIBXMLFLAGS', 'set of TIBXMLFLAG');
+ SIRegister_TIBOUTPUTXML(CL);
+ CL.AddTypeS('TIBSQLTYPES', '( SQLUNKNOWN, SQLSELECT, SQLINSERT, SQLUPDATE, SQ'
+ +'LDELETE, SQLDDL, SQLGETSEGMENT, SQLPUTSEGMENT, SQLEXECPROCEDURE, SQLSTARTT'
+ +'RANSACTION, SQLCOMMIT, SQLROLLBACK, SQLSELECTFORUPDATE, SQLSETGENERATOR )');
+ SIRegister_TIBSQL(CL);
+ CL.AddDelphiFunction('Procedure OUTPUTXML( SQLOBJECT : TIBSQL; OUTPUTOBJECT : TIBOUTPUTXML)');
+end;
+
+(* === run-time registration functions === *)
+(*----------------------------------------------------------------------------*)
+procedure TIBSQLONSQLCHANGING_W(Self: TIBSQL; const T: TNOTIFYEVENT);
+begin Self.ONSQLCHANGING := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBSQLONSQLCHANGING_R(Self: TIBSQL; var T: TNOTIFYEVENT);
+begin T := Self.ONSQLCHANGING; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBSQLTRANSACTION_W(Self: TIBSQL; const T: TIBTRANSACTION);
+begin Self.TRANSACTION := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBSQLTRANSACTION_R(Self: TIBSQL; var T: TIBTRANSACTION);
+begin T := Self.TRANSACTION; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBSQLSQL_W(Self: TIBSQL; const T: TSTRINGS);
+begin Self.SQL := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBSQLSQL_R(Self: TIBSQL; var T: TSTRINGS);
+begin T := Self.SQL; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBSQLPARAMCHECK_W(Self: TIBSQL; const T: BOOLEAN);
+begin Self.PARAMCHECK := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBSQLPARAMCHECK_R(Self: TIBSQL; var T: BOOLEAN);
+begin T := Self.PARAMCHECK; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBSQLGOTOFIRSTRECORDONEXECUTE_W(Self: TIBSQL; const T: BOOLEAN);
+begin Self.GOTOFIRSTRECORDONEXECUTE := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBSQLGOTOFIRSTRECORDONEXECUTE_R(Self: TIBSQL; var T: BOOLEAN);
+begin T := Self.GOTOFIRSTRECORDONEXECUTE; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBSQLDATABASE_W(Self: TIBSQL; const T: TIBDATABASE);
+begin Self.DATABASE := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBSQLDATABASE_R(Self: TIBSQL; var T: TIBDATABASE);
+begin T := Self.DATABASE; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBSQLUNIQUERELATIONNAME_R(Self: TIBSQL; var T: STRING);
+begin T := Self.UNIQUERELATIONNAME; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBSQLGENERATEPARAMNAMES_W(Self: TIBSQL; const T: BOOLEAN);
+begin Self.GENERATEPARAMNAMES := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBSQLGENERATEPARAMNAMES_R(Self: TIBSQL; var T: BOOLEAN);
+begin T := Self.GENERATEPARAMNAMES; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBSQLHANDLE_R(Self: TIBSQL; var T: TISC_STMT_HANDLE);
+begin T := Self.HANDLE; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBSQLTRHANDLE_R(Self: TIBSQL; var T: PISC_TR_HANDLE);
+begin T := Self.TRHANDLE; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBSQLSQLTYPE_R(Self: TIBSQL; var T: TIBSQLTYPES);
+begin T := Self.SQLTYPE; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBSQLROWSAFFECTED_R(Self: TIBSQL; var T: INTEGER);
+begin T := Self.ROWSAFFECTED; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBSQLRECORDCOUNT_R(Self: TIBSQL; var T: INTEGER);
+begin T := Self.RECORDCOUNT; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBSQLPREPARED_R(Self: TIBSQL; var T: BOOLEAN);
+begin T := Self.PREPARED; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBSQLPLAN_R(Self: TIBSQL; var T: STRING);
+begin T := Self.PLAN; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBSQLPARAMS_R(Self: TIBSQL; var T: TIBXSQLDA);
+begin T := Self.PARAMS; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBSQLOPEN_R(Self: TIBSQL; var T: BOOLEAN);
+begin T := Self.OPEN; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBSQLFIELDINDEX_R(Self: TIBSQL; var T: INTEGER; const t1: STRING);
+begin T := Self.FIELDINDEX[t1]; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBSQLFIELDS_R(Self: TIBSQL; var T: TIBXSQLVAR; const t1: INTEGER);
+begin T := Self.FIELDS[t1]; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBSQLEOF_R(Self: TIBSQL; var T: BOOLEAN);
+begin T := Self.EOF; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBSQLDBHANDLE_R(Self: TIBSQL; var T: PISC_DB_HANDLE);
+begin T := Self.DBHANDLE; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBSQLBOF_R(Self: TIBSQL; var T: BOOLEAN);
+begin T := Self.BOF; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBOUTPUTXMLFLAGS_W(Self: TIBOUTPUTXML; const T: TIBXMLFLAGS);
+begin Self.FLAGS := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBOUTPUTXMLFLAGS_R(Self: TIBOUTPUTXML; var T: TIBXMLFLAGS);
+begin T := Self.FLAGS; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBOUTPUTXMLROWTAG_W(Self: TIBOUTPUTXML; const T: STRING);
+begin Self.ROWTAG := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBOUTPUTXMLROWTAG_R(Self: TIBOUTPUTXML; var T: STRING);
+begin T := Self.ROWTAG; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBOUTPUTXMLTABLETAG_W(Self: TIBOUTPUTXML; const T: STRING);
+begin Self.TABLETAG := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBOUTPUTXMLTABLETAG_R(Self: TIBOUTPUTXML; var T: STRING);
+begin T := Self.TABLETAG; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBOUTPUTXMLSTREAM_W(Self: TIBOUTPUTXML; const T: TSTREAM);
+begin Self.STREAM := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBOUTPUTXMLSTREAM_R(Self: TIBOUTPUTXML; var T: TSTREAM);
+begin T := Self.STREAM; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBOUTPUTXMLDATABASETAG_W(Self: TIBOUTPUTXML; const T: STRING);
+begin Self.DATABASETAG := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBOUTPUTXMLDATABASETAG_R(Self: TIBOUTPUTXML; var T: STRING);
+begin T := Self.DATABASETAG; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBOUTPUTXMLHEADERTAG_W(Self: TIBOUTPUTXML; const T: STRING);
+begin Self.HEADERTAG := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBOUTPUTXMLHEADERTAG_R(Self: TIBOUTPUTXML; var T: STRING);
+begin T := Self.HEADERTAG; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBINPUTDELIMITEDFILESKIPTITLES_W(Self: TIBINPUTDELIMITEDFILE; const T: BOOLEAN);
+begin Self.SKIPTITLES := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBINPUTDELIMITEDFILESKIPTITLES_R(Self: TIBINPUTDELIMITEDFILE; var T: BOOLEAN);
+begin T := Self.SKIPTITLES; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBINPUTDELIMITEDFILEROWDELIMITER_W(Self: TIBINPUTDELIMITEDFILE; const T: STRING);
+begin Self.ROWDELIMITER := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBINPUTDELIMITEDFILEROWDELIMITER_R(Self: TIBINPUTDELIMITEDFILE; var T: STRING);
+begin T := Self.ROWDELIMITER; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBINPUTDELIMITEDFILEREADBLANKSASNULL_W(Self: TIBINPUTDELIMITEDFILE; const T: BOOLEAN);
+begin Self.READBLANKSASNULL := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBINPUTDELIMITEDFILEREADBLANKSASNULL_R(Self: TIBINPUTDELIMITEDFILE; var T: BOOLEAN);
+begin T := Self.READBLANKSASNULL; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBINPUTDELIMITEDFILECOLDELIMITER_W(Self: TIBINPUTDELIMITEDFILE; const T: STRING);
+begin Self.COLDELIMITER := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBINPUTDELIMITEDFILECOLDELIMITER_R(Self: TIBINPUTDELIMITEDFILE; var T: STRING);
+begin T := Self.COLDELIMITER; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBOUTPUTDELIMITEDFILEROWDELIMITER_W(Self: TIBOUTPUTDELIMITEDFILE; const T: STRING);
+begin Self.ROWDELIMITER := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBOUTPUTDELIMITEDFILEROWDELIMITER_R(Self: TIBOUTPUTDELIMITEDFILE; var T: STRING);
+begin T := Self.ROWDELIMITER; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBOUTPUTDELIMITEDFILEOUTPUTTITLES_W(Self: TIBOUTPUTDELIMITEDFILE; const T: BOOLEAN);
+begin Self.OUTPUTTITLES := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBOUTPUTDELIMITEDFILEOUTPUTTITLES_R(Self: TIBOUTPUTDELIMITEDFILE; var T: BOOLEAN);
+begin T := Self.OUTPUTTITLES; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBOUTPUTDELIMITEDFILECOLDELIMITER_W(Self: TIBOUTPUTDELIMITEDFILE; const T: STRING);
+begin Self.COLDELIMITER := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBOUTPUTDELIMITEDFILECOLDELIMITER_R(Self: TIBOUTPUTDELIMITEDFILE; var T: STRING);
+begin T := Self.COLDELIMITER; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLDAUNIQUERELATIONNAME_R(Self: TIBXSQLDA; var T: STRING);
+begin T := Self.UNIQUERELATIONNAME; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLDAVARS_R(Self: TIBXSQLDA; var T: TIBXSQLVAR; const t1: INTEGER);
+begin T := Self.VARS[t1]; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLDARECORDSIZE_R(Self: TIBXSQLDA; var T: INTEGER);
+begin T := Self.RECORDSIZE; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLDANAMES_R(Self: TIBXSQLDA; var T: STRING);
+begin T := Self.NAMES; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLDAMODIFIED_R(Self: TIBXSQLDA; var T: BOOLEAN);
+begin T := Self.MODIFIED; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLDACOUNT_W(Self: TIBXSQLDA; const T: INTEGER);
+begin Self.COUNT := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLDACOUNT_R(Self: TIBXSQLDA; var T: INTEGER);
+begin T := Self.COUNT; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLDAASXSQLDA_R(Self: TIBXSQLDA; var T: PXSQLDA);
+begin T := Self.ASXSQLDA; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARVALUE_W(Self: TIBXSQLVAR; const T: VARIANT);
+begin Self.VALUE := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARVALUE_R(Self: TIBXSQLVAR; var T: VARIANT);
+begin T := Self.VALUE; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARSQLTYPE_R(Self: TIBXSQLVAR; var T: INTEGER);
+begin T := Self.SQLTYPE; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARSIZE_R(Self: TIBXSQLVAR; var T: INTEGER);
+begin T := Self.SIZE; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARNAME_R(Self: TIBXSQLVAR; var T: STRING);
+begin T := Self.NAME; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARMODIFIED_W(Self: TIBXSQLVAR; const T: BOOLEAN);
+begin Self.MODIFIED := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARMODIFIED_R(Self: TIBXSQLVAR; var T: BOOLEAN);
+begin T := Self.MODIFIED; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARINDEX_R(Self: TIBXSQLVAR; var T: INTEGER);
+begin T := Self.INDEX; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARISNULLABLE_W(Self: TIBXSQLVAR; const T: BOOLEAN);
+begin Self.ISNULLABLE := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARISNULLABLE_R(Self: TIBXSQLVAR; var T: BOOLEAN);
+begin T := Self.ISNULLABLE; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARISNULL_W(Self: TIBXSQLVAR; const T: BOOLEAN);
+begin Self.ISNULL := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARISNULL_R(Self: TIBXSQLVAR; var T: BOOLEAN);
+begin T := Self.ISNULL; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARDATA_W(Self: TIBXSQLVAR; const T: PXSQLVAR);
+begin Self.DATA := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARDATA_R(Self: TIBXSQLVAR; var T: PXSQLVAR);
+begin T := Self.DATA; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASXSQLVAR_W(Self: TIBXSQLVAR; const T: PXSQLVAR);
+begin Self.ASXSQLVAR := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASXSQLVAR_R(Self: TIBXSQLVAR; var T: PXSQLVAR);
+begin T := Self.ASXSQLVAR; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASVARIANT_W(Self: TIBXSQLVAR; const T: VARIANT);
+begin Self.ASVARIANT := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASVARIANT_R(Self: TIBXSQLVAR; var T: VARIANT);
+begin T := Self.ASVARIANT; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASTRIMSTRING_W(Self: TIBXSQLVAR; const T: STRING);
+begin Self.ASTRIMSTRING := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASTRIMSTRING_R(Self: TIBXSQLVAR; var T: STRING);
+begin T := Self.ASTRIMSTRING; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASSTRING_W(Self: TIBXSQLVAR; const T: STRING);
+begin Self.ASSTRING := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASSTRING_R(Self: TIBXSQLVAR; var T: STRING);
+begin T := Self.ASSTRING; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASSHORT_W(Self: TIBXSQLVAR; const T: SHORT);
+begin Self.ASSHORT := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASSHORT_R(Self: TIBXSQLVAR; var T: SHORT);
+begin T := Self.ASSHORT; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASQUAD_W(Self: TIBXSQLVAR; const T: TISC_QUAD);
+begin Self.ASQUAD := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASQUAD_R(Self: TIBXSQLVAR; var T: TISC_QUAD);
+begin T := Self.ASQUAD; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASPOINTER_W(Self: TIBXSQLVAR; const T: POINTER);
+begin Self.ASPOINTER := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASPOINTER_R(Self: TIBXSQLVAR; var T: POINTER);
+begin T := Self.ASPOINTER; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASLONG_W(Self: TIBXSQLVAR; const T: LONG);
+begin Self.ASLONG := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASLONG_R(Self: TIBXSQLVAR; var T: LONG);
+begin T := Self.ASLONG; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASINTEGER_W(Self: TIBXSQLVAR; const T: INTEGER);
+begin Self.ASINTEGER := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASINTEGER_R(Self: TIBXSQLVAR; var T: INTEGER);
+begin T := Self.ASINTEGER; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASINT64_W(Self: TIBXSQLVAR; const T: INT64);
+begin Self.ASINT64 := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASINT64_R(Self: TIBXSQLVAR; var T: INT64);
+begin T := Self.ASINT64; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASCURRENCY_W(Self: TIBXSQLVAR; const T: CURRENCY);
+begin Self.ASCURRENCY := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASCURRENCY_R(Self: TIBXSQLVAR; var T: CURRENCY);
+begin T := Self.ASCURRENCY; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASFLOAT_W(Self: TIBXSQLVAR; const T: FLOAT);
+begin Self.ASFLOAT := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASFLOAT_R(Self: TIBXSQLVAR; var T: FLOAT);
+begin T := Self.ASFLOAT; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASDOUBLE_W(Self: TIBXSQLVAR; const T: DOUBLE);
+begin Self.ASDOUBLE := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASDOUBLE_R(Self: TIBXSQLVAR; var T: DOUBLE);
+begin T := Self.ASDOUBLE; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASDATETIME_W(Self: TIBXSQLVAR; const T: TDATETIME);
+begin Self.ASDATETIME := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASDATETIME_R(Self: TIBXSQLVAR; var T: TDATETIME);
+begin T := Self.ASDATETIME; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASTIME_W(Self: TIBXSQLVAR; const T: TDATETIME);
+begin Self.ASTIME := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASTIME_R(Self: TIBXSQLVAR; var T: TDATETIME);
+begin T := Self.ASTIME; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASDATE_W(Self: TIBXSQLVAR; const T: TDATETIME);
+begin Self.ASDATE := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBXSQLVARASDATE_R(Self: TIBXSQLVAR; var T: TDATETIME);
+begin T := Self.ASDATE; end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_IBSQL_Routines(S: TIFPSExec);
+begin
+ S.RegisterDelphiFunction(@OUTPUTXML, 'OUTPUTXML', cdRegister);
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TIBSQL(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TIBSQL) do
+ begin
+ RegisterMethod(@TIBSQL.BATCHINPUT, 'BATCHINPUT');
+ RegisterMethod(@TIBSQL.BATCHOUTPUT, 'BATCHOUTPUT');
+ RegisterMethod(@TIBSQL.CALL, 'CALL');
+ RegisterMethod(@TIBSQL.CHECKCLOSED, 'CHECKCLOSED');
+ RegisterMethod(@TIBSQL.CHECKOPEN, 'CHECKOPEN');
+ RegisterMethod(@TIBSQL.CHECKVALIDSTATEMENT, 'CHECKVALIDSTATEMENT');
+ RegisterMethod(@TIBSQL.CLOSE, 'CLOSE');
+ RegisterMethod(@TIBSQL.CURRENT, 'CURRENT');
+ RegisterMethod(@TIBSQL.EXECQUERY, 'EXECQUERY');
+ RegisterMethod(@TIBSQL.FIELDBYNAME, 'FIELDBYNAME');
+ RegisterMethod(@TIBSQL.FREEHANDLE, 'FREEHANDLE');
+ RegisterMethod(@TIBSQL.NEXT, 'NEXT');
+ RegisterMethod(@TIBSQL.PREPARE, 'PREPARE');
+ RegisterMethod(@TIBSQL.GETUNIQUERELATIONNAME, 'GETUNIQUERELATIONNAME');
+ RegisterMethod(@TIBSQL.PARAMBYNAME, 'PARAMBYNAME');
+ RegisterPropertyHelper(@TIBSQLBOF_R,nil,'BOF');
+ RegisterPropertyHelper(@TIBSQLDBHANDLE_R,nil,'DBHANDLE');
+ RegisterPropertyHelper(@TIBSQLEOF_R,nil,'EOF');
+ RegisterPropertyHelper(@TIBSQLFIELDS_R,nil,'FIELDS');
+ RegisterPropertyHelper(@TIBSQLFIELDINDEX_R,nil,'FIELDINDEX');
+ RegisterPropertyHelper(@TIBSQLOPEN_R,nil,'OPEN');
+ RegisterPropertyHelper(@TIBSQLPARAMS_R,nil,'PARAMS');
+ RegisterPropertyHelper(@TIBSQLPLAN_R,nil,'PLAN');
+ RegisterPropertyHelper(@TIBSQLPREPARED_R,nil,'PREPARED');
+ RegisterPropertyHelper(@TIBSQLRECORDCOUNT_R,nil,'RECORDCOUNT');
+ RegisterPropertyHelper(@TIBSQLROWSAFFECTED_R,nil,'ROWSAFFECTED');
+ RegisterPropertyHelper(@TIBSQLSQLTYPE_R,nil,'SQLTYPE');
+ RegisterPropertyHelper(@TIBSQLTRHANDLE_R,nil,'TRHANDLE');
+ RegisterPropertyHelper(@TIBSQLHANDLE_R,nil,'HANDLE');
+ RegisterPropertyHelper(@TIBSQLGENERATEPARAMNAMES_R,@TIBSQLGENERATEPARAMNAMES_W,'GENERATEPARAMNAMES');
+ RegisterPropertyHelper(@TIBSQLUNIQUERELATIONNAME_R,nil,'UNIQUERELATIONNAME');
+ RegisterPropertyHelper(@TIBSQLDATABASE_R,@TIBSQLDATABASE_W,'DATABASE');
+ RegisterPropertyHelper(@TIBSQLGOTOFIRSTRECORDONEXECUTE_R,@TIBSQLGOTOFIRSTRECORDONEXECUTE_W,'GOTOFIRSTRECORDONEXECUTE');
+ RegisterPropertyHelper(@TIBSQLPARAMCHECK_R,@TIBSQLPARAMCHECK_W,'PARAMCHECK');
+ RegisterPropertyHelper(@TIBSQLSQL_R,@TIBSQLSQL_W,'SQL');
+ RegisterPropertyHelper(@TIBSQLTRANSACTION_R,@TIBSQLTRANSACTION_W,'TRANSACTION');
+ RegisterEventPropertyHelper(@TIBSQLONSQLCHANGING_R,@TIBSQLONSQLCHANGING_W,'ONSQLCHANGING');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TIBOUTPUTXML(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TIBOUTPUTXML) do
+ begin
+ RegisterMethod(@TIBOUTPUTXML.WRITEXML, 'WRITEXML');
+ RegisterPropertyHelper(@TIBOUTPUTXMLHEADERTAG_R,@TIBOUTPUTXMLHEADERTAG_W,'HEADERTAG');
+ RegisterPropertyHelper(@TIBOUTPUTXMLDATABASETAG_R,@TIBOUTPUTXMLDATABASETAG_W,'DATABASETAG');
+ RegisterPropertyHelper(@TIBOUTPUTXMLSTREAM_R,@TIBOUTPUTXMLSTREAM_W,'STREAM');
+ RegisterPropertyHelper(@TIBOUTPUTXMLTABLETAG_R,@TIBOUTPUTXMLTABLETAG_W,'TABLETAG');
+ RegisterPropertyHelper(@TIBOUTPUTXMLROWTAG_R,@TIBOUTPUTXMLROWTAG_W,'ROWTAG');
+ RegisterPropertyHelper(@TIBOUTPUTXMLFLAGS_R,@TIBOUTPUTXMLFLAGS_W,'FLAGS');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TIBINPUTRAWFILE(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TIBINPUTRAWFILE) do
+ begin
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TIBOUTPUTRAWFILE(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TIBOUTPUTRAWFILE) do
+ begin
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TIBINPUTDELIMITEDFILE(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TIBINPUTDELIMITEDFILE) do
+ begin
+ RegisterMethod(@TIBINPUTDELIMITEDFILE.GETCOLUMN, 'GETCOLUMN');
+ RegisterPropertyHelper(@TIBINPUTDELIMITEDFILECOLDELIMITER_R,@TIBINPUTDELIMITEDFILECOLDELIMITER_W,'COLDELIMITER');
+ RegisterPropertyHelper(@TIBINPUTDELIMITEDFILEREADBLANKSASNULL_R,@TIBINPUTDELIMITEDFILEREADBLANKSASNULL_W,'READBLANKSASNULL');
+ RegisterPropertyHelper(@TIBINPUTDELIMITEDFILEROWDELIMITER_R,@TIBINPUTDELIMITEDFILEROWDELIMITER_W,'ROWDELIMITER');
+ RegisterPropertyHelper(@TIBINPUTDELIMITEDFILESKIPTITLES_R,@TIBINPUTDELIMITEDFILESKIPTITLES_W,'SKIPTITLES');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TIBOUTPUTDELIMITEDFILE(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TIBOUTPUTDELIMITEDFILE) do
+ begin
+ RegisterPropertyHelper(@TIBOUTPUTDELIMITEDFILECOLDELIMITER_R,@TIBOUTPUTDELIMITEDFILECOLDELIMITER_W,'COLDELIMITER');
+ RegisterPropertyHelper(@TIBOUTPUTDELIMITEDFILEOUTPUTTITLES_R,@TIBOUTPUTDELIMITEDFILEOUTPUTTITLES_W,'OUTPUTTITLES');
+ RegisterPropertyHelper(@TIBOUTPUTDELIMITEDFILEROWDELIMITER_R,@TIBOUTPUTDELIMITEDFILEROWDELIMITER_W,'ROWDELIMITER');
+ end;
+end;
+
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TIBXSQLDA(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TIBXSQLDA) do
+ begin
+ RegisterConstructor(@TIBXSQLDA.CREATE, 'CREATE');
+ RegisterMethod(@TIBXSQLDA.ADDNAME, 'ADDNAME');
+ RegisterMethod(@TIBXSQLDA.BYNAME, 'BYNAME');
+ RegisterPropertyHelper(@TIBXSQLDAASXSQLDA_R,nil,'ASXSQLDA');
+ RegisterPropertyHelper(@TIBXSQLDACOUNT_R,@TIBXSQLDACOUNT_W,'COUNT');
+ RegisterPropertyHelper(@TIBXSQLDAMODIFIED_R,nil,'MODIFIED');
+ RegisterPropertyHelper(@TIBXSQLDANAMES_R,nil,'NAMES');
+ RegisterPropertyHelper(@TIBXSQLDARECORDSIZE_R,nil,'RECORDSIZE');
+ RegisterPropertyHelper(@TIBXSQLDAVARS_R,nil,'VARS');
+ RegisterPropertyHelper(@TIBXSQLDAUNIQUERELATIONNAME_R,nil,'UNIQUERELATIONNAME');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TIBXSQLVAR(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TIBXSQLVAR) do
+ begin
+ RegisterConstructor(@TIBXSQLVAR.CREATE, 'CREATE');
+ RegisterMethod(@TIBXSQLVAR.ASSIGN, 'ASSIGN');
+ RegisterMethod(@TIBXSQLVAR.LOADFROMFILE, 'LOADFROMFILE');
+ RegisterMethod(@TIBXSQLVAR.LOADFROMSTREAM, 'LOADFROMSTREAM');
+ RegisterMethod(@TIBXSQLVAR.SAVETOFILE, 'SAVETOFILE');
+ RegisterMethod(@TIBXSQLVAR.SAVETOSTREAM, 'SAVETOSTREAM');
+ RegisterMethod(@TIBXSQLVAR.CLEAR, 'CLEAR');
+ RegisterPropertyHelper(@TIBXSQLVARASDATE_R,@TIBXSQLVARASDATE_W,'ASDATE');
+ RegisterPropertyHelper(@TIBXSQLVARASTIME_R,@TIBXSQLVARASTIME_W,'ASTIME');
+ RegisterPropertyHelper(@TIBXSQLVARASDATETIME_R,@TIBXSQLVARASDATETIME_W,'ASDATETIME');
+ RegisterPropertyHelper(@TIBXSQLVARASDOUBLE_R,@TIBXSQLVARASDOUBLE_W,'ASDOUBLE');
+ RegisterPropertyHelper(@TIBXSQLVARASFLOAT_R,@TIBXSQLVARASFLOAT_W,'ASFLOAT');
+ RegisterPropertyHelper(@TIBXSQLVARASCURRENCY_R,@TIBXSQLVARASCURRENCY_W,'ASCURRENCY');
+ RegisterPropertyHelper(@TIBXSQLVARASINT64_R,@TIBXSQLVARASINT64_W,'ASINT64');
+ RegisterPropertyHelper(@TIBXSQLVARASINTEGER_R,@TIBXSQLVARASINTEGER_W,'ASINTEGER');
+ RegisterPropertyHelper(@TIBXSQLVARASLONG_R,@TIBXSQLVARASLONG_W,'ASLONG');
+ RegisterPropertyHelper(@TIBXSQLVARASPOINTER_R,@TIBXSQLVARASPOINTER_W,'ASPOINTER');
+ RegisterPropertyHelper(@TIBXSQLVARASQUAD_R,@TIBXSQLVARASQUAD_W,'ASQUAD');
+ RegisterPropertyHelper(@TIBXSQLVARASSHORT_R,@TIBXSQLVARASSHORT_W,'ASSHORT');
+ RegisterPropertyHelper(@TIBXSQLVARASSTRING_R,@TIBXSQLVARASSTRING_W,'ASSTRING');
+ RegisterPropertyHelper(@TIBXSQLVARASTRIMSTRING_R,@TIBXSQLVARASTRIMSTRING_W,'ASTRIMSTRING');
+ RegisterPropertyHelper(@TIBXSQLVARASVARIANT_R,@TIBXSQLVARASVARIANT_W,'ASVARIANT');
+ RegisterPropertyHelper(@TIBXSQLVARASXSQLVAR_R,@TIBXSQLVARASXSQLVAR_W,'ASXSQLVAR');
+ RegisterPropertyHelper(@TIBXSQLVARDATA_R,@TIBXSQLVARDATA_W,'DATA');
+ RegisterPropertyHelper(@TIBXSQLVARISNULL_R,@TIBXSQLVARISNULL_W,'ISNULL');
+ RegisterPropertyHelper(@TIBXSQLVARISNULLABLE_R,@TIBXSQLVARISNULLABLE_W,'ISNULLABLE');
+ RegisterPropertyHelper(@TIBXSQLVARINDEX_R,nil,'INDEX');
+ RegisterPropertyHelper(@TIBXSQLVARMODIFIED_R,@TIBXSQLVARMODIFIED_W,'MODIFIED');
+ RegisterPropertyHelper(@TIBXSQLVARNAME_R,nil,'NAME');
+ RegisterPropertyHelper(@TIBXSQLVARSIZE_R,nil,'SIZE');
+ RegisterPropertyHelper(@TIBXSQLVARSQLTYPE_R,nil,'SQLTYPE');
+ RegisterPropertyHelper(@TIBXSQLVARVALUE_R,@TIBXSQLVARVALUE_W,'VALUE');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_IBSQL(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TIBSQL) do
+ with CL.Add(TIBXSQLDA) do
+ RIRegister_TIBXSQLVAR(CL);
+ RIRegister_TIBXSQLDA(CL);
+ RIRegister_TIBOUTPUTDELIMITEDFILE(CL);
+ RIRegister_TIBINPUTDELIMITEDFILE(CL);
+ RIRegister_TIBOUTPUTRAWFILE(CL);
+ RIRegister_TIBINPUTRAWFILE(CL);
+ RIRegister_TIBOUTPUTXML(CL);
+ RIRegister_TIBSQL(CL);
+end;
+
+(* === compile-time registration functions === *)
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TIBQuery(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TIBCustomDataSet', 'TIBQuery') do
+ with CL.AddClassN(CL.FindClass('TIBCustomDataSet'),'TIBQuery') do
+ begin
+ RegisterMethod('Procedure BatchInput( InputObject : TIBBatchInput)');
+ RegisterMethod('Procedure BatchOutput( OutputObject : TIBBatchOutput)');
+ RegisterMethod('Procedure ExecSQL');
+ RegisterMethod('Function ParamByName( const Value : string) : TParam');
+ RegisterMethod('Procedure Prepare');
+ RegisterMethod('Procedure UnPrepare');
+ RegisterProperty('Prepared', 'Boolean', iptrw);
+ RegisterProperty('ParamCount', 'Word', iptr);
+ RegisterProperty('StmtHandle', 'TISC_STMT_HANDLE', iptr);
+ RegisterProperty('Text', 'string', iptr);
+ RegisterProperty('RowsAffected', 'Integer', iptr);
+ RegisterProperty('GenerateParamNames', 'Boolean', iptrw);
+ RegisterProperty('DataSource', 'TDatasource', iptrw);
+ RegisterProperty('SQL', 'TStrings', iptrw);
+ RegisterProperty('Params', 'TParams', iptrw);
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_IBQuery(CL: TPSPascalCompiler);
+begin
+ SIRegister_TIBQuery(CL);
+end;
+
+(* === run-time registration functions === *)
+(*----------------------------------------------------------------------------*)
+procedure TIBQueryParams_W(Self: TIBQuery; const T: TParams);
+begin Self.Params := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBQueryParams_R(Self: TIBQuery; var T: TParams);
+begin T := Self.Params; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBQuerySQL_W(Self: TIBQuery; const T: TStrings);
+begin Self.SQL := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBQuerySQL_R(Self: TIBQuery; var T: TStrings);
+begin T := Self.SQL; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBQueryDataSource_W(Self: TIBQuery; const T: TDatasource);
+begin Self.DataSource := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBQueryDataSource_R(Self: TIBQuery; var T: TDatasource);
+begin T := Self.DataSource; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBQueryGenerateParamNames_W(Self: TIBQuery; const T: Boolean);
+begin Self.GenerateParamNames := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBQueryGenerateParamNames_R(Self: TIBQuery; var T: Boolean);
+begin T := Self.GenerateParamNames; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBQueryRowsAffected_R(Self: TIBQuery; var T: Integer);
+begin T := Self.RowsAffected; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBQueryText_R(Self: TIBQuery; var T: string);
+begin T := Self.Text; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBQueryStmtHandle_R(Self: TIBQuery; var T: TISC_STMT_HANDLE);
+begin T := Self.StmtHandle; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBQueryParamCount_R(Self: TIBQuery; var T: Word);
+begin T := Self.ParamCount; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBQueryPrepared_W(Self: TIBQuery; const T: Boolean);
+begin Self.Prepared := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TIBQueryPrepared_R(Self: TIBQuery; var T: Boolean);
+begin T := Self.Prepared; end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TIBQuery(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TIBQuery) do
+ begin
+ RegisterMethod(@TIBQuery.BatchInput, 'BatchInput');
+ RegisterMethod(@TIBQuery.BatchOutput, 'BatchOutput');
+ RegisterMethod(@TIBQuery.ExecSQL, 'ExecSQL');
+ RegisterMethod(@TIBQuery.ParamByName, 'ParamByName');
+ RegisterMethod(@TIBQuery.Prepare, 'Prepare');
+ RegisterMethod(@TIBQuery.UnPrepare, 'UnPrepare');
+ RegisterPropertyHelper(@TIBQueryPrepared_R,@TIBQueryPrepared_W,'Prepared');
+ RegisterPropertyHelper(@TIBQueryParamCount_R,nil,'ParamCount');
+ RegisterPropertyHelper(@TIBQueryStmtHandle_R,nil,'StmtHandle');
+ RegisterPropertyHelper(@TIBQueryText_R,nil,'Text');
+ RegisterPropertyHelper(@TIBQueryRowsAffected_R,nil,'RowsAffected');
+ RegisterPropertyHelper(@TIBQueryGenerateParamNames_R,@TIBQueryGenerateParamNames_W,'GenerateParamNames');
+ RegisterPropertyHelper(@TIBQueryDataSource_R,@TIBQueryDataSource_W,'DataSource');
+ RegisterPropertyHelper(@TIBQuerySQL_R,@TIBQuerySQL_W,'SQL');
+ RegisterPropertyHelper(@TIBQueryParams_R,@TIBQueryParams_W,'Params');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_IBQuery(CL: TPSRuntimeClassImporter);
+begin
+ RIRegister_TIBQuery(CL);
+end;
+
+
+
+{ TIFPS3CE_IBCustomDataSet }
+(*----------------------------------------------------------------------------*)
+procedure TPSImport_IBX.CompOnUses(CompExec: TPSScript);
+begin
+ { nothing }
+end;
+(*----------------------------------------------------------------------------*)
+procedure TPSImport_IBX.ExecOnUses(CompExec: TPSScript);
+begin
+ { nothing }
+end;
+(*----------------------------------------------------------------------------*)
+procedure TPSImport_IBX.CompileImport1(CompExec: TPSScript);
+begin
+ SIRegister_IBDatabase(CompExec.Comp);
+ SIRegister_IBSQL(CompExec.Comp);
+ SIRegister_IBCustomDataSet(CompExec.Comp);
+ SIRegister_IBTable(CompExec.Comp);
+ SIRegister_IBQuery(CompExec.Comp);
+end;
+(*----------------------------------------------------------------------------*)
+procedure TPSImport_IBX.CompileImport2(CompExec: TPSScript);
+begin
+ { nothing }
+end;
+(*----------------------------------------------------------------------------*)
+procedure TPSImport_IBX.ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter);
+begin
+ RIRegister_IBDatabase(ri);
+ RIRegister_IBSQL(ri);
+ RIRegister_IBCustomDataSet(ri);
+ RIRegister_IBTable(ri);
+ RIRegister_IBQuery(ri);
+end;
+(*----------------------------------------------------------------------------*)
+procedure TPSImport_IBX.ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter);
+begin
+ { nothing }
+end;
+
+end.
diff --git a/Units/PascalScript/uPSI_JvMail.pas b/Units/PascalScript/uPSI_JvMail.pas
new file mode 100644
index 0000000..bb79bbd
--- /dev/null
+++ b/Units/PascalScript/uPSI_JvMail.pas
@@ -0,0 +1,373 @@
+unit uPSI_JvMail;
+{
+This file has been generated by UnitParser v0.4b, written by M. Knight
+and updated by NP. v/d Spek.
+Source Code from Carlo Kok has been used to implement various sections of
+UnitParser. Components of ifps3 are used in the construction of UnitParser,
+code implementing the class wrapper is taken from Carlo Kok''s conv unility
+}
+interface
+
+uses
+ SysUtils, Classes, uPSComponent, uPSCompiler, uPSRuntime;
+
+type
+(*----------------------------------------------------------------------------*)
+ TPSImport_JvMail = class(TPSPlugin)
+ protected
+ procedure CompOnUses(CompExec: TPSScript); override;
+ procedure ExecOnUses(CompExec: TPSScript); override;
+ procedure CompileImport1(CompExec: TPSScript); override;
+ procedure CompileImport2(CompExec: TPSScript); override;
+ procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
+ procedure ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
+ end;
+
+implementation
+
+
+uses
+ Windows
+ ,Controls
+ ,Forms
+ ,Mapi
+ ,JclBase
+ ,JclMapi
+ ,JvComponent
+ ,JvMail
+ ;
+
+(* === compile-time registration functions === *)
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TJvMail(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TJvComponent', 'TJvMail') do
+ with CL.AddClassN(CL.FindClass('TComponent'),'TJvMail') do
+ begin
+ RegisterMethod('Function Address( const Caption : string; EditFields : Integer) : Boolean');
+ RegisterMethod('Procedure Clear');
+ RegisterMethod('Function ErrorCheck( Res : DWORD) : DWORD');
+ RegisterMethod('Function FindFirstMail : Boolean');
+ RegisterMethod('Function FindNextMail : Boolean');
+ RegisterMethod('Procedure FreeSimpleMapi');
+ RegisterMethod('Procedure LogOff');
+ RegisterMethod('Procedure LogOn');
+ RegisterMethod('Procedure ReadMail');
+ RegisterMethod('Function ResolveName( const Name : string) : string');
+ RegisterMethod('Function SaveMail( const MessageID : string) : string');
+ RegisterMethod('Procedure SendMail( ShowDialog : Boolean)');
+ RegisterProperty('ReadedMail', 'TJvMailReadedData', iptr);
+ RegisterProperty('SeedMessageID', 'string', iptrw);
+ RegisterProperty('SessionHandle', 'THandle', iptr);
+ RegisterProperty('SimpleMAPI', 'TJclSimpleMapi', iptr);
+ RegisterProperty('UserLogged', 'Boolean', iptr);
+ RegisterProperty('Attachment', 'TStrings', iptrw);
+ RegisterProperty('BlindCopy', 'TJvMailRecipients', iptrw);
+ RegisterProperty('Body', 'TStrings', iptrw);
+ RegisterProperty('CarbonCopy', 'TJvMailRecipients', iptrw);
+ RegisterProperty('LogonOptions', 'TJvMailLogonOptions', iptrw);
+ RegisterProperty('LongMsgId', 'Boolean', iptrw);
+ RegisterProperty('Password', 'string', iptrw);
+ RegisterProperty('ProfileName', 'string', iptrw);
+ RegisterProperty('ReadOptions', 'TJvMailReadOptions', iptrw);
+ RegisterProperty('Recipient', 'TJvMailRecipients', iptrw);
+ RegisterProperty('Subject', 'string', iptrw);
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TJvMailRecipients(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TCollection', 'TJvMailRecipients') do
+ with CL.AddClassN(CL.FindClass('TCollection'),'TJvMailRecipients') do
+ begin
+ RegisterMethod('Constructor Create( AOwner : TJvMail; ARecipientClass : DWORD)');
+ RegisterMethod('Function Add : TJvMailRecipient');
+ RegisterMethod('Function AddRecipient( const Address : string; const Name : string) : Integer');
+ RegisterProperty('Items', 'TJvMailRecipient Integer', iptrw);
+ SetDefaultPropery('Items');
+ RegisterProperty('RecipientClass', 'DWORD', iptr);
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TJvMailRecipient(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TCollectionItem', 'TJvMailRecipient') do
+ with CL.AddClassN(CL.FindClass('TCollectionItem'),'TJvMailRecipient') do
+ begin
+ RegisterProperty('AddressAndName', 'string', iptr);
+ RegisterProperty('Address', 'string', iptrw);
+ RegisterProperty('Name', 'string', iptrw);
+ RegisterProperty('Valid', 'Boolean', iptr);
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_JvMail(CL: TPSPascalCompiler);
+begin
+ CL.AddClassN(CL.FindClass('TOBJECT'),'TJvMail');
+ SIRegister_TJvMailRecipient(CL);
+ SIRegister_TJvMailRecipients(CL);
+ CL.AddTypeS('TJvMailLogonOption', '( loLogonUI, loNewSession )');
+ CL.AddTypeS('TJvMailReadOption', '( roUnreadOnly, roFifo, roPeek, roHeaderOnl'
+ +'y, roAttachments )');
+ CL.AddTypeS('TJvMailLogonOptions', 'set of TJvMailLogonOption');
+ CL.AddTypeS('TJvMailReadOptions', 'set of TJvMailReadOption');
+ CL.AddTypeS('TJvMailReadedData', 'record RecipientAddress : string; Recipient'
+ +'Name : string; ConversationID : string; DateReceived : TDateTime; end');
+ SIRegister_TJvMail(CL);
+end;
+
+(* === run-time registration functions === *)
+(*----------------------------------------------------------------------------*)
+procedure TJvMailSubject_W(Self: TJvMail; const T: string);
+begin Self.Subject := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailSubject_R(Self: TJvMail; var T: string);
+begin T := Self.Subject; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailRecipient_W(Self: TJvMail; const T: TJvMailRecipients);
+begin Self.Recipient := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailRecipient_R(Self: TJvMail; var T: TJvMailRecipients);
+begin T := Self.Recipient; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailReadOptions_W(Self: TJvMail; const T: TJvMailReadOptions);
+begin Self.ReadOptions := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailReadOptions_R(Self: TJvMail; var T: TJvMailReadOptions);
+begin T := Self.ReadOptions; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailProfileName_W(Self: TJvMail; const T: string);
+begin Self.ProfileName := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailProfileName_R(Self: TJvMail; var T: string);
+begin T := Self.ProfileName; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailPassword_W(Self: TJvMail; const T: string);
+begin Self.Password := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailPassword_R(Self: TJvMail; var T: string);
+begin T := Self.Password; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailLongMsgId_W(Self: TJvMail; const T: Boolean);
+begin Self.LongMsgId := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailLongMsgId_R(Self: TJvMail; var T: Boolean);
+begin T := Self.LongMsgId; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailLogonOptions_W(Self: TJvMail; const T: TJvMailLogonOptions);
+begin Self.LogonOptions := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailLogonOptions_R(Self: TJvMail; var T: TJvMailLogonOptions);
+begin T := Self.LogonOptions; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailCarbonCopy_W(Self: TJvMail; const T: TJvMailRecipients);
+begin Self.CarbonCopy := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailCarbonCopy_R(Self: TJvMail; var T: TJvMailRecipients);
+begin T := Self.CarbonCopy; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailBody_W(Self: TJvMail; const T: TStrings);
+begin Self.Body := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailBody_R(Self: TJvMail; var T: TStrings);
+begin T := Self.Body; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailBlindCopy_W(Self: TJvMail; const T: TJvMailRecipients);
+begin Self.BlindCopy := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailBlindCopy_R(Self: TJvMail; var T: TJvMailRecipients);
+begin T := Self.BlindCopy; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailAttachment_W(Self: TJvMail; const T: TStrings);
+begin Self.Attachment := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailAttachment_R(Self: TJvMail; var T: TStrings);
+begin T := Self.Attachment; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailUserLogged_R(Self: TJvMail; var T: Boolean);
+begin T := Self.UserLogged; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailSimpleMAPI_R(Self: TJvMail; var T: TJclSimpleMapi);
+begin T := Self.SimpleMAPI; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailSessionHandle_R(Self: TJvMail; var T: THandle);
+begin T := Self.SessionHandle; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailSeedMessageID_W(Self: TJvMail; const T: string);
+begin Self.SeedMessageID := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailSeedMessageID_R(Self: TJvMail; var T: string);
+begin T := Self.SeedMessageID; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailReadedMail_R(Self: TJvMail; var T: TJvMailReadedData);
+begin T := Self.ReadedMail; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailRecipientsRecipientClass_R(Self: TJvMailRecipients; var T: DWORD);
+begin T := Self.RecipientClass; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailRecipientsItems_W(Self: TJvMailRecipients; const T: TJvMailRecipient; const t1: Integer);
+begin Self.Items[t1] := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailRecipientsItems_R(Self: TJvMailRecipients; var T: TJvMailRecipient; const t1: Integer);
+begin T := Self.Items[t1]; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailRecipientValid_R(Self: TJvMailRecipient; var T: Boolean);
+begin T := Self.Valid; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailRecipientName_W(Self: TJvMailRecipient; const T: string);
+begin Self.Name := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailRecipientName_R(Self: TJvMailRecipient; var T: string);
+begin T := Self.Name; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailRecipientAddress_W(Self: TJvMailRecipient; const T: string);
+begin Self.Address := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailRecipientAddress_R(Self: TJvMailRecipient; var T: string);
+begin T := Self.Address; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TJvMailRecipientAddressAndName_R(Self: TJvMailRecipient; var T: string);
+begin T := Self.AddressAndName; end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TJvMail(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TJvMail) do
+ begin
+ RegisterMethod(@TJvMail.Address, 'Address');
+ RegisterMethod(@TJvMail.Clear, 'Clear');
+ RegisterMethod(@TJvMail.ErrorCheck, 'ErrorCheck');
+ RegisterMethod(@TJvMail.FindFirstMail, 'FindFirstMail');
+ RegisterMethod(@TJvMail.FindNextMail, 'FindNextMail');
+ RegisterMethod(@TJvMail.FreeSimpleMapi, 'FreeSimpleMapi');
+ RegisterMethod(@TJvMail.LogOff, 'LogOff');
+ RegisterMethod(@TJvMail.LogOn, 'LogOn');
+ RegisterMethod(@TJvMail.ReadMail, 'ReadMail');
+ RegisterMethod(@TJvMail.ResolveName, 'ResolveName');
+ RegisterMethod(@TJvMail.SaveMail, 'SaveMail');
+ RegisterMethod(@TJvMail.SendMail, 'SendMail');
+ RegisterPropertyHelper(@TJvMailReadedMail_R,nil,'ReadedMail');
+ RegisterPropertyHelper(@TJvMailSeedMessageID_R,@TJvMailSeedMessageID_W,'SeedMessageID');
+ RegisterPropertyHelper(@TJvMailSessionHandle_R,nil,'SessionHandle');
+ RegisterPropertyHelper(@TJvMailSimpleMAPI_R,nil,'SimpleMAPI');
+ RegisterPropertyHelper(@TJvMailUserLogged_R,nil,'UserLogged');
+ RegisterPropertyHelper(@TJvMailAttachment_R,@TJvMailAttachment_W,'Attachment');
+ RegisterPropertyHelper(@TJvMailBlindCopy_R,@TJvMailBlindCopy_W,'BlindCopy');
+ RegisterPropertyHelper(@TJvMailBody_R,@TJvMailBody_W,'Body');
+ RegisterPropertyHelper(@TJvMailCarbonCopy_R,@TJvMailCarbonCopy_W,'CarbonCopy');
+ RegisterPropertyHelper(@TJvMailLogonOptions_R,@TJvMailLogonOptions_W,'LogonOptions');
+ RegisterPropertyHelper(@TJvMailLongMsgId_R,@TJvMailLongMsgId_W,'LongMsgId');
+ RegisterPropertyHelper(@TJvMailPassword_R,@TJvMailPassword_W,'Password');
+ RegisterPropertyHelper(@TJvMailProfileName_R,@TJvMailProfileName_W,'ProfileName');
+ RegisterPropertyHelper(@TJvMailReadOptions_R,@TJvMailReadOptions_W,'ReadOptions');
+ RegisterPropertyHelper(@TJvMailRecipient_R,@TJvMailRecipient_W,'Recipient');
+ RegisterPropertyHelper(@TJvMailSubject_R,@TJvMailSubject_W,'Subject');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TJvMailRecipients(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TJvMailRecipients) do
+ begin
+ RegisterConstructor(@TJvMailRecipients.Create, 'Create');
+ RegisterMethod(@TJvMailRecipients.Add, 'Add');
+ RegisterMethod(@TJvMailRecipients.AddRecipient, 'AddRecipient');
+ RegisterPropertyHelper(@TJvMailRecipientsItems_R,@TJvMailRecipientsItems_W,'Items');
+ RegisterPropertyHelper(@TJvMailRecipientsRecipientClass_R,nil,'RecipientClass');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TJvMailRecipient(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TJvMailRecipient) do
+ begin
+ RegisterPropertyHelper(@TJvMailRecipientAddressAndName_R,nil,'AddressAndName');
+ RegisterPropertyHelper(@TJvMailRecipientAddress_R,@TJvMailRecipientAddress_W,'Address');
+ RegisterPropertyHelper(@TJvMailRecipientName_R,@TJvMailRecipientName_W,'Name');
+ RegisterPropertyHelper(@TJvMailRecipientValid_R,nil,'Valid');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_JvMail(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TJvMail) do
+ RIRegister_TJvMailRecipient(CL);
+ RIRegister_TJvMailRecipients(CL);
+ RIRegister_TJvMail(CL);
+end;
+
+{ TPSImport_JvMail }
+(*----------------------------------------------------------------------------*)
+procedure TPSImport_JvMail.CompOnUses(CompExec: TPSScript);
+begin
+ { nothing }
+end;
+(*----------------------------------------------------------------------------*)
+procedure TPSImport_JvMail.ExecOnUses(CompExec: TPSScript);
+begin
+ { nothing }
+end;
+(*----------------------------------------------------------------------------*)
+procedure TPSImport_JvMail.CompileImport1(CompExec: TPSScript);
+begin
+ SIRegister_JvMail(CompExec.Comp);
+end;
+(*----------------------------------------------------------------------------*)
+procedure TPSImport_JvMail.CompileImport2(CompExec: TPSScript);
+begin
+ { nothing }
+end;
+(*----------------------------------------------------------------------------*)
+procedure TPSImport_JvMail.ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter);
+begin
+ RIRegister_JvMail(ri);
+end;
+(*----------------------------------------------------------------------------*)
+procedure TPSImport_JvMail.ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter);
+begin
+ { nothing }
+end;
+
+end.
diff --git a/Units/PascalScript/uPSI_Mask.pas b/Units/PascalScript/uPSI_Mask.pas
new file mode 100644
index 0000000..b2bc080
--- /dev/null
+++ b/Units/PascalScript/uPSI_Mask.pas
@@ -0,0 +1,187 @@
+unit uPSI_Mask;
+{
+This file has been generated by UnitParser v0.5, written by M. Knight
+and updated by NP. v/d Spek.
+Source Code from Carlo Kok has been used to implement various sections of
+UnitParser. Components of ifps3 are used in the construction of UnitParser,
+code implementing the class wrapper is taken from Carlo Kok''s conv unility
+}
+interface
+
+uses
+ SysUtils, Classes, uPSComponent, uPSCompiler, uPSRuntime;
+
+type
+(*----------------------------------------------------------------------------*)
+ TPSImport_Mask = class(TPSPlugin)
+ protected
+ procedure CompOnUses(CompExec: TPSScript); override;
+ procedure ExecOnUses(CompExec: TPSScript); override;
+ procedure CompileImport1(CompExec: TPSScript); override;
+ procedure CompileImport2(CompExec: TPSScript); override;
+ procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
+ procedure ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
+ end;
+
+implementation
+
+
+uses
+ Windows ,StdCtrls ,Controls ,Messages ,Forms ,Graphics ,Menus ,Mask;
+
+(* === compile-time registration functions === *)
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TMaskEdit(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TCustomMaskEdit', 'TMaskEdit') do
+ with CL.AddClassN(CL.FindClass('TCustomMaskEdit'),'TMaskEdit') do
+ begin
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TCustomMaskEdit(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TCustomEdit', 'TCustomMaskEdit') do
+ with CL.AddClassN(CL.FindClass('TCustomEdit'),'TCustomMaskEdit') do
+ begin
+ RegisterMethod('Procedure ValidateEdit');
+ RegisterMethod('Function GetTextLen : Integer');
+ RegisterProperty('IsMasked', 'Boolean', iptr);
+ RegisterProperty('EditText', 'string', iptrw);
+ RegisterProperty('Text', 'string', iptrw);
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_Mask(CL: TPSPascalCompiler);
+begin
+ CL.AddConstantN('DefaultBlank','Char').SetString( '_');
+ CL.AddConstantN('MaskFieldSeparator','Char').SetString( ';');
+ CL.AddConstantN('MaskNoSave','Char').SetString( '0');
+ CL.AddConstantN('mDirReverse','String').SetString( '!');
+ CL.AddConstantN('mDirUpperCase','String').SetString( '>');
+ CL.AddConstantN('mDirLowerCase','String').SetString( '<');
+ CL.AddConstantN('mDirLiteral','String').SetString( '\');
+ CL.AddConstantN('mMskAlpha','String').SetString( 'L');
+ CL.AddConstantN('mMskAlphaOpt','String').SetString( 'l');
+ CL.AddConstantN('mMskAlphaNum','String').SetString( 'A');
+ CL.AddConstantN('mMskAlphaNumOpt','String').SetString( 'a');
+ CL.AddConstantN('mMskAscii','String').SetString( 'C');
+ CL.AddConstantN('mMskAsciiOpt','String').SetString( 'c');
+ CL.AddConstantN('mMskNumeric','String').SetString( '0');
+ CL.AddConstantN('mMskNumericOpt','String').SetString( '9');
+ CL.AddConstantN('mMskNumSymOpt','String').SetString( '#');
+ CL.AddConstantN('mMskTimeSeparator','String').SetString( ':');
+ CL.AddConstantN('mMskDateSeparator','String').SetString( '/');
+ CL.AddTypeS('TMaskCharType', '( mcNone, mcLiteral, mcIntlLiteral, mcDirective'
+ +', mcMask, mcMaskOpt, mcFieldSeparator, mcField )');
+ CL.AddTypeS('TMaskDirective', '( mdReverseDir, mdUpperCase, mdLowerCa'
+ +'se, mdLiteralChar )');
+ CL.AddTypeS('TMaskDirectives', 'set of TMaskDirective');
+ CL.AddClassN(CL.FindClass('TOBJECT'),'EDBEditError');
+ CL.AddTypeS('TMaskedStatex', '( msMasked, msReEnter, msDBSetText )');
+ CL.AddTypeS('TMaskedState', 'set of TMaskedStatex');
+ SIRegister_TCustomMaskEdit(CL);
+ SIRegister_TMaskEdit(CL);
+ CL.AddDelphiFunction('Function FormatMaskText( const EditMask : string; const Value : string) : string');
+ CL.AddDelphiFunction('Function MaskGetMaskSave( const EditMask : string) : Boolean');
+ CL.AddDelphiFunction('Function MaskGetMaskBlank( const EditMask : string) : Char');
+ CL.AddDelphiFunction('Function MaskGetFldSeparator( const EditMask : string) : Integer');
+end;
+
+(* === run-time registration functions === *)
+(*----------------------------------------------------------------------------*)
+procedure TCustomMaskEditText_W(Self: TCustomMaskEdit; const T: string);
+begin Self.Text := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TCustomMaskEditText_R(Self: TCustomMaskEdit; var T: string);
+begin T := Self.Text; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TCustomMaskEditEditText_W(Self: TCustomMaskEdit; const T: string);
+begin Self.EditText := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TCustomMaskEditEditText_R(Self: TCustomMaskEdit; var T: string);
+begin T := Self.EditText; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TCustomMaskEditIsMasked_R(Self: TCustomMaskEdit; var T: Boolean);
+begin T := Self.IsMasked; end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_Mask_Routines(S: TPSExec);
+begin
+ S.RegisterDelphiFunction(@FormatMaskText, 'FormatMaskText', cdRegister);
+ S.RegisterDelphiFunction(@MaskGetMaskSave, 'MaskGetMaskSave', cdRegister);
+ S.RegisterDelphiFunction(@MaskGetMaskBlank, 'MaskGetMaskBlank', cdRegister);
+ S.RegisterDelphiFunction(@MaskGetFldSeparator, 'MaskGetFldSeparator', cdRegister);
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TMaskEdit(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TMaskEdit) do
+ begin
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TCustomMaskEdit(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TCustomMaskEdit) do
+ begin
+ RegisterVirtualMethod(@TCustomMaskEdit.ValidateEdit, 'ValidateEdit');
+ RegisterMethod(@TCustomMaskEdit.GetTextLen, 'GetTextLen');
+ RegisterPropertyHelper(@TCustomMaskEditIsMasked_R,nil,'IsMasked');
+ RegisterPropertyHelper(@TCustomMaskEditEditText_R,@TCustomMaskEditEditText_W,'EditText');
+ RegisterPropertyHelper(@TCustomMaskEditText_R,@TCustomMaskEditText_W,'Text');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_Mask(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(EDBEditError) do
+ RIRegister_TCustomMaskEdit(CL);
+ RIRegister_TMaskEdit(CL);
+end;
+
+
+
+{ TPSImport_Mask }
+(*----------------------------------------------------------------------------*)
+procedure TPSImport_Mask.CompOnUses(CompExec: TPSScript);
+begin
+ { nothing }
+end;
+(*----------------------------------------------------------------------------*)
+procedure TPSImport_Mask.ExecOnUses(CompExec: TPSScript);
+begin
+ { nothing }
+end;
+(*----------------------------------------------------------------------------*)
+procedure TPSImport_Mask.CompileImport1(CompExec: TPSScript);
+begin
+ SIRegister_Mask(CompExec.Comp);
+end;
+(*----------------------------------------------------------------------------*)
+procedure TPSImport_Mask.CompileImport2(CompExec: TPSScript);
+begin
+ { nothing }
+end;
+(*----------------------------------------------------------------------------*)
+procedure TPSImport_Mask.ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter);
+begin
+ RIRegister_Mask(ri);
+ RIRegister_Mask_Routines(CompExec.Exec); // comment it if no routines
+end;
+(*----------------------------------------------------------------------------*)
+procedure TPSImport_Mask.ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter);
+begin
+ { nothing }
+end;
+
+end.
diff --git a/Units/PascalScript/uPSI_Registry.pas b/Units/PascalScript/uPSI_Registry.pas
new file mode 100644
index 0000000..538d44d
--- /dev/null
+++ b/Units/PascalScript/uPSI_Registry.pas
@@ -0,0 +1,478 @@
+unit uPSI_Registry;
+{
+This file has been generated by UnitParser v0.4b, written by M. Knight
+and updated by NP. v/d Spek.
+Source Code from Carlo Kok has been used to implement various sections of
+UnitParser. Components of ifps3 are used in the construction of UnitParser,
+code implementing the class wrapper is taken from Carlo Kok''s conv unility
+}
+
+interface
+
+uses
+ SysUtils, Classes, uPSComponent, uPSCompiler, uPSRuntime;
+
+type
+(*----------------------------------------------------------------------------*)
+ TPSImport_Registry = class(TPSPlugin)
+ protected
+ procedure CompOnUses(CompExec: TPSScript); override;
+ procedure ExecOnUses(CompExec: TPSScript); override;
+ procedure CompileImport1(CompExec: TPSScript); override;
+ procedure CompileImport2(CompExec: TPSScript); override;
+ procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
+ procedure ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
+ end;
+
+implementation
+
+
+uses
+ Windows ,IniFiles ,Registry ;
+
+(* === compile-time registration functions === *)
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TRegistryIniFile(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TCustomIniFile', 'TRegistryIniFile') do
+ with CL.AddClassN(CL.FindClass('TCustomIniFile'),'TRegistryIniFile') do
+ begin
+ RegisterMethod('Constructor Create( const FileName : string);');
+ RegisterMethod('Constructor CreateA( const FileName : string; AAccess : LongWord);');
+ RegisterProperty('RegIniFile', 'TRegIniFile', iptr);
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TRegIniFile(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TRegistry', 'TRegIniFile') do
+ with CL.AddClassN(CL.FindClass('TRegistry'),'TRegIniFile') do
+ begin
+ RegisterMethod('Constructor Create( const FileName : string);');
+ RegisterMethod('Constructor CreateA( const FileName : string; AAccess : LongWord);');
+ RegisterMethod('Function ReadString( const Section, Ident, Default : string) : string');
+ RegisterMethod('Function ReadInteger( const Section, Ident : string; Default : Longint) : Longint');
+ RegisterMethod('Procedure WriteInteger( const Section, Ident : string; Value : Longint)');
+ RegisterMethod('Procedure WriteString( const Section, Ident, Value : String)');
+ RegisterMethod('Function ReadBool( const Section, Ident : string; Default : Boolean) : Boolean');
+ RegisterMethod('Procedure WriteBool( const Section, Ident : string; Value : Boolean)');
+ RegisterMethod('Procedure ReadSection( const Section : string; Strings : TStrings)');
+ RegisterMethod('Procedure ReadSections( Strings : TStrings)');
+ RegisterMethod('Procedure ReadSectionValues( const Section : string; Strings : TStrings)');
+ RegisterMethod('Procedure EraseSection( const Section : string)');
+ RegisterMethod('Procedure DeleteKey( const Section, Ident : String)');
+ RegisterProperty('FileName', 'string', iptr);
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TRegistry(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TObject', 'TRegistry') do
+ with CL.AddClassN(CL.FindClass('TObject'),'TRegistry') do
+ begin
+ RegisterMethod('Constructor Create;');
+ RegisterMethod('Constructor CreateA( AAccess : LongWord);');
+ RegisterMethod('Procedure CloseKey');
+ RegisterMethod('Function CreateKey( const Key : string) : Boolean');
+ RegisterMethod('Function DeleteKey( const Key : string) : Boolean');
+ RegisterMethod('Function DeleteValue( const Name : string) : Boolean');
+ RegisterMethod('Function GetDataInfo( const ValueName : string; var Value : TRegDataInfo) : Boolean');
+ RegisterMethod('Function GetDataSize( const ValueName : string) : Integer');
+ RegisterMethod('Function GetDataType( const ValueName : string) : TRegDataType');
+ RegisterMethod('Function GetKeyInfo( var Value : TRegKeyInfo) : Boolean');
+ RegisterMethod('Procedure GetKeyNames( Strings : TStrings)');
+ RegisterMethod('Procedure GetValueNames( Strings : TStrings)');
+ RegisterMethod('Function HasSubKeys : Boolean');
+ RegisterMethod('Function KeyExists( const Key : string) : Boolean');
+ RegisterMethod('Function LoadKey( const Key, FileName : string) : Boolean');
+ RegisterMethod('Procedure MoveKey( const OldName, NewName : string; Delete : Boolean)');
+ RegisterMethod('Function OpenKey( const Key : string; CanCreate : Boolean) : Boolean');
+ RegisterMethod('Function OpenKeyReadOnly( const Key : String) : Boolean');
+ RegisterMethod('Function ReadCurrency( const Name : string) : Currency');
+ RegisterMethod('Function ReadBool( const Name : string) : Boolean');
+ RegisterMethod('Function ReadDate( const Name : string) : TDateTime');
+ RegisterMethod('Function ReadDateTime( const Name : string) : TDateTime');
+ RegisterMethod('Function ReadFloat( const Name : string) : Double');
+ RegisterMethod('Function ReadInteger( const Name : string) : Integer');
+ RegisterMethod('Function ReadString( const Name : string) : string');
+ RegisterMethod('Function ReadTime( const Name : string) : TDateTime');
+ RegisterMethod('Function RegistryConnect( const UNCName : string) : Boolean');
+ RegisterMethod('Procedure RenameValue( const OldName, NewName : string)');
+ RegisterMethod('Function ReplaceKey( const Key, FileName, BackUpFileName : string) : Boolean');
+ RegisterMethod('Function RestoreKey( const Key, FileName : string) : Boolean');
+ RegisterMethod('Function SaveKey( const Key, FileName : string) : Boolean');
+ RegisterMethod('Function UnLoadKey( const Key : string) : Boolean');
+ RegisterMethod('Function ValueExists( const Name : string) : Boolean');
+ RegisterMethod('Procedure WriteCurrency( const Name : string; Value : Currency)');
+ RegisterMethod('Procedure WriteBool( const Name : string; Value : Boolean)');
+ RegisterMethod('Procedure WriteDate( const Name : string; Value : TDateTime)');
+ RegisterMethod('Procedure WriteDateTime( const Name : string; Value : TDateTime)');
+ RegisterMethod('Procedure WriteFloat( const Name : string; Value : Double)');
+ RegisterMethod('Procedure WriteInteger( const Name : string; Value : Integer)');
+ RegisterMethod('Procedure WriteString( const Name, Value : string)');
+ RegisterMethod('Procedure WriteExpandString( const Name, Value : string)');
+ RegisterMethod('Procedure WriteTime( const Name : string; Value : TDateTime)');
+ RegisterProperty('CurrentKey', 'HKEY', iptr);
+ RegisterProperty('CurrentPath', 'string', iptr);
+ RegisterProperty('LazyWrite', 'Boolean', iptrw);
+ RegisterProperty('RootKey', 'HKEY', iptrw);
+ RegisterProperty('Access', 'LongWord', iptrw);
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_Registry(CL: TPSPascalCompiler);
+begin
+ CL.AddClassN(CL.FindClass('TOBJECT'),'ERegistryException');
+ SIRegister_TRegistry(CL);
+ SIRegister_TRegIniFile(CL);
+ SIRegister_TRegistryIniFile(CL);
+end;
+
+(* === run-time registration functions === *)
+(*----------------------------------------------------------------------------*)
+procedure TRegistryIniFileRegIniFile_R(Self: TRegistryIniFile; var T: TRegIniFile);
+begin T := Self.RegIniFile; end;
+
+(*----------------------------------------------------------------------------*)
+Function TRegistryIniFileCreateA_P(Self: TClass; CreateNewInstance: Boolean; const FileName : string; AAccess : LongWord):TObject;
+Begin Result := TRegistryIniFile.Create(FileName, AAccess); END;
+
+(*----------------------------------------------------------------------------*)
+Function TRegistryIniFileCreate_P(Self: TClass; CreateNewInstance: Boolean; const FileName : string):TObject;
+Begin Result := TRegistryIniFile.Create(FileName); END;
+
+(*----------------------------------------------------------------------------*)
+procedure TRegIniFileFileName_R(Self: TRegIniFile; var T: string);
+begin T := Self.FileName; end;
+
+(*----------------------------------------------------------------------------*)
+Function TRegIniFileCreateA_P(Self: TClass; CreateNewInstance: Boolean; const FileName : string; AAccess : LongWord):TObject;
+Begin Result := TRegIniFile.Create(FileName, AAccess); END;
+
+(*----------------------------------------------------------------------------*)
+Function TRegIniFileCreate_P(Self: TClass; CreateNewInstance: Boolean; const FileName : string):TObject;
+Begin Result := TRegIniFile.Create(FileName); END;
+
+(*----------------------------------------------------------------------------*)
+procedure TRegistryAccess_W(Self: TRegistry; const T: LongWord);
+begin Self.Access := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TRegistryAccess_R(Self: TRegistry; var T: LongWord);
+begin T := Self.Access; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TRegistryRootKey_W(Self: TRegistry; const T: HKEY);
+begin Self.RootKey := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TRegistryRootKey_R(Self: TRegistry; var T: HKEY);
+begin T := Self.RootKey; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TRegistryLazyWrite_W(Self: TRegistry; const T: Boolean);
+begin Self.LazyWrite := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TRegistryLazyWrite_R(Self: TRegistry; var T: Boolean);
+begin T := Self.LazyWrite; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TRegistryCurrentPath_R(Self: TRegistry; var T: string);
+begin T := Self.CurrentPath; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TRegistryCurrentKey_R(Self: TRegistry; var T: HKEY);
+begin T := Self.CurrentKey; end;
+
+(*----------------------------------------------------------------------------*)
+Function TRegistryCreateA_P(Self: TClass; CreateNewInstance: Boolean; AAccess : LongWord):TObject;
+Begin Result := TRegistry.Create(AAccess); END;
+
+(*----------------------------------------------------------------------------*)
+Function TRegistryCreate_P(Self: TClass; CreateNewInstance: Boolean):TObject;
+Begin Result := TRegistry.Create; END;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TRegistryIniFile(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TRegistryIniFile) do
+ begin
+ RegisterConstructor(@TRegistryIniFileCreate_P, 'Create');
+ RegisterConstructor(@TRegistryIniFileCreateA_P, 'CreateA');
+ RegisterPropertyHelper(@TRegistryIniFileRegIniFile_R,nil,'RegIniFile');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TRegIniFile(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TRegIniFile) do
+ begin
+ RegisterConstructor(@TRegIniFileCreate_P, 'Create');
+ RegisterConstructor(@TRegIniFileCreateA_P, 'CreateA');
+ RegisterMethod(@TRegIniFile.ReadString, 'ReadString');
+ RegisterMethod(@TRegIniFile.ReadInteger, 'ReadInteger');
+ RegisterMethod(@TRegIniFile.WriteInteger, 'WriteInteger');
+ RegisterMethod(@TRegIniFile.WriteString, 'WriteString');
+ RegisterMethod(@TRegIniFile.ReadBool, 'ReadBool');
+ RegisterMethod(@TRegIniFile.WriteBool, 'WriteBool');
+ RegisterMethod(@TRegIniFile.ReadSection, 'ReadSection');
+ RegisterMethod(@TRegIniFile.ReadSections, 'ReadSections');
+ RegisterMethod(@TRegIniFile.ReadSectionValues, 'ReadSectionValues');
+ RegisterMethod(@TRegIniFile.EraseSection, 'EraseSection');
+ RegisterMethod(@TRegIniFile.DeleteKey, 'DeleteKey');
+ RegisterPropertyHelper(@TRegIniFileFileName_R,nil,'FileName');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TRegistry(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TRegistry) do
+ begin
+ RegisterConstructor(@TRegistryCreateA_P, 'CreateA');
+ RegisterConstructor(@TRegistryCreate_P, 'Create');
+ RegisterMethod(@TRegistry.CloseKey, 'CloseKey');
+ RegisterMethod(@TRegistry.CreateKey, 'CreateKey');
+ RegisterMethod(@TRegistry.DeleteKey, 'DeleteKey');
+ RegisterMethod(@TRegistry.DeleteValue, 'DeleteValue');
+ RegisterMethod(@TRegistry.GetDataInfo, 'GetDataInfo');
+ RegisterMethod(@TRegistry.GetDataSize, 'GetDataSize');
+ RegisterMethod(@TRegistry.GetDataType, 'GetDataType');
+ RegisterMethod(@TRegistry.GetKeyInfo, 'GetKeyInfo');
+ RegisterMethod(@TRegistry.GetKeyNames, 'GetKeyNames');
+ RegisterMethod(@TRegistry.GetValueNames, 'GetValueNames');
+ RegisterMethod(@TRegistry.HasSubKeys, 'HasSubKeys');
+ RegisterMethod(@TRegistry.KeyExists, 'KeyExists');
+ RegisterMethod(@TRegistry.LoadKey, 'LoadKey');
+ RegisterMethod(@TRegistry.MoveKey, 'MoveKey');
+ RegisterMethod(@TRegistry.OpenKey, 'OpenKey');
+ RegisterMethod(@TRegistry.OpenKeyReadOnly, 'OpenKeyReadOnly');
+ RegisterMethod(@TRegistry.ReadCurrency, 'ReadCurrency');
+ RegisterMethod(@TRegistry.ReadBool, 'ReadBool');
+ RegisterMethod(@TRegistry.ReadDate, 'ReadDate');
+ RegisterMethod(@TRegistry.ReadDateTime, 'ReadDateTime');
+ RegisterMethod(@TRegistry.ReadFloat, 'ReadFloat');
+ RegisterMethod(@TRegistry.ReadInteger, 'ReadInteger');
+ RegisterMethod(@TRegistry.ReadString, 'ReadString');
+ RegisterMethod(@TRegistry.ReadTime, 'ReadTime');
+ RegisterMethod(@TRegistry.RegistryConnect, 'RegistryConnect');
+ RegisterMethod(@TRegistry.RenameValue, 'RenameValue');
+ RegisterMethod(@TRegistry.ReplaceKey, 'ReplaceKey');
+ RegisterMethod(@TRegistry.RestoreKey, 'RestoreKey');
+ RegisterMethod(@TRegistry.SaveKey, 'SaveKey');
+ RegisterMethod(@TRegistry.UnLoadKey, 'UnLoadKey');
+ RegisterMethod(@TRegistry.ValueExists, 'ValueExists');
+ RegisterMethod(@TRegistry.WriteCurrency, 'WriteCurrency');
+ RegisterMethod(@TRegistry.WriteBool, 'WriteBool');
+ RegisterMethod(@TRegistry.WriteDate, 'WriteDate');
+ RegisterMethod(@TRegistry.WriteDateTime, 'WriteDateTime');
+ RegisterMethod(@TRegistry.WriteFloat, 'WriteFloat');
+ RegisterMethod(@TRegistry.WriteInteger, 'WriteInteger');
+ RegisterMethod(@TRegistry.WriteString, 'WriteString');
+ RegisterMethod(@TRegistry.WriteExpandString, 'WriteExpandString');
+ RegisterMethod(@TRegistry.WriteTime, 'WriteTime');
+ RegisterPropertyHelper(@TRegistryCurrentKey_R,nil,'CurrentKey');
+ RegisterPropertyHelper(@TRegistryCurrentPath_R,nil,'CurrentPath');
+ RegisterPropertyHelper(@TRegistryLazyWrite_R,@TRegistryLazyWrite_W,'LazyWrite');
+ RegisterPropertyHelper(@TRegistryRootKey_R,@TRegistryRootKey_W,'RootKey');
+ RegisterPropertyHelper(@TRegistryAccess_R,@TRegistryAccess_W,'Access');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_Registry(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(ERegistryException) do
+ RIRegister_TRegistry(CL);
+ RIRegister_TRegIniFile(CL);
+ RIRegister_TRegistryIniFile(CL);
+end;
+
+(* === compile-time registration functions === *)
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TMemIniFile(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TCustomIniFile', 'TMemIniFile') do
+ with CL.AddClassN(CL.FindClass('TCustomIniFile'),'TMemIniFile') do
+ begin
+ RegisterMethod('Constructor Create( const FileName : string)');
+ RegisterMethod('Procedure Clear');
+ RegisterMethod('Procedure GetStrings( List : TStrings)');
+ RegisterMethod('Procedure Rename( const FileName : string; Reload : Boolean)');
+ RegisterMethod('Procedure SetStrings( List : TStrings)');
+ end;
+end;
+
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TIniFile(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TCustomIniFile', 'TIniFile') do
+ with CL.AddClassN(CL.FindClass('TCustomIniFile'),'TIniFile') do
+ begin
+ RegisterMethod('Function ReadString( const Section, Ident, Default : string) : string');
+ RegisterMethod('Procedure WriteString( const Section, Ident, Value : String)');
+ RegisterMethod('Procedure ReadSection( const Section : string; Strings : TStrings)');
+ RegisterMethod('Procedure ReadSections( Strings : TStrings)');
+ RegisterMethod('Procedure ReadSectionValues( const Section : string; Strings : TStrings)');
+ RegisterMethod('Procedure EraseSection( const Section : string)');
+ RegisterMethod('Procedure DeleteKey( const Section, Ident : String)');
+ RegisterMethod('Procedure UpdateFile');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TCustomIniFile(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TObject', 'TCustomIniFile') do
+ with CL.AddClassN(CL.FindClass('TObject'),'TCustomIniFile') do
+ begin
+ RegisterMethod('Constructor Create( const FileName : string)');
+ RegisterMethod('Function SectionExists( const Section : string) : Boolean');
+// RegisterMethod('Function ReadString( const Section, Ident, Default : string) : string');
+// RegisterMethod('Procedure WriteString( const Section, Ident, Value : String)');
+ RegisterMethod('Function ReadInteger( const Section, Ident : string; Default : Longint) : Longint');
+ RegisterMethod('Procedure WriteInteger( const Section, Ident : string; Value : Longint)');
+ RegisterMethod('Function ReadBool( const Section, Ident : string; Default : Boolean) : Boolean');
+ RegisterMethod('Procedure WriteBool( const Section, Ident : string; Value : Boolean)');
+ RegisterMethod('Function ReadDate( const Section, Name : string; Default : TDateTime) : TDateTime');
+ RegisterMethod('Function ReadDateTime( const Section, Name : string; Default : TDateTime) : TDateTime');
+ RegisterMethod('Function ReadFloat( const Section, Name : string; Default : Double) : Double');
+ RegisterMethod('Function ReadTime( const Section, Name : string; Default : TDateTime) : TDateTime');
+ RegisterMethod('Procedure WriteDate( const Section, Name : string; Value : TDateTime)');
+ RegisterMethod('Procedure WriteDateTime( const Section, Name : string; Value : TDateTime)');
+ RegisterMethod('Procedure WriteFloat( const Section, Name : string; Value : Double)');
+ RegisterMethod('Procedure WriteTime( const Section, Name : string; Value : TDateTime)');
+// RegisterMethod('Procedure ReadSection( const Section : string; Strings : TStrings)');
+// RegisterMethod('Procedure ReadSections( Strings : TStrings)');
+// RegisterMethod('Procedure ReadSectionValues( const Section : string; Strings : TStrings)');
+// RegisterMethod('Procedure EraseSection( const Section : string)');
+// RegisterMethod('Procedure DeleteKey( const Section, Ident : String)');
+// RegisterMethod('Procedure UpdateFile');
+ RegisterMethod('Function ValueExists( const Section, Ident : string) : Boolean');
+ RegisterProperty('FileName', 'string', iptr);
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_IniFiles(CL: TPSPascalCompiler);
+begin
+ SIRegister_TCustomIniFile(CL);
+ SIRegister_TIniFile(CL);
+ SIRegister_TMemIniFile(CL);
+end;
+
+(* === run-time registration functions === *)
+(*----------------------------------------------------------------------------*)
+procedure TCustomIniFileFileName_R(Self: TCustomIniFile; var T: string);
+begin T := Self.FileName; end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TMemIniFile(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TMemIniFile) do
+ begin
+ RegisterConstructor(@TMemIniFile.Create, 'Create');
+ RegisterMethod(@TMemIniFile.Clear, 'Clear');
+ RegisterMethod(@TMemIniFile.GetStrings, 'GetStrings');
+ RegisterMethod(@TMemIniFile.Rename, 'Rename');
+ RegisterMethod(@TMemIniFile.SetStrings, 'SetStrings');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TIniFile(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TIniFile) do
+ begin
+ RegisterMethod(@TIniFile.ReadString, 'ReadString');
+ RegisterMethod(@TIniFile.WriteString, 'WriteString');
+ RegisterMethod(@TIniFile.ReadSection, 'ReadSection');
+ RegisterMethod(@TIniFile.ReadSections, 'ReadSections');
+ RegisterMethod(@TIniFile.ReadSectionValues, 'ReadSectionValues');
+ RegisterMethod(@TIniFile.EraseSection, 'EraseSection');
+ RegisterMethod(@TIniFile.DeleteKey, 'DeleteKey');
+ RegisterMethod(@TIniFile.UpdateFile, 'UpdateFile');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TCustomIniFile(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TCustomIniFile) do
+ begin
+ RegisterConstructor(@TCustomIniFile.Create, 'Create');
+ RegisterMethod(@TCustomIniFile.SectionExists, 'SectionExists');
+// RegisterVirtualAbstractMethod(@TCustomIniFile, @!.ReadString, 'ReadString');
+// RegisterVirtualAbstractMethod(@TCustomIniFile, @!.WriteString, 'WriteString');
+ RegisterVirtualMethod(@TCustomIniFile.ReadInteger, 'ReadInteger');
+ RegisterVirtualMethod(@TCustomIniFile.WriteInteger, 'WriteInteger');
+ RegisterVirtualMethod(@TCustomIniFile.ReadBool, 'ReadBool');
+ RegisterVirtualMethod(@TCustomIniFile.WriteBool, 'WriteBool');
+ RegisterVirtualMethod(@TCustomIniFile.ReadDate, 'ReadDate');
+ RegisterVirtualMethod(@TCustomIniFile.ReadDateTime, 'ReadDateTime');
+ RegisterVirtualMethod(@TCustomIniFile.ReadFloat, 'ReadFloat');
+ RegisterVirtualMethod(@TCustomIniFile.ReadTime, 'ReadTime');
+ RegisterVirtualMethod(@TCustomIniFile.WriteDate, 'WriteDate');
+ RegisterVirtualMethod(@TCustomIniFile.WriteDateTime, 'WriteDateTime');
+ RegisterVirtualMethod(@TCustomIniFile.WriteFloat, 'WriteFloat');
+ RegisterVirtualMethod(@TCustomIniFile.WriteTime, 'WriteTime');
+// RegisterVirtualAbstractMethod(@TCustomIniFile, @!.ReadSection, 'ReadSection');
+// RegisterVirtualAbstractMethod(@TCustomIniFile, @!.ReadSections, 'ReadSections');
+// RegisterVirtualAbstractMethod(@TCustomIniFile, @!.ReadSectionValues, 'ReadSectionValues');
+// RegisterVirtualAbstractMethod(@TCustomIniFile, @!.EraseSection, 'EraseSection');
+// RegisterVirtualAbstractMethod(@TCustomIniFile, @!.DeleteKey, 'DeleteKey');
+// RegisterVirtualAbstractMethod(@TCustomIniFile, @!.UpdateFile, 'UpdateFile');
+ RegisterMethod(@TCustomIniFile.ValueExists, 'ValueExists');
+ RegisterPropertyHelper(@TCustomIniFileFileName_R,nil,'FileName');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_IniFiles(CL: TPSRuntimeClassImporter);
+begin
+ RIRegister_TCustomIniFile(CL);
+ RIRegister_TIniFile(CL);
+ RIRegister_TMemIniFile(CL);
+end;
+
+{ TPSImport_Registry }
+(*----------------------------------------------------------------------------*)
+procedure TPSImport_Registry.CompOnUses(CompExec: TPSScript);
+begin
+ { nothing }
+end;
+(*----------------------------------------------------------------------------*)
+procedure TPSImport_Registry.ExecOnUses(CompExec: TPSScript);
+begin
+ { nothing }
+end;
+(*----------------------------------------------------------------------------*)
+procedure TPSImport_Registry.CompileImport1(CompExec: TPSScript);
+begin
+ SIRegister_Registry(CompExec.Comp);
+ SIRegister_IniFiles(CompExec.Comp);
+end;
+(*----------------------------------------------------------------------------*)
+procedure TPSImport_Registry.CompileImport2(CompExec: TPSScript);
+begin
+ { nothing }
+end;
+(*----------------------------------------------------------------------------*)
+procedure TPSImport_Registry.ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter);
+begin
+ RIRegister_Registry(ri);
+ RIRegister_IniFiles(ri);
+end;
+(*----------------------------------------------------------------------------*)
+procedure TPSImport_Registry.ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter);
+begin
+ { nothing }
+end;
+
+end.
diff --git a/Units/PascalScript/uPSPreProcessor.pas b/Units/PascalScript/uPSPreProcessor.pas
new file mode 100644
index 0000000..573d5cf
--- /dev/null
+++ b/Units/PascalScript/uPSPreProcessor.pas
@@ -0,0 +1,800 @@
+
+unit uPSPreProcessor;
+{$I PascalScript.inc}
+
+interface
+uses
+ Classes, SysUtils, uPSCompiler, uPSUtils;
+
+
+
+type
+ EPSPreProcessor = class(Exception); //- jgv
+ TPSPreProcessor = class;
+ TPSPascalPreProcessorParser = class;
+
+ TPSOnNeedFile = function (Sender: TPSPreProcessor; const callingfilename: tbtstring; var FileName, Output: tbtstring): Boolean;
+ TPSOnProcessDirective = procedure (
+ Sender: TPSPreProcessor;
+ Parser: TPSPascalPreProcessorParser;
+ const Active: Boolean;
+ const DirectiveName, DirectiveParam: tbtString;
+ Var Continue: Boolean); //- jgv - application set continue to false to stop the normal directive processing
+
+ TPSLineInfo = class(TObject)
+ private
+ function GetLineOffset(I: Integer): Cardinal;
+ function GetLineOffsetCount: Longint;
+ protected
+ FEndPos: Cardinal;
+ FStartPos: Cardinal;
+ FFileName: tbtstring;
+ FLineOffsets: TIfList;
+ public
+
+ property FileName: tbtstring read FFileName;
+
+ property StartPos: Cardinal read FStartPos;
+
+ property EndPos: Cardinal read FEndPos;
+
+ property LineOffsetCount: Longint read GetLineOffsetCount;
+
+ property LineOffset[I: Longint]: Cardinal read GetLineOffset;
+
+
+ constructor Create;
+
+ destructor Destroy; override;
+ end;
+
+ TPSLineInfoResults = record
+
+ Row,
+ Col,
+ Pos: Cardinal;
+
+ Name: tbtstring;
+ end;
+
+ TPSLineInfoList = class(TObject)
+ private
+ FItems: TIfList;
+ FCurrent: Longint;
+ function GetCount: Longint;
+ function GetItem(I: Integer): TPSLineInfo;
+ protected
+
+ function Add: TPSLineInfo;
+ public
+
+ property Count: Longint read GetCount;
+
+ property Items[I: Longint]: TPSLineInfo read GetItem; default;
+
+ procedure Clear;
+
+ function GetLineInfo(const ModuleName: tbtstring; Pos: Cardinal; var Res: TPSLineInfoResults): Boolean;
+
+ property Current: Longint read FCurrent write FCurrent;
+
+
+ constructor Create;
+
+ destructor Destroy; override;
+ end;
+ TPSDefineStates = class;
+
+ TPSPreProcessor = class(TObject)
+ private
+ FID: Pointer;
+ FCurrentDefines, FDefines: TStringList;
+ FCurrentLineInfo: TPSLineInfoList;
+ FOnNeedFile: TPSOnNeedFile;
+ FAddedPosition: Cardinal;
+ FDefineState: TPSDefineStates;
+ FMaxLevel: Longint;
+ FMainFileName: tbtstring;
+ FMainFile: tbtstring;
+ FOnProcessDirective: TPSOnProcessDirective;
+ FOnProcessUnknowDirective: TPSOnProcessDirective;
+ procedure ParserNewLine(Sender: TPSPascalPreProcessorParser; Row, Col, Pos: Cardinal);
+ procedure IntPreProcess(Level: Integer; const OrgFileName: tbtstring; FileName: tbtstring; Dest: TStream);
+ protected
+ procedure doAddStdPredefines; virtual; // jgv
+ public
+ {The maximum number of levels deep the parser will go, defaults to 20}
+ property MaxLevel: Longint read FMaxLevel write FMaxLevel;
+ property CurrentLineInfo: TPSLineInfoList read FCurrentLineInfo;
+
+ property OnNeedFile: TPSOnNeedFile read FOnNeedFile write FOnNeedFile;
+
+ property Defines: TStringList read FDefines write FDefines;
+
+ property MainFile: tbtstring read FMainFile write FMainFile;
+
+ property MainFileName: tbtstring read FMainFileName write FMainFileName;
+
+ property ID: Pointer read FID write FID;
+
+ procedure AdjustMessages(Comp: TPSPascalCompiler);
+ procedure AdjustMessage(Msg: TPSPascalCompilerMessage); //-jgv
+
+ procedure PreProcess(const Filename: tbtstring; var Output: tbtstring);
+
+ procedure Clear;
+
+
+ constructor Create;
+
+ destructor Destroy; override;
+
+ property OnProcessDirective: TPSOnProcessDirective read fOnProcessDirective write fOnProcessDirective;
+ property OnProcessUnknowDirective: TPSOnProcessDirective read fOnProcessUnknowDirective write fOnProcessUnknowDirective;
+ end;
+
+ TPSPascalPreProcessorType = (ptEOF, ptOther, ptDefine);
+
+ TPSOnNewLine = procedure (Sender: TPSPascalPreProcessorParser; Row, Col, Pos: Cardinal) of object;
+
+ TPSPascalPreProcessorParser = class(TObject)
+ private
+ FData: tbtstring;
+ FText: PAnsichar;
+ FToken: tbtstring;
+ FTokenId: TPSPascalPreProcessorType;
+ FLastEnterPos, FLen, FRow, FCol, FPos: Cardinal;
+ FOnNewLine: TPSOnNewLine;
+ public
+
+ procedure SetText(const dta: tbtstring);
+
+ procedure Next;
+
+ property Token: tbtstring read FToken;
+
+ property TokenId: TPSPascalPreProcessorType read FTokenId;
+
+ property Row: Cardinal read FRow;
+
+ property Col: Cardinal read FCol;
+
+ property Pos: Cardinal read FPos;
+
+ property OnNewLine: TPSOnNewLine read FOnNewLine write FOnNewLine;
+ end;
+
+ TPSDefineState = class(TObject)
+ private
+ FInElse: Boolean;
+ FDoWrite: Boolean;
+ public
+
+ property InElse: Boolean read FInElse write FInElse;
+
+ property DoWrite: Boolean read FDoWrite write FDoWrite;
+ end;
+
+ TPSDefineStates = class(TObject)
+ private
+ FItems: TIfList;
+ function GetCount: Longint;
+ function GetItem(I: Integer): TPSDefineState;
+ function GetWrite: Boolean;
+ function GetPrevWrite: Boolean; //JeromeWelsh - nesting fix
+ public
+
+ property Count: Longint read GetCount;
+
+ property Item[I: Longint]: TPSDefineState read GetItem; default;
+
+ function Add: TPSDefineState;
+
+ procedure Delete(I: Longint);
+
+
+ constructor Create;
+
+ destructor Destroy; override;
+
+ procedure Clear;
+
+ property DoWrite: Boolean read GetWrite;
+ property DoPrevWrite: Boolean read GetPrevWrite; //JeromeWelsh - nesting fix
+ end;
+
+implementation
+
+{$IFDEF DELPHI3UP }
+resourceString
+{$ELSE }
+const
+{$ENDIF }
+
+ RPS_TooManyNestedInclude = 'Too many nested include files while processing ''%s'' from ''%s''';
+ RPS_IncludeNotFound = 'Unable to find file ''%s'' used from ''%s''';
+ RPS_DefineTooManyParameters = 'Too many parameters at %d:%d';
+ RPS_NoIfdefForEndif = 'No IFDEF for ENDIF at %d:%d';
+ RPS_NoIfdefForElse = 'No IFDEF for ELSE at %d:%d';
+ RPS_ElseTwice = 'Can''t use ELSE twice at %d:%d';
+ RPS_UnknownCompilerDirective = 'Unknown compiler directives at %d:%d';
+ RPs_DefineNotClosed = 'Define not closed';
+
+{ TPSLineInfoList }
+
+function TPSLineInfoList.Add: TPSLineInfo;
+begin
+ Result := TPSLineInfo.Create;
+ FItems.Add(Result);
+end;
+
+procedure TPSLineInfoList.Clear;
+var
+ i: Longint;
+begin
+ for i := FItems.count -1 downto 0 do
+ TPSLineInfo(FItems[i]).Free;
+ FItems.Clear;
+end;
+
+constructor TPSLineInfoList.Create;
+begin
+ inherited Create;
+ FItems := TIfList.Create;
+end;
+
+destructor TPSLineInfoList.Destroy;
+begin
+ Clear;
+ FItems.Free;
+ inherited Destroy;
+end;
+
+function TPSLineInfoList.GetCount: Longint;
+begin
+ Result := FItems.Count;
+end;
+
+function TPSLineInfoList.GetItem(I: Integer): TPSLineInfo;
+begin
+ Result := TPSLineInfo(FItems[i]);
+end;
+
+function TPSLineInfoList.GetLineInfo(const ModuleName: tbtstring; Pos: Cardinal; var Res: TPSLineInfoResults): Boolean;
+var
+ i,j: Longint;
+ linepos: Cardinal;
+ Item: TPSLineInfo;
+ lModuleName: tbtstring;
+begin
+ lModuleName := FastUpperCase(ModuleName);
+
+ for i := FItems.Count -1 downto 0 do
+ begin
+ Item := FItems[i];
+ if (Pos >= Item.StartPos) and (Pos < Item.EndPos) and
+ (lModuleName = '') or (lModuleName = Item.FileName) then
+ begin
+ Res.Name := Item.FileName;
+ Pos := Pos - Item.StartPos;
+ Res.Pos := Pos;
+ Res.Col := 1;
+ Res.Row := 1;
+ LinePos := 0;
+ for j := 0 to Item.LineOffsetCount -1 do
+ begin
+ if Pos >= Item.LineOffset[j] then
+ begin
+ linepos := Item.LineOffset[j];
+ end else
+ begin
+ Res.Row := j; // j -1, but line counting starts at 1
+ Res.Col := pos - linepos + 1;
+ Break;
+ end;
+ end;
+ Result := True;
+ exit;
+ end;
+ end;
+ Result := False;
+end;
+
+{ TPSLineInfo }
+
+constructor TPSLineInfo.Create;
+begin
+ inherited Create;
+ FLineOffsets := TIfList.Create;
+end;
+
+destructor TPSLineInfo.Destroy;
+begin
+ FLineOffsets.Free;
+ inherited Destroy;
+end;
+
+
+function TPSLineInfo.GetLineOffset(I: Integer): Cardinal;
+begin
+ Result := Longint(FLineOffsets[I]);
+end;
+
+function TPSLineInfo.GetLineOffsetCount: Longint;
+begin
+ result := FLineOffsets.Count;
+end;
+
+{ TPSPascalPreProcessorParser }
+
+procedure TPSPascalPreProcessorParser.Next;
+var
+ ci: Cardinal;
+
+begin
+ FPos := FPos + FLen;
+ case FText[FPos] of
+ #0:
+ begin
+ FLen := 0;
+ FTokenId := ptEof;
+ end;
+ '''':
+ begin
+ ci := FPos;
+ while (FText[ci] <> #0) do
+ begin
+ Inc(ci);
+ while FText[ci] = '''' do
+ begin
+ if FText[ci+1] <> '''' then Break;
+ inc(ci);
+ inc(ci);
+ end;
+ if FText[ci] = '''' then Break;
+ if FText[ci] = #13 then
+ begin
+ inc(FRow);
+ if FText[ci] = #10 then
+ inc(ci);
+ FLastEnterPos := ci -1;
+ if @FOnNewLine <> nil then FOnNewLine(Self, FRow, FPos - FLastEnterPos + 1, ci+1);
+ end else if FText[ci] = #10 then
+ begin
+ inc(FRow);
+ FLastEnterPos := ci -1;
+ if @FOnNewLine <> nil then FOnNewLine(Self, FRow, FPos - FLastEnterPos + 1, ci+1);
+ end;
+ end;
+ FLen := ci - FPos + 1;
+ FTokenId := ptOther;
+ end;
+ '(':
+ begin
+ if FText[FPos + 1] = '*' then
+ begin
+ ci := FPos + 1;
+ while (FText[ci] <> #0) do begin
+ if (FText[ci] = '*') and (FText[ci + 1] = ')') then
+ Break;
+ if FText[ci] = #13 then
+ begin
+ inc(FRow);
+ if FText[ci+1] = #10 then
+ inc(ci);
+ FLastEnterPos := ci -1;
+ if @FOnNewLine <> nil then FOnNewLine(Self, FRow, FPos - FLastEnterPos + 1, ci+1);
+ end else if FText[ci] = #10 then
+ begin
+ inc(FRow);
+ FLastEnterPos := ci -1;
+ if @FOnNewLine <> nil then FOnNewLine(Self, FRow, FPos - FLastEnterPos + 1, ci+1);
+ end;
+ Inc(ci);
+ end;
+ FTokenId := ptOther;
+ if (FText[ci] <> #0) then
+ Inc(ci, 2);
+ FLen := ci - FPos;
+ end
+ else
+ begin
+ FTokenId := ptOther;
+ FLen := 1;
+ end;
+ end;
+ '/':
+ begin
+ if FText[FPos + 1] = '/' then
+ begin
+ ci := FPos + 1;
+ while (FText[ci] <> #0) and (FText[ci] <> #13) and
+ (FText[ci] <> #10) do begin
+ Inc(ci);
+ end;
+ FTokenId := ptOther;
+ FLen := ci - FPos;
+ end else
+ begin
+ FTokenId := ptOther;
+ FLen := 1;
+ end;
+ end;
+ '{':
+ begin
+ ci := FPos + 1;
+ while (FText[ci] <> #0) and (FText[ci] <> '}') do begin
+ if FText[ci] = #13 then
+ begin
+ inc(FRow);
+ if FText[ci+1] = #10 then
+ inc(ci);
+ FLastEnterPos := ci - 1;
+ if @FOnNewLine <> nil then FOnNewLine(Self, FRow, FPos - FLastEnterPos + 1, ci+1);
+ end else if FText[ci] = #10 then
+ begin
+ inc(FRow);
+ FLastEnterPos := ci - 1;
+ if @FOnNewLine <> nil then FOnNewLine(Self, FRow, FPos - FLastEnterPos + 1, ci+1);
+ end;
+ Inc(ci);
+ end;
+ if (FText[FPos + 1] = '$') or (FText[FPos + 1] = '.') then
+ FTokenId := ptDefine
+ else
+ FTokenId := ptOther;
+
+ FLen := ci - FPos + 1;
+ end;
+ else
+ begin
+ ci := FPos + 1;
+ while not (FText[ci] in [#0,'{', '(', '''', '/']) do
+ begin
+ if FText[ci] = #13 then
+ begin
+ inc(FRow);
+ if FText[ci+1] = #10 then
+ inc(ci);
+ FLastEnterPos := ci - 1;
+ if @FOnNewLine <> nil then FOnNewLine(Self, FRow, FPos - FLastEnterPos + 1, ci+1);
+ end else if FText[ci] = #10 then
+ begin
+ inc(FRow);
+ FLastEnterPos := ci -1 ;
+ if @FOnNewLine <> nil then FOnNewLine(Self, FRow, FPos - FLastEnterPos + 1, ci+1);
+ end;
+ Inc(Ci);
+ end;
+ FTokenId := ptOther;
+ FLen := ci - FPos;
+ end;
+ end;
+ FCol := FPos - FLastEnterPos + 1;
+ FToken := Copy(FData, FPos +1, FLen);
+end;
+
+procedure TPSPascalPreProcessorParser.SetText(const dta: tbtstring);
+begin
+ FData := dta;
+ FText := pAnsichar(FData);
+ FLen := 0;
+ FPos := 0;
+ FCol := 1;
+ FLastEnterPos := 0;
+ FRow := 1;
+ if @FOnNewLine <> nil then FOnNewLine(Self, 1, 1, 0);
+ Next;
+end;
+
+{ TPSPreProcessor }
+
+procedure TPSPreProcessor.AdjustMessage(Msg: TPSPascalCompilerMessage);
+var
+ Res: TPSLineInfoResults;
+begin
+ if CurrentLineInfo.GetLineInfo(Msg.ModuleName, Msg.Pos, Res) then
+ begin
+ Msg.SetCustomPos(res.Pos, Res.Row, Res.Col);
+ Msg.ModuleName := Res.Name;
+ end;
+end;
+
+procedure TPSPreProcessor.AdjustMessages(Comp: TPSPascalCompiler);
+var
+ i: Longint;
+begin
+ for i := 0 to Comp.MsgCount -1 do
+ AdjustMessage (Comp.Msg[i]);
+end;
+
+procedure TPSPreProcessor.Clear;
+begin
+ FDefineState.Clear;
+ FDefines.Clear;
+ FCurrentDefines.Clear;
+ FCurrentLineInfo.Clear;
+ FMainFile := '';
+end;
+
+constructor TPSPreProcessor.Create;
+begin
+ inherited Create;
+ FDefines := TStringList.Create;
+ FCurrentLineInfo := TPSLineInfoList.Create;
+ FCurrentDefines := TStringList.Create;
+ FDefines.Duplicates := dupIgnore;
+ FCurrentDefines.Duplicates := dupIgnore;
+ FDefineState := TPSDefineStates.Create;
+ FMaxLevel := 20;
+
+ doAddStdPredefines;
+end;
+
+destructor TPSPreProcessor.Destroy;
+begin
+ FDefineState.Free;
+ FCurrentDefines.Free;
+ FDefines.Free;
+ FCurrentLineInfo.Free;
+ inherited Destroy;
+end;
+
+procedure TPSPreProcessor.doAddStdPredefines;
+begin
+ //--- 20050708_jgv
+ FCurrentDefines.Add (Format ('VER%d', [PSCurrentBuildNo]));
+ {$IFDEF CPU386 }
+ FCurrentDefines.Add ('CPU386');
+ {$ENDIF }
+ {$IFDEF MSWINDOWS }
+ FCurrentDefines.Add ('MSWINDOWS');
+ FCurrentDefines.Add ('WIN32');
+ {$ENDIF }
+ {$IFDEF LINUX }
+ FCurrentDefines.Add ('LINUX');
+ {$ENDIF }
+end;
+
+procedure TPSPreProcessor.IntPreProcess(Level: Integer; const OrgFileName: tbtstring; FileName: tbtstring; Dest: TStream);
+var
+ Parser: TPSPascalPreProcessorParser;
+ dta: tbtstring;
+ item: TPSLineInfo;
+ s, name: tbtstring;
+ current, i: Longint;
+ ds: TPSDefineState;
+ AppContinue: Boolean;
+begin
+ if Level > MaxLevel then raise EPSPreProcessor.CreateFmt(RPS_TooManyNestedInclude, [FileName, OrgFileName]);
+ Parser := TPSPascalPreProcessorParser.Create;
+ try
+ Parser.OnNewLine := ParserNewLine;
+ if FileName = MainFileName then
+ begin
+ dta := MainFile;
+ end else
+ if (@OnNeedFile = nil) or (not OnNeedFile(Self, OrgFileName, FileName, dta)) then
+ raise EPSPreProcessor.CreateFmt(RPS_IncludeNotFound, [FileName, OrgFileName]);
+ Item := FCurrentLineInfo.Add;
+ current := FCurrentLineInfo.Count -1;
+ FCurrentLineInfo.Current := current;
+ Item.FStartPos := Dest.Position;
+ Item.FFileName := FileName;
+ Parser.SetText(dta);
+ while Parser.TokenId <> ptEOF do
+ begin
+ s := Parser.Token;
+ if Parser.TokenId = ptDefine then
+ begin
+ Delete(s,1,2); // delete the {$
+ Delete(s,length(s), 1); // delete the }
+
+ //-- 20050707_jgv trim right
+ i := length (s);
+ while (i > 0) and (s[i] = ' ') do begin
+ Delete (s, i, 1);
+ Dec (i);
+ end;
+ //-- end_jgv
+
+ if pos(tbtChar(' '), s) = 0 then
+ begin
+ name := uppercase(s);
+ s := '';
+ end else
+ begin
+ Name := uppercase(copy(s,1,pos(' ', s)-1));
+ Delete(s, 1, pos(' ', s));
+ end;
+
+ //-- 20050707_jgv - ask the application
+ AppContinue := True;
+ If @OnProcessDirective <> Nil then OnProcessDirective (Self, Parser, FDefineState.DoWrite, name, s, AppContinue);
+
+ If AppContinue then
+ //-- end jgv
+
+ if (Name = 'I') or (Name = 'INCLUDE') or (Name = '.INCLUDE') then
+ begin
+ if FDefineState.DoWrite then
+ begin
+ FAddedPosition := 0;
+ IntPreProcess(Level +1, FileName, s, Dest);
+ FCurrentLineInfo.Current := current;
+ FAddedPosition := Cardinal(Dest.Position) - Item.StartPos - Parser.Pos;
+ end;
+ end else if (Name = 'DEFINE') then
+ begin
+ if FDefineState.DoWrite then
+ begin
+ if pos(' ', s) <> 0 then raise EPSPreProcessor.CreateFmt(RPS_DefineTooManyParameters, [Parser.Row, Parser.Col]);
+ FCurrentDefines.Add(Uppercase(S));
+ end;
+ end else if (Name = 'UNDEF') then
+ begin
+ if FDefineState.DoWrite then
+ begin
+ if pos(' ', s) <> 0 then raise EPSPreProcessor.CreateFmt(RPS_DefineTooManyParameters, [Parser.Row, Parser.Col]);
+ i := FCurrentDefines.IndexOf(Uppercase(s));
+ if i <> -1 then
+ FCurrentDefines.Delete(i);
+ end;
+ end else if (Name = 'IFDEF') then
+ begin
+ if pos(' ', s) <> 0 then raise EPSPreProcessor.CreateFmt(RPS_DefineTooManyParameters, [Parser.Row, Parser.Col]);
+ //JeromeWelsh - nesting fix
+ if (FDefineState.DoWrite and (FCurrentDefines.IndexOf(Uppercase(s)) <> -1)) then
+ FDefineState.Add.DoWrite := True
+ else
+ FDefineState.Add.DoWrite := False;
+ end else if (Name = 'IFNDEF') then
+ begin
+ if pos(' ', s) <> 0 then raise EPSPreProcessor.CreateFmt(RPS_DefineTooManyParameters, [Parser.Row, Parser.Col]);
+ //JeromeWelsh - nesting fix
+ if (FCurrentDefines.IndexOf(Uppercase(s)) = -1) and FDefineState.DoWrite then
+ FDefineState.Add.DoWrite := True
+ else
+ FDefineState.Add.DoWrite := False;
+ end else if (Name = 'ENDIF') then
+ begin
+ //- jgv remove - borland use it (sysutils.pas)
+ //- if s <> '' then raise EPSPreProcessor.CreateFmt(RPS_DefineTooManyParameters, [Parser.Row, Parser.Col]);
+ if FDefineState.Count = 0 then
+ raise EPSPreProcessor.CreateFmt(RPS_NoIfdefForEndif, [Parser.Row, Parser.Col]);
+ FDefineState.Delete(FDefineState.Count -1); // remove define from list
+ end else if (Name = 'ELSE') then
+ begin
+ if s<> '' then raise EPSPreProcessor.CreateFmt(RPS_DefineTooManyParameters, [Parser.Row, Parser.Col]);
+ if FDefineState.Count = 0 then
+ raise EPSPreProcessor.CreateFmt(RPS_NoIfdefForElse, [Parser.Row, Parser.Col]);
+ ds := FDefineState[FDefineState.Count -1];
+ if ds.InElse then
+ raise EPSPreProcessor.CreateFmt(RPS_ElseTwice, [Parser.Row, Parser.Col]);
+ ds.FInElse := True;
+ //JeromeWelsh - nesting fix
+ ds.DoWrite := not ds.DoWrite and FDefineState.DoPrevWrite;
+ end
+
+ //-- 20050710_jgv custom application error process
+ else if Parser.Token[2] <> '.' then begin
+ If @OnProcessUnknowDirective <> Nil then begin
+ OnProcessUnknowDirective (Self, Parser, FDefineState.DoWrite, name, s, AppContinue);
+ end;
+ If AppContinue then
+ //-- end jgv
+
+ raise EPSPreProcessor.CreateFmt(RPS_UnknownCompilerDirective, [Parser.Row, Parser.Col]);
+ end;
+ end;
+
+ if (not FDefineState.DoWrite) or (Parser.TokenId = ptDefine) then
+ begin
+ SetLength(s, Length(Parser.Token));
+ for i := length(s) downto 1 do
+ s[i] := #32; // space
+ end;
+ Dest.Write(s[1], length(s));
+ Parser.Next;
+ end;
+ Item.FEndPos := Dest.Position;
+ finally
+ Parser.Free;
+ end;
+end;
+
+procedure TPSPreProcessor.ParserNewLine(Sender: TPSPascalPreProcessorParser; Row, Col, Pos: Cardinal);
+begin
+ if FCurrentLineInfo.Current >= FCurrentLineInfo.Count then exit; //errr ???
+ with FCurrentLineInfo.Items[FCurrentLineInfo.Current] do
+ begin
+ Pos := Pos + FAddedPosition;
+ FLineOffsets.Add(Pointer(Pos));
+ end;
+end;
+
+procedure TPSPreProcessor.PreProcess(const Filename: tbtstring; var Output: tbtstring);
+var
+ Stream: TMemoryStream;
+begin
+ FAddedPosition := 0;
+ FCurrentDefines.Assign(FDefines);
+ Stream := TMemoryStream.Create;
+ try
+ IntPreProcess(0, '', FileName, Stream);
+ Stream.Position := 0;
+ SetLength(Output, Stream.Size);
+ Stream.Read(Output[1], Length(Output));
+ finally
+ Stream.Free;
+ end;
+ if FDefineState.Count <> 0 then
+ raise EPSPreProcessor.Create(RPs_DefineNotClosed);
+end;
+
+{ TPSDefineStates }
+
+function TPSDefineStates.Add: TPSDefineState;
+begin
+ Result := TPSDefineState.Create;
+ FItems.Add(Result);
+end;
+
+procedure TPSDefineStates.Clear;
+var
+ i: Longint;
+begin
+ for i := Longint(FItems.Count) -1 downto 0 do
+ TPSDefineState(FItems[i]).Free;
+ FItems.Clear;
+end;
+
+constructor TPSDefineStates.Create;
+begin
+ inherited Create;
+ FItems := TIfList.Create;
+end;
+
+procedure TPSDefineStates.Delete(I: Integer);
+begin
+ TPSDefineState(FItems[i]).Free;
+ FItems.Delete(i);
+end;
+
+destructor TPSDefineStates.Destroy;
+var
+ i: Longint;
+begin
+ for i := Longint(FItems.Count) -1 downto 0 do
+ TPSDefineState(FItems[i]).Free;
+ FItems.Free;
+ inherited Destroy;
+end;
+
+function TPSDefineStates.GetCount: Longint;
+begin
+ Result := FItems.Count;
+end;
+
+function TPSDefineStates.GetItem(I: Integer): TPSDefineState;
+begin
+ Result := FItems[i];
+end;
+
+function TPSDefineStates.GetWrite: Boolean;
+begin
+ if FItems.Count = 0 then
+ result := true
+ else Result := TPSDefineState(FItems[FItems.Count -1]).DoWrite;
+end;
+
+//JeromeWelsh - nesting fix
+function TPSDefineStates.GetPrevWrite: Boolean;
+begin
+ if FItems.Count < 2 then
+ result := true
+ else Result := TPSDefineState(FItems[FItems.Count -2]).DoWrite;
+end;
+
+end.
+
diff --git a/Units/PascalScript/uPSR_DB.pas b/Units/PascalScript/uPSR_DB.pas
new file mode 100644
index 0000000..3c2fb80
--- /dev/null
+++ b/Units/PascalScript/uPSR_DB.pas
@@ -0,0 +1,2094 @@
+{runtime DB support}
+Unit uPSR_DB;
+{$I PascalScript.inc}
+Interface
+Uses uPSRuntime, uPSUtils, SysUtils;
+
+procedure RIRegisterTDATASET(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTPARAMS(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTPARAM(Cl: TPSRuntimeClassImporter);
+
+{$IFNDEF FPC}
+procedure RIRegisterTGUIDFIELD(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTVARIANTFIELD(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTREFERENCEFIELD(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTDATASETFIELD(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTARRAYFIELD(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTADTFIELD(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTOBJECTFIELD(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTWIDESTRINGFIELD(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTFIELDLIST(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTFIELDDEFLIST(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTFLATLIST(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTDEFCOLLECTION(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTNAMEDITEM(Cl: TPSRuntimeClassImporter);
+
+{$IFDEF DELPHI6UP}
+procedure RIRegisterTFMTBCDFIELD(Cl: TPSRuntimeClassImporter);
+{$ENDIF}
+procedure RIRegisterTBCDFIELD(Cl: TPSRuntimeClassImporter);
+
+{$ENDIF}
+
+procedure RIRegisterTGRAPHICFIELD(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTMEMOFIELD(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTBLOBFIELD(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTVARBYTESFIELD(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTBYTESFIELD(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTBINARYFIELD(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTTIMEFIELD(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTDATEFIELD(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTDATETIMEFIELD(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTBOOLEANFIELD(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTCURRENCYFIELD(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTFLOATFIELD(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTAUTOINCFIELD(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTWORDFIELD(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTLARGEINTFIELD(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTSMALLINTFIELD(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTINTEGERFIELD(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTNUMERICFIELD(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTSTRINGFIELD(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTFIELD(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTLOOKUPLIST(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTFIELDS(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTINDEXDEFS(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTINDEXDEF(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTFIELDDEFS(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTFIELDDEF(Cl: TPSRuntimeClassImporter);
+procedure RIRegister_DB(CL: TPSRuntimeClassImporter);
+
+implementation
+Uses DB, {$IFDEF DELPHI6UP}{$IFNDEF FPC}FMTBcd, MaskUtils,{$ENDIF}{$ENDIF}Classes;
+
+procedure TDATASETONPOSTERROR_W(Self: TDATASET; const T: TDATASETERROREVENT);
+begin Self.ONPOSTERROR := T; end;
+
+procedure TDATASETONPOSTERROR_R(Self: TDATASET; var T: TDATASETERROREVENT);
+begin T := Self.ONPOSTERROR; end;
+
+procedure TDATASETONNEWRECORD_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT);
+begin Self.ONNEWRECORD := T; end;
+
+procedure TDATASETONNEWRECORD_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT);
+begin T := Self.ONNEWRECORD; end;
+
+procedure TDATASETONFILTERRECORD_W(Self: TDATASET; const T: TFILTERRECORDEVENT);
+begin Self.ONFILTERRECORD := T; end;
+
+procedure TDATASETONFILTERRECORD_R(Self: TDATASET; var T: TFILTERRECORDEVENT);
+begin T := Self.ONFILTERRECORD; end;
+
+procedure TDATASETONEDITERROR_W(Self: TDATASET; const T: TDATASETERROREVENT);
+begin Self.ONEDITERROR := T; end;
+
+procedure TDATASETONEDITERROR_R(Self: TDATASET; var T: TDATASETERROREVENT);
+begin T := Self.ONEDITERROR; end;
+
+procedure TDATASETONDELETEERROR_W(Self: TDATASET; const T: TDATASETERROREVENT);
+begin Self.ONDELETEERROR := T; end;
+
+procedure TDATASETONDELETEERROR_R(Self: TDATASET; var T: TDATASETERROREVENT);
+begin T := Self.ONDELETEERROR; end;
+
+procedure TDATASETONCALCFIELDS_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT);
+begin Self.ONCALCFIELDS := T; end;
+
+procedure TDATASETONCALCFIELDS_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT);
+begin T := Self.ONCALCFIELDS; end;
+
+{$IFNDEF FPC}
+procedure TDATASETAFTERREFRESH_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT);
+begin Self.AFTERREFRESH := T; end;
+
+procedure TDATASETAFTERREFRESH_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT);
+begin T := Self.AFTERREFRESH; end;
+
+procedure TDATASETBEFOREREFRESH_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT);
+begin Self.BEFOREREFRESH := T; end;
+
+procedure TDATASETBEFOREREFRESH_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT);
+begin T := Self.BEFOREREFRESH; end;
+
+{$ENDIF}
+
+procedure TDATASETAFTERSCROLL_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT);
+begin Self.AFTERSCROLL := T; end;
+
+procedure TDATASETAFTERSCROLL_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT);
+begin T := Self.AFTERSCROLL; end;
+
+procedure TDATASETBEFORESCROLL_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT);
+begin Self.BEFORESCROLL := T; end;
+
+procedure TDATASETBEFORESCROLL_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT);
+begin T := Self.BEFORESCROLL; end;
+
+procedure TDATASETAFTERDELETE_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT);
+begin Self.AFTERDELETE := T; end;
+
+procedure TDATASETAFTERDELETE_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT);
+begin T := Self.AFTERDELETE; end;
+
+procedure TDATASETBEFOREDELETE_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT);
+begin Self.BEFOREDELETE := T; end;
+
+procedure TDATASETBEFOREDELETE_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT);
+begin T := Self.BEFOREDELETE; end;
+
+procedure TDATASETAFTERCANCEL_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT);
+begin Self.AFTERCANCEL := T; end;
+
+procedure TDATASETAFTERCANCEL_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT);
+begin T := Self.AFTERCANCEL; end;
+
+procedure TDATASETBEFORECANCEL_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT);
+begin Self.BEFORECANCEL := T; end;
+
+procedure TDATASETBEFORECANCEL_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT);
+begin T := Self.BEFORECANCEL; end;
+
+procedure TDATASETAFTERPOST_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT);
+begin Self.AFTERPOST := T; end;
+
+procedure TDATASETAFTERPOST_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT);
+begin T := Self.AFTERPOST; end;
+
+procedure TDATASETBEFOREPOST_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT);
+begin Self.BEFOREPOST := T; end;
+
+procedure TDATASETBEFOREPOST_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT);
+begin T := Self.BEFOREPOST; end;
+
+procedure TDATASETAFTEREDIT_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT);
+begin Self.AFTEREDIT := T; end;
+
+procedure TDATASETAFTEREDIT_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT);
+begin T := Self.AFTEREDIT; end;
+
+procedure TDATASETBEFOREEDIT_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT);
+begin Self.BEFOREEDIT := T; end;
+
+procedure TDATASETBEFOREEDIT_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT);
+begin T := Self.BEFOREEDIT; end;
+
+procedure TDATASETAFTERINSERT_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT);
+begin Self.AFTERINSERT := T; end;
+
+procedure TDATASETAFTERINSERT_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT);
+begin T := Self.AFTERINSERT; end;
+
+procedure TDATASETBEFOREINSERT_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT);
+begin Self.BEFOREINSERT := T; end;
+
+procedure TDATASETBEFOREINSERT_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT);
+begin T := Self.BEFOREINSERT; end;
+
+procedure TDATASETAFTERCLOSE_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT);
+begin Self.AFTERCLOSE := T; end;
+
+procedure TDATASETAFTERCLOSE_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT);
+begin T := Self.AFTERCLOSE; end;
+
+procedure TDATASETBEFORECLOSE_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT);
+begin Self.BEFORECLOSE := T; end;
+
+procedure TDATASETBEFORECLOSE_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT);
+begin T := Self.BEFORECLOSE; end;
+
+procedure TDATASETAFTEROPEN_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT);
+begin Self.AFTEROPEN := T; end;
+
+procedure TDATASETAFTEROPEN_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT);
+begin T := Self.AFTEROPEN; end;
+
+procedure TDATASETBEFOREOPEN_W(Self: TDATASET; const T: TDATASETNOTIFYEVENT);
+begin Self.BEFOREOPEN := T; end;
+
+procedure TDATASETBEFOREOPEN_R(Self: TDATASET; var T: TDATASETNOTIFYEVENT);
+begin T := Self.BEFOREOPEN; end;
+
+procedure TDATASETAUTOCALCFIELDS_W(Self: TDATASET; const T: BOOLEAN);
+begin Self.AUTOCALCFIELDS := T; end;
+
+procedure TDATASETAUTOCALCFIELDS_R(Self: TDATASET; var T: BOOLEAN);
+begin T := Self.AUTOCALCFIELDS; end;
+
+procedure TDATASETACTIVE_W(Self: TDATASET; const T: BOOLEAN);
+begin Self.ACTIVE := T; end;
+
+procedure TDATASETACTIVE_R(Self: TDATASET; var T: BOOLEAN);
+begin T := Self.ACTIVE; end;
+
+procedure TDATASETFILTEROPTIONS_W(Self: TDATASET; const T: TFILTEROPTIONS);
+begin Self.FILTEROPTIONS := T; end;
+
+procedure TDATASETFILTEROPTIONS_R(Self: TDATASET; var T: TFILTEROPTIONS);
+begin T := Self.FILTEROPTIONS; end;
+
+procedure TDATASETFILTERED_W(Self: TDATASET; const T: BOOLEAN);
+begin Self.FILTERED := T; end;
+
+procedure TDATASETFILTERED_R(Self: TDATASET; var T: BOOLEAN);
+begin T := Self.FILTERED; end;
+
+procedure TDATASETFILTER_W(Self: TDATASET; const T: String);
+begin Self.FILTER := T; end;
+
+procedure TDATASETFILTER_R(Self: TDATASET; var T: String);
+begin T := Self.FILTER; end;
+
+procedure TDATASETSTATE_R(Self: TDATASET; var T: TDATASETSTATE);
+begin T := Self.STATE; end;
+
+{$IFNDEF FPC}
+procedure TDATASETSPARSEARRAYS_W(Self: TDATASET; const T: BOOLEAN);
+begin Self.SPARSEARRAYS := T; end;
+
+procedure TDATASETSPARSEARRAYS_R(Self: TDATASET; var T: BOOLEAN);
+begin T := Self.SPARSEARRAYS; end;
+{$ENDIF}
+
+procedure TDATASETRECORDSIZE_R(Self: TDATASET; var T: WORD);
+begin T := Self.RECORDSIZE; end;
+
+procedure TDATASETRECNO_W(Self: TDATASET; const T: INTEGER);
+begin Self.RECNO := T; end;
+
+procedure TDATASETRECNO_R(Self: TDATASET; var T: INTEGER);
+begin T := Self.RECNO; end;
+
+procedure TDATASETRECORDCOUNT_R(Self: TDATASET; var T: INTEGER);
+begin T := Self.RECORDCOUNT; end;
+
+{$IFNDEF FPC}
+procedure TDATASETOBJECTVIEW_W(Self: TDATASET; const T: BOOLEAN);
+begin Self.OBJECTVIEW := T; end;
+
+procedure TDATASETOBJECTVIEW_R(Self: TDATASET; var T: BOOLEAN);
+begin T := Self.OBJECTVIEW; end;
+{$ENDIF}
+
+procedure TDATASETMODIFIED_R(Self: TDATASET; var T: BOOLEAN);
+begin T := Self.MODIFIED; end;
+
+{$IFDEF DELPHI6UP}
+procedure TDATASETISUNIDIRECTIONAL_R(Self: TDATASET; var T: BOOLEAN);
+begin T := Self.ISUNIDIRECTIONAL; end;
+{$ENDIF}
+
+procedure TDATASETFOUND_R(Self: TDATASET; var T: BOOLEAN);
+begin T := Self.FOUND; end;
+
+procedure TDATASETFIELDVALUES_W(Self: TDATASET; const T: VARIANT; const t1: String);
+begin Self.FIELDVALUES[t1] := T; end;
+
+procedure TDATASETFIELDVALUES_R(Self: TDATASET; var T: VARIANT; const t1: String);
+begin T := Self.FIELDVALUES[t1]; end;
+
+procedure TDATASETFIELDS_R(Self: TDATASET; var T: TFIELDS);
+begin T := Self.FIELDS; end;
+
+{$IFNDEF FPC}
+
+procedure TDATASETFIELDLIST_R(Self: TDATASET; var T: TFIELDLIST);
+begin T := Self.FIELDLIST; end;
+
+
+procedure TDATASETFIELDDEFLIST_R(Self: TDATASET; var T: TFIELDDEFLIST);
+begin T := Self.FIELDDEFLIST; end;
+
+procedure TDATASETFIELDDEFS_W(Self: TDATASET; const T: TFIELDDEFS);
+begin Self.FIELDDEFS := T; end;
+
+procedure TDATASETFIELDDEFS_R(Self: TDATASET; var T: TFIELDDEFS);
+begin T := Self.FIELDDEFS; end;
+
+procedure TDATASETBLOCKREADSIZE_W(Self: TDATASET; const T: INTEGER);
+begin Self.BLOCKREADSIZE := T; end;
+
+procedure TDATASETBLOCKREADSIZE_R(Self: TDATASET; var T: INTEGER);
+begin T := Self.BLOCKREADSIZE; end;
+
+procedure TDATASETDESIGNER_R(Self: TDATASET; var T: TDATASETDESIGNER);
+begin T := Self.DESIGNER; end;
+
+
+procedure TDATASETDATASETFIELD_W(Self: TDATASET; const T: TDATASETFIELD);
+begin Self.DATASETFIELD := T; end;
+
+
+
+procedure TDATASETDATASETFIELD_R(Self: TDATASET; var T: TDATASETFIELD);
+begin T := Self.DATASETFIELD; end;
+
+
+procedure TDATASETAGGFIELDS_R(Self: TDATASET; var T: TFIELDS);
+begin T := Self.AGGFIELDS; end;
+
+
+
+{$ENDIF}
+
+procedure TDATASETFIELDCOUNT_R(Self: TDATASET; var T: INTEGER);
+begin T := Self.FIELDCOUNT; end;
+
+
+procedure TDATASETEOF_R(Self: TDATASET; var T: BOOLEAN);
+begin T := Self.EOF; end;
+
+procedure TDATASETDEFAULTFIELDS_R(Self: TDATASET; var T: BOOLEAN);
+begin T := Self.DEFAULTFIELDS; end;
+
+procedure TDATASETDATASOURCE_R(Self: TDATASET; var T: TDATASOURCE);
+begin T := Self.DATASOURCE; end;
+
+
+
+procedure TDATASETCANMODIFY_R(Self: TDATASET; var T: BOOLEAN);
+begin T := Self.CANMODIFY; end;
+
+//procedure TDATASETBOOKMARK_W(Self: TDATASET; const T: TBOOKMARKSTR);
+//begin Self.BOOKMARK := T; end;
+
+//procedure TDATASETBOOKMARK_R(Self: TDATASET; var T: TBOOKMARKSTR);
+//begin T := Self.BOOKMARK; end;
+
+procedure TDATASETBOF_R(Self: TDATASET; var T: BOOLEAN);
+begin T := Self.BOF; end;
+
+procedure TPARAMSPARAMVALUES_W(Self: TPARAMS; const T: VARIANT; const t1: String);
+begin Self.PARAMVALUES[t1] := T; end;
+
+procedure TPARAMSPARAMVALUES_R(Self: TPARAMS; var T: VARIANT; const t1: String);
+begin T := Self.PARAMVALUES[t1]; end;
+
+procedure TPARAMSITEMS_W(Self: TPARAMS; const T: TPARAM; const t1: INTEGER);
+begin Self.ITEMS[t1] := T; end;
+
+procedure TPARAMSITEMS_R(Self: TPARAMS; var T: TPARAM; const t1: INTEGER);
+begin T := Self.ITEMS[t1]; end;
+
+procedure TPARAMVALUE_W(Self: TPARAM; const T: VARIANT);
+begin Self.VALUE := T; end;
+
+procedure TPARAMVALUE_R(Self: TPARAM; var T: VARIANT);
+begin T := Self.VALUE; end;
+
+
+{$IFDEF DELPHI6UP}
+procedure TPARAMSIZE_W(Self: TPARAM; const T: INTEGER);
+begin Self.SIZE := T; end;
+
+procedure TPARAMSIZE_R(Self: TPARAM; var T: INTEGER);
+begin T := Self.SIZE; end;
+{$ENDIF}
+
+procedure TPARAMPARAMTYPE_W(Self: TPARAM; const T: TPARAMTYPE);
+begin Self.PARAMTYPE := T; end;
+
+procedure TPARAMPARAMTYPE_R(Self: TPARAM; var T: TPARAMTYPE);
+begin T := Self.PARAMTYPE; end;
+
+procedure TPARAMNAME_W(Self: TPARAM; const T: String);
+begin Self.NAME := T; end;
+
+procedure TPARAMNAME_R(Self: TPARAM; var T: String);
+begin T := Self.NAME; end;
+
+{$IFDEF DELPHI6UP}
+procedure TPARAMNUMERICSCALE_W(Self: TPARAM; const T: INTEGER);
+begin Self.NUMERICSCALE := T; end;
+
+procedure TPARAMNUMERICSCALE_R(Self: TPARAM; var T: INTEGER);
+begin T := Self.NUMERICSCALE; end;
+{$ENDIF}
+{$IFDEF DELPHI6UP}
+
+procedure TPARAMPRECISION_W(Self: TPARAM; const T: INTEGER);
+begin Self.PRECISION := T; end;
+
+procedure TPARAMPRECISION_R(Self: TPARAM; var T: INTEGER);
+begin T := Self.PRECISION; end;
+{$ENDIF}
+procedure TPARAMDATATYPE_W(Self: TPARAM; const T: TFIELDTYPE);
+begin Self.DATATYPE := T; end;
+
+procedure TPARAMDATATYPE_R(Self: TPARAM; var T: TFIELDTYPE);
+begin T := Self.DATATYPE; end;
+
+procedure TPARAMTEXT_W(Self: TPARAM; const T: String);
+begin Self.TEXT := T; end;
+
+procedure TPARAMTEXT_R(Self: TPARAM; var T: String);
+begin T := Self.TEXT; end;
+
+procedure TPARAMNATIVESTR_W(Self: TPARAM; const T: String);
+begin Self.NATIVESTR := T; end;
+
+procedure TPARAMNATIVESTR_R(Self: TPARAM; var T: String);
+begin T := Self.NATIVESTR; end;
+
+procedure TPARAMISNULL_R(Self: TPARAM; var T: BOOLEAN);
+begin T := Self.ISNULL; end;
+
+procedure TPARAMBOUND_W(Self: TPARAM; const T: BOOLEAN);
+begin Self.BOUND := T; end;
+
+procedure TPARAMBOUND_R(Self: TPARAM; var T: BOOLEAN);
+begin T := Self.BOUND; end;
+
+procedure TPARAMASWORD_W(Self: TPARAM; const T: LONGINT);
+begin Self.ASWORD := T; end;
+
+procedure TPARAMASWORD_R(Self: TPARAM; var T: LONGINT);
+begin T := Self.ASWORD; end;
+
+procedure TPARAMASTIME_W(Self: TPARAM; const T: TDATETIME);
+begin Self.ASTIME := T; end;
+
+procedure TPARAMASTIME_R(Self: TPARAM; var T: TDATETIME);
+begin T := Self.ASTIME; end;
+
+procedure TPARAMASSTRING_W(Self: TPARAM; const T: String);
+begin Self.ASSTRING := T; end;
+
+procedure TPARAMASSTRING_R(Self: TPARAM; var T: String);
+begin T := Self.ASSTRING; end;
+
+procedure TPARAMASMEMO_W(Self: TPARAM; const T: String);
+begin Self.ASMEMO := T; end;
+
+procedure TPARAMASMEMO_R(Self: TPARAM; var T: String);
+begin T := Self.ASMEMO; end;
+
+procedure TPARAMASSMALLINT_W(Self: TPARAM; const T: LONGINT);
+begin Self.ASSMALLINT := T; end;
+
+procedure TPARAMASSMALLINT_R(Self: TPARAM; var T: LONGINT);
+begin T := Self.ASSMALLINT; end;
+
+procedure TPARAMASINTEGER_W(Self: TPARAM; const T: LONGINT);
+begin Self.ASINTEGER := T; end;
+
+procedure TPARAMASINTEGER_R(Self: TPARAM; var T: LONGINT);
+begin T := Self.ASINTEGER; end;
+
+procedure TPARAMASFLOAT_W(Self: TPARAM; const T: DOUBLE);
+begin Self.ASFLOAT := T; end;
+
+procedure TPARAMASFLOAT_R(Self: TPARAM; var T: DOUBLE);
+begin T := Self.ASFLOAT; end;
+
+procedure TPARAMASDATETIME_W(Self: TPARAM; const T: TDATETIME);
+begin Self.ASDATETIME := T; end;
+
+procedure TPARAMASDATETIME_R(Self: TPARAM; var T: TDATETIME);
+begin T := Self.ASDATETIME; end;
+
+procedure TPARAMASDATE_W(Self: TPARAM; const T: TDATETIME);
+begin Self.ASDATE := T; end;
+
+procedure TPARAMASDATE_R(Self: TPARAM; var T: TDATETIME);
+begin T := Self.ASDATE; end;
+
+procedure TPARAMASCURRENCY_W(Self: TPARAM; const T: CURRENCY);
+begin Self.ASCURRENCY := T; end;
+
+procedure TPARAMASCURRENCY_R(Self: TPARAM; var T: CURRENCY);
+begin T := Self.ASCURRENCY; end;
+
+procedure TPARAMASBOOLEAN_W(Self: TPARAM; const T: BOOLEAN);
+begin Self.ASBOOLEAN := T; end;
+
+procedure TPARAMASBOOLEAN_R(Self: TPARAM; var T: BOOLEAN);
+begin T := Self.ASBOOLEAN; end;
+
+procedure TPARAMASBLOB_W(Self: TPARAM; const T: TBLOBDATA);
+begin Self.ASBLOB := T; end;
+
+procedure TPARAMASBLOB_R(Self: TPARAM; var T: TBLOBDATA);
+begin T := Self.ASBLOB; end;
+
+{$IFNDEF FPC}
+
+{$IFDEF DELPHI6UP}
+procedure TPARAMASFMTBCD_W(Self: TPARAM; const T: TBCD);
+begin Self.ASFMTBCD := T; end;
+
+procedure TPARAMASFMTBCD_R(Self: TPARAM; var T: TBCD);
+begin T := Self.ASFMTBCD; end;
+{$ENDIF}
+procedure TPARAMASBCD_W(Self: TPARAM; const T: CURRENCY);
+begin Self.ASBCD := T; end;
+
+procedure TPARAMASBCD_R(Self: TPARAM; var T: CURRENCY);
+begin T := Self.ASBCD; end;
+
+procedure TREFERENCEFIELDREFERENCETABLENAME_W(Self: TREFERENCEFIELD; const T: String);
+begin Self.REFERENCETABLENAME := T; end;
+
+procedure TREFERENCEFIELDREFERENCETABLENAME_R(Self: TREFERENCEFIELD; var T: String);
+begin T := Self.REFERENCETABLENAME; end;
+
+
+procedure TDATASETFIELDINCLUDEOBJECTFIELD_W(Self: TDATASETFIELD; const T: BOOLEAN);
+begin Self.INCLUDEOBJECTFIELD := T; end;
+
+procedure TDATASETFIELDINCLUDEOBJECTFIELD_R(Self: TDATASETFIELD; var T: BOOLEAN);
+begin T := Self.INCLUDEOBJECTFIELD; end;
+
+procedure TDATASETFIELDNESTEDDATASET_R(Self: TDATASETFIELD; var T: TDATASET);
+begin T := Self.NESTEDDATASET; end;
+
+procedure TOBJECTFIELDOBJECTTYPE_W(Self: TOBJECTFIELD; const T: String);
+begin Self.OBJECTTYPE := T; end;
+
+procedure TOBJECTFIELDOBJECTTYPE_R(Self: TOBJECTFIELD; var T: String);
+begin T := Self.OBJECTTYPE; end;
+
+procedure TOBJECTFIELDUNNAMED_R(Self: TOBJECTFIELD; var T: BOOLEAN);
+begin T := Self.UNNAMED; end;
+
+procedure TOBJECTFIELDFIELDVALUES_W(Self: TOBJECTFIELD; const T: VARIANT; const t1: INTEGER);
+begin Self.FIELDVALUES[t1] := T; end;
+
+procedure TOBJECTFIELDFIELDVALUES_R(Self: TOBJECTFIELD; var T: VARIANT; const t1: INTEGER);
+begin T := Self.FIELDVALUES[t1]; end;
+
+procedure TOBJECTFIELDFIELDS_R(Self: TOBJECTFIELD; var T: TFIELDS);
+begin T := Self.FIELDS; end;
+
+procedure TOBJECTFIELDFIELDCOUNT_R(Self: TOBJECTFIELD; var T: INTEGER);
+begin T := Self.FIELDCOUNT; end;
+{$ENDIF}
+
+
+{$IFNDEF FPC}
+{$IFDEF DELPHI6UP}
+procedure TBLOBFIELDGRAPHICHEADER_W(Self: TBLOBFIELD; const T: BOOLEAN);
+begin Self.GRAPHICHEADER := T; end;
+
+procedure TBLOBFIELDGRAPHICHEADER_R(Self: TBLOBFIELD; var T: BOOLEAN);
+begin T := Self.GRAPHICHEADER; end;
+{$ENDIF}
+{$ENDIF}
+
+procedure TBLOBFIELDBLOBTYPE_W(Self: TBLOBFIELD; const T: TBLOBTYPE);
+begin Self.BLOBTYPE := T; end;
+
+procedure TBLOBFIELDBLOBTYPE_R(Self: TBLOBFIELD; var T: TBLOBTYPE);
+begin T := Self.BLOBTYPE; end;
+
+procedure TBLOBFIELDTRANSLITERATE_W(Self: TBLOBFIELD; const T: BOOLEAN);
+begin Self.TRANSLITERATE := T; end;
+
+procedure TBLOBFIELDTRANSLITERATE_R(Self: TBLOBFIELD; var T: BOOLEAN);
+begin T := Self.TRANSLITERATE; end;
+
+procedure TBLOBFIELDVALUE_W(Self: TBLOBFIELD; const T: String);
+{$IFDEF DELPHI2009UP}
+var
+ b: TBytes;
+begin
+ setLEngth(b, Length(T));
+ Move(T[1], b[0], Length(T));
+ self.Value := b;
+ {$ELSE}
+begin
+ Self.VALUE := T;
+ {$ENDIF}
+end;
+
+procedure TBLOBFIELDVALUE_R(Self: TBLOBFIELD; var T: String);
+begin
+{$IFDEF DELPHI2009UP}
+ SetLength(t, Length(SElf.Value));
+ Move(Self.Value[0], t[1], LEngth(T));
+{$ELSE}
+ T := Self.VALUE;
+{$ENDIF}
+end;
+
+procedure TBLOBFIELDMODIFIED_W(Self: TBLOBFIELD; const T: BOOLEAN);
+begin Self.MODIFIED := T; end;
+
+procedure TBLOBFIELDMODIFIED_R(Self: TBLOBFIELD; var T: BOOLEAN);
+begin T := Self.MODIFIED; end;
+
+procedure TBLOBFIELDBLOBSIZE_R(Self: TBLOBFIELD; var T: INTEGER);
+begin T := Self.BLOBSIZE; end;
+
+{$IFNDEF FPC}
+{$IFDEF DELPHI6UP}
+procedure TFMTBCDFIELDPRECISION_W(Self: TFMTBCDFIELD; const T: INTEGER);
+begin Self.PRECISION := T; end;
+
+procedure TFMTBCDFIELDPRECISION_R(Self: TFMTBCDFIELD; var T: INTEGER);
+begin T := Self.PRECISION; end;
+
+procedure TFMTBCDFIELDMINVALUE_W(Self: TFMTBCDFIELD; const T: String);
+begin Self.MINVALUE := T; end;
+
+procedure TFMTBCDFIELDMINVALUE_R(Self: TFMTBCDFIELD; var T: String);
+begin T := Self.MINVALUE; end;
+
+procedure TFMTBCDFIELDMAXVALUE_W(Self: TFMTBCDFIELD; const T: String);
+begin Self.MAXVALUE := T; end;
+
+procedure TFMTBCDFIELDMAXVALUE_R(Self: TFMTBCDFIELD; var T: String);
+begin T := Self.MAXVALUE; end;
+
+procedure TFMTBCDFIELDCURRENCY_W(Self: TFMTBCDFIELD; const T: BOOLEAN);
+begin Self.CURRENCY := T; end;
+
+procedure TFMTBCDFIELDCURRENCY_R(Self: TFMTBCDFIELD; var T: BOOLEAN);
+begin T := Self.CURRENCY; end;
+
+procedure TFMTBCDFIELDVALUE_W(Self: TFMTBCDFIELD; const T: TBCD);
+begin Self.VALUE := T; end;
+
+procedure TFMTBCDFIELDVALUE_R(Self: TFMTBCDFIELD; var T: TBCD);
+begin T := Self.VALUE; end;
+{$ENDIF}
+
+procedure TBCDFIELDPRECISION_W(Self: TBCDFIELD; const T: INTEGER);
+begin Self.PRECISION := T; end;
+
+procedure TBCDFIELDPRECISION_R(Self: TBCDFIELD; var T: INTEGER);
+begin T := Self.PRECISION; end;
+
+procedure TBCDFIELDMINVALUE_W(Self: TBCDFIELD; const T: CURRENCY);
+begin Self.MINVALUE := T; end;
+
+procedure TBCDFIELDMINVALUE_R(Self: TBCDFIELD; var T: CURRENCY);
+begin T := Self.MINVALUE; end;
+
+procedure TBCDFIELDMAXVALUE_W(Self: TBCDFIELD; const T: CURRENCY);
+begin Self.MAXVALUE := T; end;
+
+procedure TBCDFIELDMAXVALUE_R(Self: TBCDFIELD; var T: CURRENCY);
+begin T := Self.MAXVALUE; end;
+
+procedure TBCDFIELDCURRENCY_W(Self: TBCDFIELD; const T: BOOLEAN);
+begin Self.CURRENCY := T; end;
+
+procedure TBCDFIELDCURRENCY_R(Self: TBCDFIELD; var T: BOOLEAN);
+begin T := Self.CURRENCY; end;
+
+procedure TBCDFIELDVALUE_W(Self: TBCDFIELD; const T: CURRENCY);
+begin Self.VALUE := T; end;
+
+procedure TBCDFIELDVALUE_R(Self: TBCDFIELD; var T: CURRENCY);
+begin T := Self.VALUE; end;
+{$ENDIF}
+
+
+procedure TDATETIMEFIELDDISPLAYFORMAT_W(Self: TDATETIMEFIELD; const T: String);
+begin Self.DISPLAYFORMAT := T; end;
+
+procedure TDATETIMEFIELDDISPLAYFORMAT_R(Self: TDATETIMEFIELD; var T: String);
+begin T := Self.DISPLAYFORMAT; end;
+
+procedure TDATETIMEFIELDVALUE_W(Self: TDATETIMEFIELD; const T: TDATETIME);
+begin Self.VALUE := T; end;
+
+procedure TDATETIMEFIELDVALUE_R(Self: TDATETIMEFIELD; var T: TDATETIME);
+begin T := Self.VALUE; end;
+
+procedure TBOOLEANFIELDDISPLAYVALUES_W(Self: TBOOLEANFIELD; const T: String);
+begin Self.DISPLAYVALUES := T; end;
+
+procedure TBOOLEANFIELDDISPLAYVALUES_R(Self: TBOOLEANFIELD; var T: String);
+begin T := Self.DISPLAYVALUES; end;
+
+procedure TBOOLEANFIELDVALUE_W(Self: TBOOLEANFIELD; const T: BOOLEAN);
+begin Self.VALUE := T; end;
+
+procedure TBOOLEANFIELDVALUE_R(Self: TBOOLEANFIELD; var T: BOOLEAN);
+begin T := Self.VALUE; end;
+
+procedure TFLOATFIELDPRECISION_W(Self: TFLOATFIELD; const T: INTEGER);
+begin Self.PRECISION := T; end;
+
+procedure TFLOATFIELDPRECISION_R(Self: TFLOATFIELD; var T: INTEGER);
+begin T := Self.PRECISION; end;
+
+procedure TFLOATFIELDMINVALUE_W(Self: TFLOATFIELD; const T: DOUBLE);
+begin Self.MINVALUE := T; end;
+
+procedure TFLOATFIELDMINVALUE_R(Self: TFLOATFIELD; var T: DOUBLE);
+begin T := Self.MINVALUE; end;
+
+procedure TFLOATFIELDMAXVALUE_W(Self: TFLOATFIELD; const T: DOUBLE);
+begin Self.MAXVALUE := T; end;
+
+procedure TFLOATFIELDMAXVALUE_R(Self: TFLOATFIELD; var T: DOUBLE);
+begin T := Self.MAXVALUE; end;
+
+{$IFNDEF FPC}
+procedure TFLOATFIELDCURRENCY_W(Self: TFLOATFIELD; const T: BOOLEAN);
+begin Self.CURRENCY := T; end;
+
+procedure TFLOATFIELDCURRENCY_R(Self: TFLOATFIELD; var T: BOOLEAN);
+begin T := Self.CURRENCY; end;
+{$ENDIF}
+
+procedure TFLOATFIELDVALUE_W(Self: TFLOATFIELD; const T: DOUBLE);
+begin Self.VALUE := T; end;
+
+procedure TFLOATFIELDVALUE_R(Self: TFLOATFIELD; var T: DOUBLE);
+begin T := Self.VALUE; end;
+
+procedure TLARGEINTFIELDMINVALUE_W(Self: TLARGEINTFIELD; const T: LARGEINT);
+begin Self.MINVALUE := T; end;
+
+procedure TLARGEINTFIELDMINVALUE_R(Self: TLARGEINTFIELD; var T: LARGEINT);
+begin T := Self.MINVALUE; end;
+
+procedure TLARGEINTFIELDMAXVALUE_W(Self: TLARGEINTFIELD; const T: LARGEINT);
+begin Self.MAXVALUE := T; end;
+
+procedure TLARGEINTFIELDMAXVALUE_R(Self: TLARGEINTFIELD; var T: LARGEINT);
+begin T := Self.MAXVALUE; end;
+
+procedure TLARGEINTFIELDVALUE_W(Self: TLARGEINTFIELD; const T: LARGEINT);
+begin Self.VALUE := T; end;
+
+procedure TLARGEINTFIELDVALUE_R(Self: TLARGEINTFIELD; var T: LARGEINT);
+begin T := Self.VALUE; end;
+
+procedure TLARGEINTFIELDASLARGEINT_W(Self: TLARGEINTFIELD; const T: LARGEINT);
+begin Self.ASLARGEINT := T; end;
+
+procedure TLARGEINTFIELDASLARGEINT_R(Self: TLARGEINTFIELD; var T: LARGEINT);
+begin T := Self.ASLARGEINT; end;
+
+procedure TINTEGERFIELDMINVALUE_W(Self: TINTEGERFIELD; const T: LONGINT);
+begin Self.MINVALUE := T; end;
+
+procedure TINTEGERFIELDMINVALUE_R(Self: TINTEGERFIELD; var T: LONGINT);
+begin T := Self.MINVALUE; end;
+
+procedure TINTEGERFIELDMAXVALUE_W(Self: TINTEGERFIELD; const T: LONGINT);
+begin Self.MAXVALUE := T; end;
+
+procedure TINTEGERFIELDMAXVALUE_R(Self: TINTEGERFIELD; var T: LONGINT);
+begin T := Self.MAXVALUE; end;
+
+procedure TINTEGERFIELDVALUE_W(Self: TINTEGERFIELD; const T: LONGINT);
+begin Self.VALUE := T; end;
+
+procedure TINTEGERFIELDVALUE_R(Self: TINTEGERFIELD; var T: LONGINT);
+begin T := Self.VALUE; end;
+
+procedure TNUMERICFIELDEDITFORMAT_W(Self: TNUMERICFIELD; const T: String);
+begin Self.EDITFORMAT := T; end;
+
+procedure TNUMERICFIELDEDITFORMAT_R(Self: TNUMERICFIELD; var T: String);
+begin T := Self.EDITFORMAT; end;
+
+procedure TNUMERICFIELDDISPLAYFORMAT_W(Self: TNUMERICFIELD; const T: String);
+begin Self.DISPLAYFORMAT := T; end;
+
+procedure TNUMERICFIELDDISPLAYFORMAT_R(Self: TNUMERICFIELD; var T: String);
+begin T := Self.DISPLAYFORMAT; end;
+
+{$IFNDEF FPC}
+procedure TWIDESTRINGFIELDVALUE_W(Self: TWIDESTRINGFIELD; const T: WIDESTRING);
+begin Self.VALUE := T; end;
+
+procedure TWIDESTRINGFIELDVALUE_R(Self: TWIDESTRINGFIELD; var T: WIDESTRING);
+begin T := Self.VALUE; end;
+
+procedure TSTRINGFIELDTRANSLITERATE_W(Self: TSTRINGFIELD; const T: BOOLEAN);
+begin Self.TRANSLITERATE := T; end;
+
+procedure TSTRINGFIELDTRANSLITERATE_R(Self: TSTRINGFIELD; var T: BOOLEAN);
+begin T := Self.TRANSLITERATE; end;
+
+procedure TSTRINGFIELDFIXEDCHAR_W(Self: TSTRINGFIELD; const T: BOOLEAN);
+begin Self.FIXEDCHAR := T; end;
+
+procedure TSTRINGFIELDFIXEDCHAR_R(Self: TSTRINGFIELD; var T: BOOLEAN);
+begin T := Self.FIXEDCHAR; end;
+{$ENDIF}
+
+
+procedure TSTRINGFIELDVALUE_W(Self: TSTRINGFIELD; const T: String);
+begin Self.VALUE := T; end;
+
+procedure TSTRINGFIELDVALUE_R(Self: TSTRINGFIELD; var T: String);
+begin T := Self.VALUE; end;
+
+procedure TFIELDONVALIDATE_W(Self: TFIELD; const T: TFIELDNOTIFYEVENT);
+begin Self.ONVALIDATE := T; end;
+
+procedure TFIELDONVALIDATE_R(Self: TFIELD; var T: TFIELDNOTIFYEVENT);
+begin T := Self.ONVALIDATE; end;
+
+procedure TFIELDONSETTEXT_W(Self: TFIELD; const T: TFIELDSETTEXTEVENT);
+begin Self.ONSETTEXT := T; end;
+
+procedure TFIELDONSETTEXT_R(Self: TFIELD; var T: TFIELDSETTEXTEVENT);
+begin T := Self.ONSETTEXT; end;
+
+procedure TFIELDONGETTEXT_W(Self: TFIELD; const T: TFIELDGETTEXTEVENT);
+begin Self.ONGETTEXT := T; end;
+
+procedure TFIELDONGETTEXT_R(Self: TFIELD; var T: TFIELDGETTEXTEVENT);
+begin T := Self.ONGETTEXT; end;
+
+procedure TFIELDONCHANGE_W(Self: TFIELD; const T: TFIELDNOTIFYEVENT);
+begin Self.ONCHANGE := T; end;
+
+procedure TFIELDONCHANGE_R(Self: TFIELD; var T: TFIELDNOTIFYEVENT);
+begin T := Self.ONCHANGE; end;
+
+procedure TFIELDVISIBLE_W(Self: TFIELD; const T: BOOLEAN);
+begin Self.VISIBLE := T; end;
+
+procedure TFIELDVISIBLE_R(Self: TFIELD; var T: BOOLEAN);
+begin T := Self.VISIBLE; end;
+
+procedure TFIELDREQUIRED_W(Self: TFIELD; const T: BOOLEAN);
+begin Self.REQUIRED := T; end;
+
+procedure TFIELDREQUIRED_R(Self: TFIELD; var T: BOOLEAN);
+begin T := Self.REQUIRED; end;
+
+procedure TFIELDREADONLY_W(Self: TFIELD; const T: BOOLEAN);
+begin Self.READONLY := T; end;
+
+procedure TFIELDREADONLY_R(Self: TFIELD; var T: BOOLEAN);
+begin T := Self.READONLY; end;
+
+procedure TFIELDPROVIDERFLAGS_W(Self: TFIELD; const T: TPROVIDERFLAGS);
+begin Self.PROVIDERFLAGS := T; end;
+
+procedure TFIELDPROVIDERFLAGS_R(Self: TFIELD; var T: TPROVIDERFLAGS);
+begin T := Self.PROVIDERFLAGS; end;
+
+procedure TFIELDORIGIN_W(Self: TFIELD; const T: String);
+begin Self.ORIGIN := T; end;
+
+procedure TFIELDORIGIN_R(Self: TFIELD; var T: String);
+begin T := Self.ORIGIN; end;
+
+procedure TFIELDLOOKUPCACHE_W(Self: TFIELD; const T: BOOLEAN);
+begin Self.LOOKUPCACHE := T; end;
+
+procedure TFIELDLOOKUPCACHE_R(Self: TFIELD; var T: BOOLEAN);
+begin T := Self.LOOKUPCACHE; end;
+
+procedure TFIELDKEYFIELDS_W(Self: TFIELD; const T: String);
+begin Self.KEYFIELDS := T; end;
+
+procedure TFIELDKEYFIELDS_R(Self: TFIELD; var T: String);
+begin T := Self.KEYFIELDS; end;
+
+procedure TFIELDLOOKUPRESULTFIELD_W(Self: TFIELD; const T: String);
+begin Self.LOOKUPRESULTFIELD := T; end;
+
+procedure TFIELDLOOKUPRESULTFIELD_R(Self: TFIELD; var T: String);
+begin T := Self.LOOKUPRESULTFIELD; end;
+
+procedure TFIELDLOOKUPKEYFIELDS_W(Self: TFIELD; const T: String);
+begin Self.LOOKUPKEYFIELDS := T; end;
+
+procedure TFIELDLOOKUPKEYFIELDS_R(Self: TFIELD; var T: String);
+begin T := Self.LOOKUPKEYFIELDS; end;
+
+procedure TFIELDLOOKUPDATASET_W(Self: TFIELD; const T: TDATASET);
+begin Self.LOOKUPDATASET := T; end;
+
+procedure TFIELDLOOKUPDATASET_R(Self: TFIELD; var T: TDATASET);
+begin T := Self.LOOKUPDATASET; end;
+
+procedure TFIELDIMPORTEDCONSTRAINT_W(Self: TFIELD; const T: String);
+begin Self.IMPORTEDCONSTRAINT := T; end;
+
+procedure TFIELDIMPORTEDCONSTRAINT_R(Self: TFIELD; var T: String);
+begin T := Self.IMPORTEDCONSTRAINT; end;
+
+procedure TFIELDINDEX_W(Self: TFIELD; const T: INTEGER);
+begin Self.INDEX := T; end;
+
+procedure TFIELDINDEX_R(Self: TFIELD; var T: INTEGER);
+begin T := Self.INDEX; end;
+
+procedure TFIELDHASCONSTRAINTS_R(Self: TFIELD; var T: BOOLEAN);
+begin T := Self.HASCONSTRAINTS; end;
+
+procedure TFIELDFIELDNAME_W(Self: TFIELD; const T: String);
+begin Self.FIELDNAME := T; end;
+
+procedure TFIELDFIELDNAME_R(Self: TFIELD; var T: String);
+begin T := Self.FIELDNAME; end;
+
+procedure TFIELDFIELDKIND_W(Self: TFIELD; const T: TFIELDKIND);
+begin Self.FIELDKIND := T; end;
+
+procedure TFIELDFIELDKIND_R(Self: TFIELD; var T: TFIELDKIND);
+begin T := Self.FIELDKIND; end;
+
+procedure TFIELDDISPLAYWIDTH_W(Self: TFIELD; const T: INTEGER);
+begin Self.DISPLAYWIDTH := T; end;
+
+procedure TFIELDDISPLAYWIDTH_R(Self: TFIELD; var T: INTEGER);
+begin T := Self.DISPLAYWIDTH; end;
+
+procedure TFIELDDISPLAYLABEL_W(Self: TFIELD; const T: String);
+begin Self.DISPLAYLABEL := T; end;
+
+procedure TFIELDDISPLAYLABEL_R(Self: TFIELD; var T: String);
+begin T := Self.DISPLAYLABEL; end;
+
+procedure TFIELDDEFAULTEXPRESSION_W(Self: TFIELD; const T: String);
+begin Self.DEFAULTEXPRESSION := T; end;
+
+procedure TFIELDDEFAULTEXPRESSION_R(Self: TFIELD; var T: String);
+begin T := Self.DEFAULTEXPRESSION; end;
+
+procedure TFIELDCONSTRAINTERRORMESSAGE_W(Self: TFIELD; const T: String);
+begin Self.CONSTRAINTERRORMESSAGE := T; end;
+
+procedure TFIELDCONSTRAINTERRORMESSAGE_R(Self: TFIELD; var T: String);
+begin T := Self.CONSTRAINTERRORMESSAGE; end;
+
+procedure TFIELDCUSTOMCONSTRAINT_W(Self: TFIELD; const T: String);
+begin Self.CUSTOMCONSTRAINT := T; end;
+
+procedure TFIELDCUSTOMCONSTRAINT_R(Self: TFIELD; var T: String);
+begin T := Self.CUSTOMCONSTRAINT; end;
+
+{$IFNDEF FPC}
+procedure TFIELDAUTOGENERATEVALUE_W(Self: TFIELD; const T: TAUTOREFRESHFLAG);
+begin Self.AUTOGENERATEVALUE := T; end;
+
+procedure TFIELDAUTOGENERATEVALUE_R(Self: TFIELD; var T: TAUTOREFRESHFLAG);
+begin T := Self.AUTOGENERATEVALUE; end;
+
+procedure TFIELDVALIDCHARS_W(Self: TFIELD; const T: TFIELDCHARS);
+begin Self.VALIDCHARS := T; end;
+
+procedure TFIELDVALIDCHARS_R(Self: TFIELD; var T: TFIELDCHARS);
+begin T := Self.VALIDCHARS; end;
+
+
+procedure TFIELDPARENTFIELD_W(Self: TFIELD; const T: TOBJECTFIELD);
+begin Self.PARENTFIELD := T; end;
+
+procedure TFIELDPARENTFIELD_R(Self: TFIELD; var T: TOBJECTFIELD);
+begin T := Self.PARENTFIELD; end;
+
+
+
+{$ENDIF}
+
+procedure TFIELDALIGNMENT_W(Self: TFIELD; const T: TALIGNMENT);
+begin Self.ALIGNMENT := T; end;
+
+procedure TFIELDALIGNMENT_R(Self: TFIELD; var T: TALIGNMENT);
+begin T := Self.ALIGNMENT; end;
+
+procedure TFIELDVALUE_W(Self: TFIELD; const T: VARIANT);
+begin Self.VALUE := T; end;
+
+procedure TFIELDVALUE_R(Self: TFIELD; var T: VARIANT);
+begin T := Self.VALUE; end;
+
+procedure TFIELDTEXT_W(Self: TFIELD; const T: String);
+begin Self.TEXT := T; end;
+
+procedure TFIELDTEXT_R(Self: TFIELD; var T: String);
+begin T := Self.TEXT; end;
+
+procedure TFIELDSIZE_W(Self: TFIELD; const T: INTEGER);
+begin Self.SIZE := T; end;
+
+procedure TFIELDSIZE_R(Self: TFIELD; var T: INTEGER);
+begin T := Self.SIZE; end;
+
+procedure TFIELDOLDVALUE_R(Self: TFIELD; var T: VARIANT);
+begin T := Self.OLDVALUE; end;
+
+procedure TFIELDOFFSET_R(Self: TFIELD; var T: INTEGER);
+begin T := Self.OFFSET; end;
+
+procedure TFIELDNEWVALUE_W(Self: TFIELD; const T: VARIANT);
+begin Self.NEWVALUE := T; end;
+
+procedure TFIELDNEWVALUE_R(Self: TFIELD; var T: VARIANT);
+begin T := Self.NEWVALUE; end;
+
+procedure TFIELDLOOKUPLIST_R(Self: TFIELD; var T: TLOOKUPLIST);
+begin T := Self.LOOKUPLIST; end;
+
+{$IFNDEF FPC}
+procedure TFIELDLOOKUP_W(Self: TFIELD; const T: BOOLEAN);
+begin Self.LOOKUP := T; end;
+
+procedure TFIELDLOOKUP_R(Self: TFIELD; var T: BOOLEAN);
+begin T := Self.LOOKUP; end;
+
+procedure TFIELDFULLNAME_R(Self: TFIELD; var T: String);
+begin T := Self.FULLNAME; end;
+
+
+procedure TFIELDEDITMASKPTR_R(Self: TFIELD; var T: String);
+begin T := Self.EDITMASKPTR; end;
+
+procedure TFIELDEDITMASK_W(Self: TFIELD; const T: String);
+begin Self.EDITMASK := T; end;
+
+procedure TFIELDEDITMASK_R(Self: TFIELD; var T: String);
+begin T := Self.EDITMASK; end;
+
+{$ENDIF}
+
+procedure TFIELDISNULL_R(Self: TFIELD; var T: BOOLEAN);
+begin T := Self.ISNULL; end;
+
+procedure TFIELDISINDEXFIELD_R(Self: TFIELD; var T: BOOLEAN);
+begin T := Self.ISINDEXFIELD; end;
+
+procedure TFIELDFIELDNO_R(Self: TFIELD; var T: INTEGER);
+begin T := Self.FIELDNO; end;
+
+
+
+procedure TFIELDDISPLAYTEXT_R(Self: TFIELD; var T: String);
+begin T := Self.DISPLAYTEXT; end;
+
+procedure TFIELDDISPLAYNAME_R(Self: TFIELD; var T: String);
+begin T := Self.DISPLAYNAME; end;
+
+procedure TFIELDDATATYPE_R(Self: TFIELD; var T: TFIELDTYPE);
+begin T := Self.DATATYPE; end;
+
+procedure TFIELDDATASIZE_R(Self: TFIELD; var T: INTEGER);
+begin T := Self.DATASIZE; end;
+
+procedure TFIELDDATASET_W(Self: TFIELD; const T: TDATASET);
+begin Self.DATASET := T; end;
+
+procedure TFIELDDATASET_R(Self: TFIELD; var T: TDATASET);
+begin T := Self.DATASET; end;
+
+procedure TFIELDCURVALUE_R(Self: TFIELD; var T: VARIANT);
+begin T := Self.CURVALUE; end;
+
+procedure TFIELDCANMODIFY_R(Self: TFIELD; var T: BOOLEAN);
+begin T := Self.CANMODIFY; end;
+
+procedure TFIELDCALCULATED_W(Self: TFIELD; const T: BOOLEAN);
+begin Self.CALCULATED := T; end;
+
+procedure TFIELDCALCULATED_R(Self: TFIELD; var T: BOOLEAN);
+begin T := Self.CALCULATED; end;
+
+procedure TFIELDATTRIBUTESET_W(Self: TFIELD; const T: String);
+begin Self.ATTRIBUTESET := T; end;
+
+procedure TFIELDATTRIBUTESET_R(Self: TFIELD; var T: String);
+begin T := Self.ATTRIBUTESET; end;
+
+procedure TFIELDASVARIANT_W(Self: TFIELD; const T: VARIANT);
+begin Self.ASVARIANT := T; end;
+
+procedure TFIELDASVARIANT_R(Self: TFIELD; var T: VARIANT);
+begin T := Self.ASVARIANT; end;
+
+procedure TFIELDASSTRING_W(Self: TFIELD; const T: String);
+begin Self.ASSTRING := T; end;
+
+procedure TFIELDASSTRING_R(Self: TFIELD; var T: String);
+begin T := Self.ASSTRING; end;
+
+procedure TFIELDASINTEGER_W(Self: TFIELD; const T: LONGINT);
+begin Self.ASINTEGER := T; end;
+
+procedure TFIELDASINTEGER_R(Self: TFIELD; var T: LONGINT);
+begin T := Self.ASINTEGER; end;
+
+procedure TFIELDASFLOAT_W(Self: TFIELD; const T: DOUBLE);
+begin Self.ASFLOAT := T; end;
+
+procedure TFIELDASFLOAT_R(Self: TFIELD; var T: DOUBLE);
+begin T := Self.ASFLOAT; end;
+
+procedure TFIELDASDATETIME_W(Self: TFIELD; const T: TDATETIME);
+begin Self.ASDATETIME := T; end;
+
+procedure TFIELDASDATETIME_R(Self: TFIELD; var T: TDATETIME);
+begin T := Self.ASDATETIME; end;
+
+procedure TFIELDASCURRENCY_W(Self: TFIELD; const T: CURRENCY);
+begin Self.ASCURRENCY := T; end;
+
+procedure TFIELDASCURRENCY_R(Self: TFIELD; var T: CURRENCY);
+begin T := Self.ASCURRENCY; end;
+
+procedure TFIELDASBOOLEAN_W(Self: TFIELD; const T: BOOLEAN);
+begin Self.ASBOOLEAN := T; end;
+
+procedure TFIELDASBOOLEAN_R(Self: TFIELD; var T: BOOLEAN);
+begin T := Self.ASBOOLEAN; end;
+
+{$IFNDEF FPC}
+{$IFDEF DELPHI6UP}
+procedure TFIELDASBCD_W(Self: TFIELD; const T: TBCD);
+begin Self.ASBCD := T; end;
+
+procedure TFIELDASBCD_R(Self: TFIELD; var T: TBCD);
+begin T := Self.ASBCD; end;
+{$ENDIF}
+
+procedure TFIELDLISTFIELDS_R(Self: TFIELDLIST; var T: TFIELD; const t1: INTEGER);
+begin T := Self.FIELDS[t1]; end;
+
+procedure TFIELDDEFLISTFIELDDEFS_R(Self: TFIELDDEFLIST; var T: TFIELDDEF; const t1: INTEGER);
+begin T := Self.FIELDDEFS[t1]; end;
+
+procedure TFLATLISTDATASET_R(Self: TFLATLIST; var T: TDATASET);
+begin T := Self.DATASET; end;
+
+procedure TINDEXDEFGROUPINGLEVEL_W(Self: TINDEXDEF; const T: INTEGER);
+begin Self.GROUPINGLEVEL := T; end;
+
+procedure TINDEXDEFGROUPINGLEVEL_R(Self: TINDEXDEF; var T: INTEGER);
+begin T := Self.GROUPINGLEVEL; end;
+
+
+
+{$ENDIF}
+
+procedure TFIELDSFIELDS_W(Self: TFIELDS; const T: TFIELD; const t1: INTEGER);
+begin Self.FIELDS[t1] := T; end;
+
+procedure TFIELDSFIELDS_R(Self: TFIELDS; var T: TFIELD; const t1: INTEGER);
+begin T := Self.FIELDS[t1]; end;
+
+procedure TFIELDSDATASET_R(Self: TFIELDS; var T: TDATASET);
+begin T := Self.DATASET; end;
+
+procedure TFIELDSCOUNT_R(Self: TFIELDS; var T: INTEGER);
+begin T := Self.COUNT; end;
+
+procedure TINDEXDEFSITEMS_W(Self: TINDEXDEFS; const T: TINDEXDEF; const t1: INTEGER);
+begin Self.ITEMS[t1] := T; end;
+
+procedure TINDEXDEFSITEMS_R(Self: TINDEXDEFS; var T: TINDEXDEF; const t1: INTEGER);
+begin T := Self.ITEMS[t1]; end;
+
+procedure TINDEXDEFSOURCE_W(Self: TINDEXDEF; const T: String);
+begin Self.SOURCE := T; end;
+
+procedure TINDEXDEFSOURCE_R(Self: TINDEXDEF; var T: String);
+begin T := Self.SOURCE; end;
+
+procedure TINDEXDEFOPTIONS_W(Self: TINDEXDEF; const T: TINDEXOPTIONS);
+begin Self.OPTIONS := T; end;
+
+procedure TINDEXDEFOPTIONS_R(Self: TINDEXDEF; var T: TINDEXOPTIONS);
+begin T := Self.OPTIONS; end;
+
+procedure TINDEXDEFFIELDS_W(Self: TINDEXDEF; const T: String);
+begin Self.FIELDS := T; end;
+
+procedure TINDEXDEFFIELDS_R(Self: TINDEXDEF; var T: String);
+begin T := Self.FIELDS; end;
+
+procedure TINDEXDEFEXPRESSION_W(Self: TINDEXDEF; const T: String);
+begin {$IFNDEF FPC}Self.EXPRESSION := T; {$ENDIF}end;
+
+procedure TINDEXDEFEXPRESSION_R(Self: TINDEXDEF; var T: String);
+begin T := Self.EXPRESSION; end;
+
+{$IFNDEF FPC}
+procedure TINDEXDEFDESCFIELDS_W(Self: TINDEXDEF; const T: String);
+begin Self.DESCFIELDS := T; end;
+
+procedure TINDEXDEFDESCFIELDS_R(Self: TINDEXDEF; var T: String);
+begin T := Self.DESCFIELDS; end;
+
+procedure TINDEXDEFCASEINSFIELDS_W(Self: TINDEXDEF; const T: String);
+begin Self.CASEINSFIELDS := T; end;
+
+procedure TINDEXDEFCASEINSFIELDS_R(Self: TINDEXDEF; var T: String);
+begin T := Self.CASEINSFIELDS; end;
+
+
+procedure TINDEXDEFFIELDEXPRESSION_R(Self: TINDEXDEF; var T: String);
+begin T := Self.FIELDEXPRESSION; end;
+
+procedure TFIELDDEFSPARENTDEF_R(Self: TFIELDDEFS; var T: TFIELDDEF);
+begin T := Self.PARENTDEF; end;
+
+{$ENDIF}
+
+procedure TFIELDDEFSITEMS_W(Self: TFIELDDEFS; const T: TFIELDDEF; const t1: INTEGER);
+begin Self.ITEMS[t1] := T; end;
+
+procedure TFIELDDEFSITEMS_R(Self: TFIELDDEFS; var T: TFIELDDEF; const t1: INTEGER);
+begin T := Self.ITEMS[t1]; end;
+
+procedure TFIELDDEFSHIDDENFIELDS_W(Self: TFIELDDEFS; const T: BOOLEAN);
+begin Self.HIDDENFIELDS := T; end;
+
+procedure TFIELDDEFSHIDDENFIELDS_R(Self: TFIELDDEFS; var T: BOOLEAN);
+begin T := Self.HIDDENFIELDS; end;
+
+procedure TFIELDDEFSIZE_W(Self: TFIELDDEF; const T: INTEGER);
+begin Self.SIZE := T; end;
+
+procedure TFIELDDEFSIZE_R(Self: TFIELDDEF; var T: INTEGER);
+begin T := Self.SIZE; end;
+
+procedure TFIELDDEFPRECISION_W(Self: TFIELDDEF; const T: INTEGER);
+begin Self.PRECISION := T; end;
+
+procedure TFIELDDEFPRECISION_R(Self: TFIELDDEF; var T: INTEGER);
+begin T := Self.PRECISION; end;
+
+procedure TFIELDDEFDATATYPE_W(Self: TFIELDDEF; const T: TFIELDTYPE);
+begin Self.DATATYPE := T; end;
+
+procedure TFIELDDEFDATATYPE_R(Self: TFIELDDEF; var T: TFIELDTYPE);
+begin T := Self.DATATYPE; end;
+
+{$IFNDEF FPC}
+procedure TFIELDDEFCHILDDEFS_W(Self: TFIELDDEF; const T: TFIELDDEFS);
+begin Self.CHILDDEFS := T; end;
+
+procedure TFIELDDEFCHILDDEFS_R(Self: TFIELDDEF; var T: TFIELDDEFS);
+begin T := Self.CHILDDEFS; end;
+
+procedure TFIELDDEFREQUIRED_W(Self: TFIELDDEF; const T: BOOLEAN);
+begin Self.REQUIRED := T;end;
+
+procedure TFIELDDEFPARENTDEF_R(Self: TFIELDDEF; var T: TFIELDDEF);
+begin T := Self.PARENTDEF; end;
+
+{$ENDIF}
+
+procedure TFIELDDEFATTRIBUTES_W(Self: TFIELDDEF; const T: TFIELDATTRIBUTES);
+begin Self.ATTRIBUTES := T; end;
+
+procedure TFIELDDEFATTRIBUTES_R(Self: TFIELDDEF; var T: TFIELDATTRIBUTES);
+begin T := Self.ATTRIBUTES; end;
+
+procedure TFIELDDEFREQUIRED_R(Self: TFIELDDEF; var T: BOOLEAN);
+begin T := Self.REQUIRED; end;
+
+procedure TFIELDDEFINTERNALCALCFIELD_W(Self: TFIELDDEF; const T: BOOLEAN);
+begin Self.INTERNALCALCFIELD := T; end;
+
+procedure TFIELDDEFINTERNALCALCFIELD_R(Self: TFIELDDEF; var T: BOOLEAN);
+begin T := Self.INTERNALCALCFIELD; end;
+
+{$IFNDEF FPC}
+procedure TFIELDDEFFIELDNO_W(Self: TFIELDDEF; const T: INTEGER);
+begin Self.FIELDNO := T; end;
+
+procedure TDEFCOLLECTIONUPDATED_W(Self: TDEFCOLLECTION; const T: BOOLEAN);
+begin Self.UPDATED := T; end;
+
+procedure TDEFCOLLECTIONUPDATED_R(Self: TDEFCOLLECTION; var T: BOOLEAN);
+begin T := Self.UPDATED; end;
+
+procedure TDEFCOLLECTIONDATASET_R(Self: TDEFCOLLECTION; var T: TDATASET);
+begin T := Self.DATASET; end;
+
+procedure TNAMEDITEMNAME_W(Self: TNAMEDITEM; const T: String);
+begin Self.NAME := T; end;
+
+procedure TNAMEDITEMNAME_R(Self: TNAMEDITEM; var T: String);
+begin T := Self.NAME; end;
+
+
+{$ENDIF}
+
+procedure TFIELDDEFFIELDNO_R(Self: TFIELDDEF; var T: INTEGER);
+begin T := Self.FIELDNO; end;
+
+procedure TFIELDDEFFIELDCLASS_R(Self: TFIELDDEF; var T: TFIELDCLASS);
+begin T := Self.FIELDCLASS; end;
+
+procedure RIRegisterTDATASET(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TDATASET) do
+ begin
+ RegisterMethod(@TDATASET.ACTIVEBUFFER, 'ACTIVEBUFFER');
+ RegisterMethod(@TDATASET.APPEND, 'APPEND');
+ RegisterMethod(@TDATASET.APPENDRECORD, 'APPENDRECORD');
+// RegisterVirtualMethod(@TDATASET.BOOKMARKVALID, 'BOOKMARKVALID');
+ RegisterVirtualMethod(@TDATASET.CANCEL, 'CANCEL');
+ RegisterMethod(@TDATASET.CHECKBROWSEMODE, 'CHECKBROWSEMODE');
+ RegisterMethod(@TDATASET.CLEARFIELDS, 'CLEARFIELDS');
+ RegisterMethod(@TDATASET.CLOSE, 'CLOSE');
+ RegisterMethod(@TDATASET.CONTROLSDISABLED, 'CONTROLSDISABLED');
+// RegisterVirtualMethod(@TDATASET.COMPAREBOOKMARKS, 'COMPAREBOOKMARKS');
+ RegisterVirtualMethod(@TDATASET.CREATEBLOBSTREAM, 'CREATEBLOBSTREAM');
+ RegisterMethod(@TDATASET.CURSORPOSCHANGED, 'CURSORPOSCHANGED');
+ RegisterMethod(@TDATASET.DELETE, 'DELETE');
+ RegisterMethod(@TDATASET.DISABLECONTROLS, 'DISABLECONTROLS');
+ RegisterMethod(@TDATASET.EDIT, 'EDIT');
+ RegisterMethod(@TDATASET.ENABLECONTROLS, 'ENABLECONTROLS');
+ RegisterMethod(@TDATASET.FIELDBYNAME, 'FIELDBYNAME');
+ RegisterMethod(@TDATASET.FINDFIELD, 'FINDFIELD');
+ RegisterMethod(@TDATASET.FINDFIRST, 'FINDFIRST');
+ RegisterMethod(@TDATASET.FINDLAST, 'FINDLAST');
+ RegisterMethod(@TDATASET.FINDNEXT, 'FINDNEXT');
+ RegisterMethod(@TDATASET.FINDPRIOR, 'FINDPRIOR');
+ RegisterMethod(@TDATASET.FIRST, 'FIRST');
+// RegisterVirtualMethod(@TDATASET.FREEBOOKMARK, 'FREEBOOKMARK');
+// RegisterVirtualMethod(@TDATASET.GETBOOKMARK, 'GETBOOKMARK');
+ RegisterVirtualMethod(@TDATASET.GETCURRENTRECORD, 'GETCURRENTRECORD');
+// RegisterVirtualMethod(@TDATASET.GETDETAILDATASETS, 'GETDETAILDATASETS');
+// RegisterVirtualMethod(@TDATASET.GETDETAILLINKFIELDS, 'GETDETAILLINKFIELDS');
+// RegisterVirtualMethod(@TDATASET.GETBLOBFIELDDATA, 'GETBLOBFIELDDATA');
+// RegisterMethod(@TDATASET.GETFIELDLIST, 'GETFIELDLIST');
+ RegisterMethod(@TDATASET.GETFIELDNAMES, 'GETFIELDNAMES');
+// RegisterMethod(@TDATASET.GOTOBOOKMARK, 'GOTOBOOKMARK');
+ RegisterMethod(@TDATASET.INSERT, 'INSERT');
+ RegisterMethod(@TDATASET.INSERTRECORD, 'INSERTRECORD');
+ RegisterMethod(@TDATASET.ISEMPTY, 'ISEMPTY');
+ RegisterMethod(@TDATASET.ISLINKEDTO, 'ISLINKEDTO');
+ RegisterVirtualMethod(@TDATASET.ISSEQUENCED, 'ISSEQUENCED');
+ RegisterMethod(@TDATASET.LAST, 'LAST');
+ RegisterVirtualMethod(@TDATASET.LOCATE, 'LOCATE');
+ RegisterVirtualMethod(@TDATASET.LOOKUP, 'LOOKUP');
+ RegisterMethod(@TDATASET.MOVEBY, 'MOVEBY');
+ RegisterMethod(@TDATASET.NEXT, 'NEXT');
+ RegisterMethod(@TDATASET.OPEN, 'OPEN');
+ RegisterVirtualMethod(@TDATASET.POST, 'POST');
+ RegisterMethod(@TDATASET.PRIOR, 'PRIOR');
+ RegisterMethod(@TDATASET.REFRESH, 'REFRESH');
+// RegisterVirtualMethod(@TDATASET.RESYNC, 'RESYNC');
+ RegisterMethod(@TDATASET.SETFIELDS, 'SETFIELDS');
+ RegisterVirtualMethod(@TDATASET.TRANSLATE, 'TRANSLATE');
+ RegisterMethod(@TDATASET.UPDATECURSORPOS, 'UPDATECURSORPOS');
+ RegisterMethod(@TDATASET.UPDATERECORD, 'UPDATERECORD');
+ RegisterVirtualMethod(@TDATASET.UPDATESTATUS, 'UPDATESTATUS');
+ RegisterPropertyHelper(@TDATASETBOF_R,nil,'BOF');
+// RegisterPropertyHelper(@TDATASETBOOKMARK_R,@TDATASETBOOKMARK_W,'BOOKMARK');
+ RegisterPropertyHelper(@TDATASETCANMODIFY_R,nil,'CANMODIFY');
+ RegisterPropertyHelper(@TDATASETDATASOURCE_R,nil,'DATASOURCE');
+ RegisterPropertyHelper(@TDATASETDEFAULTFIELDS_R,nil,'DEFAULTFIELDS');
+ RegisterPropertyHelper(@TDATASETEOF_R,nil,'EOF');
+ RegisterPropertyHelper(@TDATASETFIELDCOUNT_R,nil,'FIELDCOUNT');
+ RegisterPropertyHelper(@TDATASETFIELDS_R,nil,'FIELDS');
+ RegisterPropertyHelper(@TDATASETFIELDVALUES_R,@TDATASETFIELDVALUES_W,'FIELDVALUES');
+ RegisterPropertyHelper(@TDATASETFOUND_R,nil,'FOUND');
+{$IFDEF DELPHI6UP}
+ RegisterPropertyHelper(@TDATASETISUNIDIRECTIONAL_R,nil,'ISUNIDIRECTIONAL');
+{$ENDIF}
+ RegisterPropertyHelper(@TDATASETMODIFIED_R,nil,'MODIFIED');
+ RegisterPropertyHelper(@TDATASETRECORDCOUNT_R,nil,'RECORDCOUNT');
+ RegisterPropertyHelper(@TDATASETRECNO_R,@TDATASETRECNO_W,'RECNO');
+ RegisterPropertyHelper(@TDATASETRECORDSIZE_R,nil,'RECORDSIZE');
+ RegisterPropertyHelper(@TDATASETSTATE_R,nil,'STATE');
+ RegisterPropertyHelper(@TDATASETFILTER_R,@TDATASETFILTER_W,'FILTER');
+ RegisterPropertyHelper(@TDATASETFILTERED_R,@TDATASETFILTERED_W,'FILTERED');
+ RegisterPropertyHelper(@TDATASETFILTEROPTIONS_R,@TDATASETFILTEROPTIONS_W,'FILTEROPTIONS');
+ RegisterPropertyHelper(@TDATASETACTIVE_R,@TDATASETACTIVE_W,'ACTIVE');
+ RegisterPropertyHelper(@TDATASETAUTOCALCFIELDS_R,@TDATASETAUTOCALCFIELDS_W,'AUTOCALCFIELDS');
+ RegisterPropertyHelper(@TDATASETBEFOREOPEN_R,@TDATASETBEFOREOPEN_W,'BEFOREOPEN');
+ RegisterPropertyHelper(@TDATASETAFTEROPEN_R,@TDATASETAFTEROPEN_W,'AFTEROPEN');
+ RegisterPropertyHelper(@TDATASETBEFORECLOSE_R,@TDATASETBEFORECLOSE_W,'BEFORECLOSE');
+ RegisterPropertyHelper(@TDATASETAFTERCLOSE_R,@TDATASETAFTERCLOSE_W,'AFTERCLOSE');
+ RegisterPropertyHelper(@TDATASETBEFOREINSERT_R,@TDATASETBEFOREINSERT_W,'BEFOREINSERT');
+ RegisterPropertyHelper(@TDATASETAFTERINSERT_R,@TDATASETAFTERINSERT_W,'AFTERINSERT');
+ RegisterPropertyHelper(@TDATASETBEFOREEDIT_R,@TDATASETBEFOREEDIT_W,'BEFOREEDIT');
+ RegisterPropertyHelper(@TDATASETAFTEREDIT_R,@TDATASETAFTEREDIT_W,'AFTEREDIT');
+ RegisterPropertyHelper(@TDATASETBEFOREPOST_R,@TDATASETBEFOREPOST_W,'BEFOREPOST');
+ RegisterPropertyHelper(@TDATASETAFTERPOST_R,@TDATASETAFTERPOST_W,'AFTERPOST');
+ RegisterPropertyHelper(@TDATASETBEFORECANCEL_R,@TDATASETBEFORECANCEL_W,'BEFORECANCEL');
+ RegisterPropertyHelper(@TDATASETAFTERCANCEL_R,@TDATASETAFTERCANCEL_W,'AFTERCANCEL');
+ RegisterPropertyHelper(@TDATASETBEFOREDELETE_R,@TDATASETBEFOREDELETE_W,'BEFOREDELETE');
+ RegisterPropertyHelper(@TDATASETAFTERDELETE_R,@TDATASETAFTERDELETE_W,'AFTERDELETE');
+ RegisterPropertyHelper(@TDATASETBEFORESCROLL_R,@TDATASETBEFORESCROLL_W,'BEFORESCROLL');
+ RegisterPropertyHelper(@TDATASETAFTERSCROLL_R,@TDATASETAFTERSCROLL_W,'AFTERSCROLL');
+ {$IFNDEF FPC}
+ RegisterPropertyHelper(@TDATASETFIELDLIST_R,nil,'FIELDLIST');
+ RegisterPropertyHelper(@TDATASETDESIGNER_R,nil,'DESIGNER');
+ RegisterPropertyHelper(@TDATASETBLOCKREADSIZE_R,@TDATASETBLOCKREADSIZE_W,'BLOCKREADSIZE');
+ RegisterPropertyHelper(@TDATASETBEFOREREFRESH_R,@TDATASETBEFOREREFRESH_W,'BEFOREREFRESH');
+ RegisterPropertyHelper(@TDATASETAFTERREFRESH_R,@TDATASETAFTERREFRESH_W,'AFTERREFRESH');
+ RegisterPropertyHelper(@TDATASETAGGFIELDS_R,nil,'AGGFIELDS');
+ RegisterPropertyHelper(@TDATASETDATASETFIELD_R,@TDATASETDATASETFIELD_W,'DATASETFIELD');
+ RegisterPropertyHelper(@TDATASETOBJECTVIEW_R,@TDATASETOBJECTVIEW_W,'OBJECTVIEW');
+ RegisterPropertyHelper(@TDATASETSPARSEARRAYS_R,@TDATASETSPARSEARRAYS_W,'SPARSEARRAYS');
+ RegisterPropertyHelper(@TDATASETFIELDDEFS_R,@TDATASETFIELDDEFS_W,'FIELDDEFS');
+ RegisterPropertyHelper(@TDATASETFIELDDEFLIST_R,nil,'FIELDDEFLIST');
+
+ {$ENDIF}
+ RegisterEventPropertyHelper(@TDATASETONCALCFIELDS_R,@TDATASETONCALCFIELDS_W,'ONCALCFIELDS');
+ RegisterEventPropertyHelper(@TDATASETONDELETEERROR_R,@TDATASETONDELETEERROR_W,'ONDELETEERROR');
+ RegisterEventPropertyHelper(@TDATASETONEDITERROR_R,@TDATASETONEDITERROR_W,'ONEDITERROR');
+ RegisterEventPropertyHelper(@TDATASETONFILTERRECORD_R,@TDATASETONFILTERRECORD_W,'ONFILTERRECORD');
+ RegisterEventPropertyHelper(@TDATASETONNEWRECORD_R,@TDATASETONNEWRECORD_W,'ONNEWRECORD');
+ RegisterEventPropertyHelper(@TDATASETONPOSTERROR_R,@TDATASETONPOSTERROR_W,'ONPOSTERROR');
+ end;
+end;
+
+procedure RIRegisterTPARAMS(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TPARAMS) do
+ begin
+// RegisterMethod(@TPARAMS.ASSIGNVALUES, 'ASSIGNVALUES');
+ RegisterMethod(@TPARAMS.ADDPARAM, 'ADDPARAM');
+ RegisterMethod(@TPARAMS.REMOVEPARAM, 'REMOVEPARAM');
+ RegisterMethod(@TPARAMS.CREATEPARAM, 'CREATEPARAM');
+ RegisterMethod(@TPARAMS.GETPARAMLIST, 'GETPARAMLIST');
+ RegisterMethod(@TPARAMS.ISEQUAL, 'ISEQUAL');
+ RegisterMethod(@TPARAMS.PARSESQL, 'PARSESQL');
+ RegisterMethod(@TPARAMS.PARAMBYNAME, 'PARAMBYNAME');
+ RegisterMethod(@TPARAMS.FINDPARAM, 'FINDPARAM');
+ RegisterPropertyHelper(@TPARAMSITEMS_R,@TPARAMSITEMS_W,'ITEMS');
+ RegisterPropertyHelper(@TPARAMSPARAMVALUES_R,@TPARAMSPARAMVALUES_W,'PARAMVALUES');
+ end;
+end;
+
+procedure RIRegisterTPARAM(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TPARAM) do
+ begin
+ RegisterMethod(@TPARAM.ASSIGNFIELD, 'ASSIGNFIELD');
+ RegisterMethod(@TPARAM.ASSIGNFIELDVALUE, 'ASSIGNFIELDVALUE');
+ RegisterMethod(@TPARAM.CLEAR, 'CLEAR');
+// RegisterMethod(@TPARAM.GETDATA, 'GETDATA');
+ RegisterMethod(@TPARAM.GETDATASIZE, 'GETDATASIZE');
+ RegisterMethod(@TPARAM.LOADFROMFILE, 'LOADFROMFILE');
+ RegisterMethod(@TPARAM.LOADFROMSTREAM, 'LOADFROMSTREAM');
+// RegisterMethod(@TPARAM.SETBLOBDATA, 'SETBLOBDATA');
+// RegisterMethod(@TPARAM.SETDATA, 'SETDATA');
+ {$IFNDEF FPC}
+ RegisterPropertyHelper(@TPARAMASBCD_R,@TPARAMASBCD_W,'ASBCD');
+{$IFDEF DELPHI6UP}
+ RegisterPropertyHelper(@TPARAMASFMTBCD_R,@TPARAMASFMTBCD_W,'ASFMTBCD');
+{$ENDIF}
+ {$ENDIF}
+ RegisterPropertyHelper(@TPARAMASBLOB_R,@TPARAMASBLOB_W,'ASBLOB');
+ RegisterPropertyHelper(@TPARAMASBOOLEAN_R,@TPARAMASBOOLEAN_W,'ASBOOLEAN');
+ RegisterPropertyHelper(@TPARAMASCURRENCY_R,@TPARAMASCURRENCY_W,'ASCURRENCY');
+ RegisterPropertyHelper(@TPARAMASDATE_R,@TPARAMASDATE_W,'ASDATE');
+ RegisterPropertyHelper(@TPARAMASDATETIME_R,@TPARAMASDATETIME_W,'ASDATETIME');
+ RegisterPropertyHelper(@TPARAMASFLOAT_R,@TPARAMASFLOAT_W,'ASFLOAT');
+ RegisterPropertyHelper(@TPARAMASINTEGER_R,@TPARAMASINTEGER_W,'ASINTEGER');
+ RegisterPropertyHelper(@TPARAMASSMALLINT_R,@TPARAMASSMALLINT_W,'ASSMALLINT');
+ RegisterPropertyHelper(@TPARAMASMEMO_R,@TPARAMASMEMO_W,'ASMEMO');
+ RegisterPropertyHelper(@TPARAMASSTRING_R,@TPARAMASSTRING_W,'ASSTRING');
+ RegisterPropertyHelper(@TPARAMASTIME_R,@TPARAMASTIME_W,'ASTIME');
+ RegisterPropertyHelper(@TPARAMASWORD_R,@TPARAMASWORD_W,'ASWORD');
+ RegisterPropertyHelper(@TPARAMBOUND_R,@TPARAMBOUND_W,'BOUND');
+ RegisterPropertyHelper(@TPARAMISNULL_R,nil,'ISNULL');
+ RegisterPropertyHelper(@TPARAMNATIVESTR_R,@TPARAMNATIVESTR_W,'NATIVESTR');
+ RegisterPropertyHelper(@TPARAMTEXT_R,@TPARAMTEXT_W,'TEXT');
+ RegisterPropertyHelper(@TPARAMDATATYPE_R,@TPARAMDATATYPE_W,'DATATYPE');
+{$IFDEF DELPHI6UP}
+ RegisterPropertyHelper(@TPARAMPRECISION_R,@TPARAMPRECISION_W,'PRECISION');
+ RegisterPropertyHelper(@TPARAMNUMERICSCALE_R,@TPARAMNUMERICSCALE_W,'NUMERICSCALE');
+ RegisterPropertyHelper(@TPARAMSIZE_R,@TPARAMSIZE_W,'SIZE');
+{$ENDIF}
+ RegisterPropertyHelper(@TPARAMNAME_R,@TPARAMNAME_W,'NAME');
+ RegisterPropertyHelper(@TPARAMPARAMTYPE_R,@TPARAMPARAMTYPE_W,'PARAMTYPE');
+ RegisterPropertyHelper(@TPARAMVALUE_R,@TPARAMVALUE_W,'VALUE');
+ end;
+end;
+
+{$IFNDEF FPC}
+procedure RIRegisterTGUIDFIELD(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TGUIDFIELD) do
+ begin
+ end;
+end;
+
+procedure RIRegisterTVARIANTFIELD(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TVARIANTFIELD) do
+ begin
+ end;
+end;
+
+procedure RIRegisterTREFERENCEFIELD(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TREFERENCEFIELD) do
+ begin
+ RegisterPropertyHelper(@TREFERENCEFIELDREFERENCETABLENAME_R,@TREFERENCEFIELDREFERENCETABLENAME_W,'REFERENCETABLENAME');
+ end;
+end;
+
+
+procedure RIRegisterTDATASETFIELD(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TDATASETFIELD) do
+ begin
+ RegisterPropertyHelper(@TDATASETFIELDNESTEDDATASET_R,nil,'NESTEDDATASET');
+ RegisterPropertyHelper(@TDATASETFIELDINCLUDEOBJECTFIELD_R,@TDATASETFIELDINCLUDEOBJECTFIELD_W,'INCLUDEOBJECTFIELD');
+ end;
+end;
+
+
+procedure RIRegisterTARRAYFIELD(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TARRAYFIELD) do
+ begin
+ end;
+end;
+
+
+procedure RIRegisterTADTFIELD(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TADTFIELD) do
+ begin
+ end;
+end;
+
+
+procedure RIRegisterTOBJECTFIELD(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TOBJECTFIELD) do
+ begin
+ RegisterPropertyHelper(@TOBJECTFIELDFIELDCOUNT_R,nil,'FIELDCOUNT');
+ RegisterPropertyHelper(@TOBJECTFIELDFIELDS_R,nil,'FIELDS');
+ RegisterPropertyHelper(@TOBJECTFIELDFIELDVALUES_R,@TOBJECTFIELDFIELDVALUES_W,'FIELDVALUES');
+ RegisterPropertyHelper(@TOBJECTFIELDUNNAMED_R,nil,'UNNAMED');
+ RegisterPropertyHelper(@TOBJECTFIELDOBJECTTYPE_R,@TOBJECTFIELDOBJECTTYPE_W,'OBJECTTYPE');
+ end;
+end;
+{$ENDIF}
+
+
+procedure RIRegisterTGRAPHICFIELD(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TGRAPHICFIELD) do
+ begin
+ end;
+end;
+
+procedure RIRegisterTMEMOFIELD(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TMEMOFIELD) do
+ begin
+ end;
+end;
+
+procedure RIRegisterTBLOBFIELD(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TBLOBFIELD) do
+ begin
+ RegisterMethod(@TBLOBFIELD.LOADFROMFILE, 'LOADFROMFILE');
+ RegisterMethod(@TBLOBFIELD.LOADFROMSTREAM, 'LOADFROMSTREAM');
+ RegisterMethod(@TBLOBFIELD.SAVETOFILE, 'SAVETOFILE');
+ RegisterMethod(@TBLOBFIELD.SAVETOSTREAM, 'SAVETOSTREAM');
+ RegisterPropertyHelper(@TBLOBFIELDBLOBSIZE_R,nil,'BLOBSIZE');
+ RegisterPropertyHelper(@TBLOBFIELDMODIFIED_R,@TBLOBFIELDMODIFIED_W,'MODIFIED');
+ RegisterPropertyHelper(@TBLOBFIELDVALUE_R,@TBLOBFIELDVALUE_W,'VALUE');
+ RegisterPropertyHelper(@TBLOBFIELDTRANSLITERATE_R,@TBLOBFIELDTRANSLITERATE_W,'TRANSLITERATE');
+ RegisterPropertyHelper(@TBLOBFIELDBLOBTYPE_R,@TBLOBFIELDBLOBTYPE_W,'BLOBTYPE');
+{$IFNDEF FPC}
+{$IFDEF DELPHI6UP}
+ RegisterPropertyHelper(@TBLOBFIELDGRAPHICHEADER_R,@TBLOBFIELDGRAPHICHEADER_W,'GRAPHICHEADER');
+{$ENDIF}
+{$ENDIF}
+ end;
+end;
+
+
+{$IFNDEF FPC}
+{$IFDEF DELPHI6UP}
+
+procedure RIRegisterTFMTBCDFIELD(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TFMTBCDFIELD) do
+ begin
+ RegisterPropertyHelper(@TFMTBCDFIELDVALUE_R,@TFMTBCDFIELDVALUE_W,'VALUE');
+ RegisterPropertyHelper(@TFMTBCDFIELDCURRENCY_R,@TFMTBCDFIELDCURRENCY_W,'CURRENCY');
+ RegisterPropertyHelper(@TFMTBCDFIELDMAXVALUE_R,@TFMTBCDFIELDMAXVALUE_W,'MAXVALUE');
+ RegisterPropertyHelper(@TFMTBCDFIELDMINVALUE_R,@TFMTBCDFIELDMINVALUE_W,'MINVALUE');
+ RegisterPropertyHelper(@TFMTBCDFIELDPRECISION_R,@TFMTBCDFIELDPRECISION_W,'PRECISION');
+ end;
+end;
+{$ENDIF}
+procedure RIRegisterTBCDFIELD(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TBCDFIELD) do
+ begin
+ RegisterPropertyHelper(@TBCDFIELDVALUE_R,@TBCDFIELDVALUE_W,'VALUE');
+ RegisterPropertyHelper(@TBCDFIELDCURRENCY_R,@TBCDFIELDCURRENCY_W,'CURRENCY');
+ RegisterPropertyHelper(@TBCDFIELDMAXVALUE_R,@TBCDFIELDMAXVALUE_W,'MAXVALUE');
+ RegisterPropertyHelper(@TBCDFIELDMINVALUE_R,@TBCDFIELDMINVALUE_W,'MINVALUE');
+ RegisterPropertyHelper(@TBCDFIELDPRECISION_R,@TBCDFIELDPRECISION_W,'PRECISION');
+ end;
+end;
+{$ENDIF}
+
+procedure RIRegisterTVARBYTESFIELD(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TVARBYTESFIELD) do
+ begin
+ end;
+end;
+
+procedure RIRegisterTBYTESFIELD(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TBYTESFIELD) do
+ begin
+ end;
+end;
+
+procedure RIRegisterTBINARYFIELD(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TBINARYFIELD) do
+ begin
+ end;
+end;
+
+procedure RIRegisterTTIMEFIELD(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TTIMEFIELD) do
+ begin
+ end;
+end;
+
+procedure RIRegisterTDATEFIELD(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TDATEFIELD) do
+ begin
+ end;
+end;
+
+procedure RIRegisterTDATETIMEFIELD(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TDATETIMEFIELD) do
+ begin
+ RegisterPropertyHelper(@TDATETIMEFIELDVALUE_R,@TDATETIMEFIELDVALUE_W,'VALUE');
+ RegisterPropertyHelper(@TDATETIMEFIELDDISPLAYFORMAT_R,@TDATETIMEFIELDDISPLAYFORMAT_W,'DISPLAYFORMAT');
+ end;
+end;
+
+procedure RIRegisterTBOOLEANFIELD(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TBOOLEANFIELD) do
+ begin
+ RegisterPropertyHelper(@TBOOLEANFIELDVALUE_R,@TBOOLEANFIELDVALUE_W,'VALUE');
+ RegisterPropertyHelper(@TBOOLEANFIELDDISPLAYVALUES_R,@TBOOLEANFIELDDISPLAYVALUES_W,'DISPLAYVALUES');
+ end;
+end;
+
+procedure RIRegisterTCURRENCYFIELD(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TCURRENCYFIELD) do
+ begin
+ end;
+end;
+
+procedure RIRegisterTFLOATFIELD(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TFLOATFIELD) do
+ begin
+ {$IFNDEF FPC}
+ RegisterPropertyHelper(@TFLOATFIELDCURRENCY_R,@TFLOATFIELDCURRENCY_W,'CURRENCY');
+ {$ENDIF}
+ RegisterPropertyHelper(@TFLOATFIELDVALUE_R,@TFLOATFIELDVALUE_W,'VALUE');
+ RegisterPropertyHelper(@TFLOATFIELDMAXVALUE_R,@TFLOATFIELDMAXVALUE_W,'MAXVALUE');
+ RegisterPropertyHelper(@TFLOATFIELDMINVALUE_R,@TFLOATFIELDMINVALUE_W,'MINVALUE');
+ RegisterPropertyHelper(@TFLOATFIELDPRECISION_R,@TFLOATFIELDPRECISION_W,'PRECISION');
+ end;
+end;
+
+procedure RIRegisterTAUTOINCFIELD(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TAUTOINCFIELD) do
+ begin
+ end;
+end;
+
+procedure RIRegisterTWORDFIELD(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TWORDFIELD) do
+ begin
+ end;
+end;
+
+procedure RIRegisterTLARGEINTFIELD(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TLARGEINTFIELD) do
+ begin
+ RegisterPropertyHelper(@TLARGEINTFIELDASLARGEINT_R,@TLARGEINTFIELDASLARGEINT_W,'ASLARGEINT');
+ RegisterPropertyHelper(@TLARGEINTFIELDVALUE_R,@TLARGEINTFIELDVALUE_W,'VALUE');
+ RegisterPropertyHelper(@TLARGEINTFIELDMAXVALUE_R,@TLARGEINTFIELDMAXVALUE_W,'MAXVALUE');
+ RegisterPropertyHelper(@TLARGEINTFIELDMINVALUE_R,@TLARGEINTFIELDMINVALUE_W,'MINVALUE');
+ end;
+end;
+
+procedure RIRegisterTSMALLINTFIELD(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TSMALLINTFIELD) do
+ begin
+ end;
+end;
+
+procedure RIRegisterTINTEGERFIELD(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TINTEGERFIELD) do
+ begin
+ RegisterPropertyHelper(@TINTEGERFIELDVALUE_R,@TINTEGERFIELDVALUE_W,'VALUE');
+ RegisterPropertyHelper(@TINTEGERFIELDMAXVALUE_R,@TINTEGERFIELDMAXVALUE_W,'MAXVALUE');
+ RegisterPropertyHelper(@TINTEGERFIELDMINVALUE_R,@TINTEGERFIELDMINVALUE_W,'MINVALUE');
+ end;
+end;
+
+procedure RIRegisterTNUMERICFIELD(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TNUMERICFIELD) do
+ begin
+ RegisterPropertyHelper(@TNUMERICFIELDDISPLAYFORMAT_R,@TNUMERICFIELDDISPLAYFORMAT_W,'DISPLAYFORMAT');
+ RegisterPropertyHelper(@TNUMERICFIELDEDITFORMAT_R,@TNUMERICFIELDEDITFORMAT_W,'EDITFORMAT');
+ end;
+end;
+
+{$IFNDEF FPC}
+procedure RIRegisterTWIDESTRINGFIELD(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TWIDESTRINGFIELD) do
+ begin
+ RegisterPropertyHelper(@TWIDESTRINGFIELDVALUE_R,@TWIDESTRINGFIELDVALUE_W,'VALUE');
+ end;
+end;
+{$ENDIF}
+
+procedure RIRegisterTSTRINGFIELD(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TSTRINGFIELD) do
+ begin
+ RegisterPropertyHelper(@TSTRINGFIELDVALUE_R,@TSTRINGFIELDVALUE_W,'VALUE');
+ {$IFNDEF FPC}
+ RegisterPropertyHelper(@TSTRINGFIELDFIXEDCHAR_R,@TSTRINGFIELDFIXEDCHAR_W,'FIXEDCHAR');
+ RegisterPropertyHelper(@TSTRINGFIELDTRANSLITERATE_R,@TSTRINGFIELDTRANSLITERATE_W,'TRANSLITERATE');
+ {$ENDIF}
+ end;
+end;
+
+procedure RIRegisterTFIELD(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TFIELD) do
+ begin
+ RegisterMethod(@TFIELD.ASSIGNVALUE, 'ASSIGNVALUE');
+ RegisterVirtualMethod(@TFIELD.CLEAR, 'CLEAR');
+ RegisterMethod(@TFIELD.FOCUSCONTROL, 'FOCUSCONTROL');
+// RegisterMethod(@TFIELD.GETDATA, 'GETDATA');
+ RegisterVirtualMethod(@TFIELD.ISVALIDCHAR, 'ISVALIDCHAR');
+ RegisterMethod(@TFIELD.REFRESHLOOKUPLIST, 'REFRESHLOOKUPLIST');
+// RegisterMethod(@TFIELD.SETDATA, 'SETDATA');
+ RegisterVirtualMethod(@TFIELD.SETFIELDTYPE, 'SETFIELDTYPE');
+// RegisterMethod(@TFIELD.VALIDATE, 'VALIDATE');
+{$IFNDEF FPC}
+
+ RegisterPropertyHelper(@TFIELDEDITMASK_R,@TFIELDEDITMASK_W,'EDITMASK');
+ RegisterPropertyHelper(@TFIELDEDITMASKPTR_R,nil,'EDITMASKPTR');
+ RegisterPropertyHelper(@TFIELDEDITMASK_R,@TFIELDEDITMASK_W,'EDITMASK');
+ RegisterPropertyHelper(@TFIELDEDITMASKPTR_R,nil,'EDITMASKPTR');
+ RegisterPropertyHelper(@TFIELDFULLNAME_R,nil,'FULLNAME');
+ RegisterPropertyHelper(@TFIELDLOOKUP_R,@TFIELDLOOKUP_W,'LOOKUP');
+ RegisterPropertyHelper(@TFIELDPARENTFIELD_R,@TFIELDPARENTFIELD_W,'PARENTFIELD');
+ RegisterPropertyHelper(@TFIELDVALIDCHARS_R,@TFIELDVALIDCHARS_W,'VALIDCHARS');
+ RegisterPropertyHelper(@TFIELDAUTOGENERATEVALUE_R,@TFIELDAUTOGENERATEVALUE_W,'AUTOGENERATEVALUE');
+
+{$IFDEF DELPHI6UP}
+ RegisterPropertyHelper(@TFIELDASBCD_R,@TFIELDASBCD_W,'ASBCD');
+{$ENDIF}
+{$ENDIF}
+ RegisterPropertyHelper(@TFIELDASBOOLEAN_R,@TFIELDASBOOLEAN_W,'ASBOOLEAN');
+ RegisterPropertyHelper(@TFIELDASCURRENCY_R,@TFIELDASCURRENCY_W,'ASCURRENCY');
+ RegisterPropertyHelper(@TFIELDASDATETIME_R,@TFIELDASDATETIME_W,'ASDATETIME');
+ RegisterPropertyHelper(@TFIELDASFLOAT_R,@TFIELDASFLOAT_W,'ASFLOAT');
+ RegisterPropertyHelper(@TFIELDASINTEGER_R,@TFIELDASINTEGER_W,'ASINTEGER');
+ RegisterPropertyHelper(@TFIELDASSTRING_R,@TFIELDASSTRING_W,'ASSTRING');
+ RegisterPropertyHelper(@TFIELDASVARIANT_R,@TFIELDASVARIANT_W,'ASVARIANT');
+ RegisterPropertyHelper(@TFIELDATTRIBUTESET_R,@TFIELDATTRIBUTESET_W,'ATTRIBUTESET');
+ RegisterPropertyHelper(@TFIELDCALCULATED_R,@TFIELDCALCULATED_W,'CALCULATED');
+ RegisterPropertyHelper(@TFIELDCANMODIFY_R,nil,'CANMODIFY');
+ RegisterPropertyHelper(@TFIELDCURVALUE_R,nil,'CURVALUE');
+ RegisterPropertyHelper(@TFIELDDATASET_R,@TFIELDDATASET_W,'DATASET');
+ RegisterPropertyHelper(@TFIELDDATASIZE_R,nil,'DATASIZE');
+ RegisterPropertyHelper(@TFIELDDATATYPE_R,nil,'DATATYPE');
+ RegisterPropertyHelper(@TFIELDDISPLAYNAME_R,nil,'DISPLAYNAME');
+ RegisterPropertyHelper(@TFIELDDISPLAYTEXT_R,nil,'DISPLAYTEXT');
+ RegisterPropertyHelper(@TFIELDFIELDNO_R,nil,'FIELDNO');
+ RegisterPropertyHelper(@TFIELDISINDEXFIELD_R,nil,'ISINDEXFIELD');
+ RegisterPropertyHelper(@TFIELDISNULL_R,nil,'ISNULL');
+ RegisterPropertyHelper(@TFIELDLOOKUPLIST_R,nil,'LOOKUPLIST');
+ RegisterPropertyHelper(@TFIELDNEWVALUE_R,@TFIELDNEWVALUE_W,'NEWVALUE');
+ RegisterPropertyHelper(@TFIELDOFFSET_R,nil,'OFFSET');
+ RegisterPropertyHelper(@TFIELDOLDVALUE_R,nil,'OLDVALUE');
+ RegisterPropertyHelper(@TFIELDSIZE_R,@TFIELDSIZE_W,'SIZE');
+ RegisterPropertyHelper(@TFIELDTEXT_R,@TFIELDTEXT_W,'TEXT');
+ RegisterPropertyHelper(@TFIELDVALUE_R,@TFIELDVALUE_W,'VALUE');
+ RegisterPropertyHelper(@TFIELDALIGNMENT_R,@TFIELDALIGNMENT_W,'ALIGNMENT');
+ RegisterPropertyHelper(@TFIELDCUSTOMCONSTRAINT_R,@TFIELDCUSTOMCONSTRAINT_W,'CUSTOMCONSTRAINT');
+ RegisterPropertyHelper(@TFIELDCONSTRAINTERRORMESSAGE_R,@TFIELDCONSTRAINTERRORMESSAGE_W,'CONSTRAINTERRORMESSAGE');
+ RegisterPropertyHelper(@TFIELDDEFAULTEXPRESSION_R,@TFIELDDEFAULTEXPRESSION_W,'DEFAULTEXPRESSION');
+ RegisterPropertyHelper(@TFIELDDISPLAYLABEL_R,@TFIELDDISPLAYLABEL_W,'DISPLAYLABEL');
+ RegisterPropertyHelper(@TFIELDDISPLAYWIDTH_R,@TFIELDDISPLAYWIDTH_W,'DISPLAYWIDTH');
+ RegisterPropertyHelper(@TFIELDFIELDKIND_R,@TFIELDFIELDKIND_W,'FIELDKIND');
+ RegisterPropertyHelper(@TFIELDFIELDNAME_R,@TFIELDFIELDNAME_W,'FIELDNAME');
+ RegisterPropertyHelper(@TFIELDHASCONSTRAINTS_R,nil,'HASCONSTRAINTS');
+ RegisterPropertyHelper(@TFIELDINDEX_R,@TFIELDINDEX_W,'INDEX');
+ RegisterPropertyHelper(@TFIELDIMPORTEDCONSTRAINT_R,@TFIELDIMPORTEDCONSTRAINT_W,'IMPORTEDCONSTRAINT');
+ RegisterPropertyHelper(@TFIELDLOOKUPDATASET_R,@TFIELDLOOKUPDATASET_W,'LOOKUPDATASET');
+ RegisterPropertyHelper(@TFIELDLOOKUPKEYFIELDS_R,@TFIELDLOOKUPKEYFIELDS_W,'LOOKUPKEYFIELDS');
+ RegisterPropertyHelper(@TFIELDLOOKUPRESULTFIELD_R,@TFIELDLOOKUPRESULTFIELD_W,'LOOKUPRESULTFIELD');
+ RegisterPropertyHelper(@TFIELDKEYFIELDS_R,@TFIELDKEYFIELDS_W,'KEYFIELDS');
+ RegisterPropertyHelper(@TFIELDLOOKUPCACHE_R,@TFIELDLOOKUPCACHE_W,'LOOKUPCACHE');
+ RegisterPropertyHelper(@TFIELDORIGIN_R,@TFIELDORIGIN_W,'ORIGIN');
+ RegisterPropertyHelper(@TFIELDPROVIDERFLAGS_R,@TFIELDPROVIDERFLAGS_W,'PROVIDERFLAGS');
+ RegisterPropertyHelper(@TFIELDREADONLY_R,@TFIELDREADONLY_W,'READONLY');
+ RegisterPropertyHelper(@TFIELDREQUIRED_R,@TFIELDREQUIRED_W,'REQUIRED');
+ RegisterPropertyHelper(@TFIELDVISIBLE_R,@TFIELDVISIBLE_W,'VISIBLE');
+ RegisterEventPropertyHelper(@TFIELDONCHANGE_R,@TFIELDONCHANGE_W,'ONCHANGE');
+ RegisterEventPropertyHelper(@TFIELDONGETTEXT_R,@TFIELDONGETTEXT_W,'ONGETTEXT');
+ RegisterEventPropertyHelper(@TFIELDONSETTEXT_R,@TFIELDONSETTEXT_W,'ONSETTEXT');
+ RegisterEventPropertyHelper(@TFIELDONVALIDATE_R,@TFIELDONVALIDATE_W,'ONVALIDATE');
+ end;
+end;
+
+procedure RIRegisterTLOOKUPLIST(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TLOOKUPLIST) do
+ begin
+ RegisterConstructor(@TLOOKUPLIST.CREATE, 'CREATE');
+ {$IFDEF DELPHI2009UP}
+ RegisterVirtualAbstractMethod(TDefaultLookupList, @TDefaultLookupList.ADD, 'ADD');
+ RegisterVirtualAbstractMethod(TDefaultLookupList, @TDefaultLookupList.CLEAR, 'CLEAR');
+ RegisterVirtualAbstractMethod(TDefaultLookupList, @TDefaultLookupList.VALUEOFKEY, 'VALUEOFKEY');
+ {$ELSE}
+ RegisterMethod(@TLOOKUPLIST.ADD, 'ADD');
+ RegisterMethod(@TLOOKUPLIST.CLEAR, 'CLEAR');
+ RegisterMethod(@TLOOKUPLIST.VALUEOFKEY, 'VALUEOFKEY');
+ {$ENDIF}
+ end;
+end;
+
+procedure RIRegisterTFIELDS(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TFIELDS) do
+ begin
+ RegisterConstructor(@TFIELDS.CREATE, 'CREATE');
+ RegisterMethod(@TFIELDS.ADD, 'ADD');
+ RegisterMethod(@TFIELDS.CHECKFIELDNAME, 'CHECKFIELDNAME');
+ RegisterMethod(@TFIELDS.CHECKFIELDNAMES, 'CHECKFIELDNAMES');
+ RegisterMethod(@TFIELDS.CLEAR, 'CLEAR');
+ RegisterMethod(@TFIELDS.FINDFIELD, 'FINDFIELD');
+ RegisterMethod(@TFIELDS.FIELDBYNAME, 'FIELDBYNAME');
+ RegisterMethod(@TFIELDS.FIELDBYNUMBER, 'FIELDBYNUMBER');
+ RegisterMethod(@TFIELDS.GETFIELDNAMES, 'GETFIELDNAMES');
+ RegisterMethod(@TFIELDS.INDEXOF, 'INDEXOF');
+ RegisterMethod(@TFIELDS.REMOVE, 'REMOVE');
+ RegisterPropertyHelper(@TFIELDSCOUNT_R,nil,'COUNT');
+ RegisterPropertyHelper(@TFIELDSDATASET_R,nil,'DATASET');
+ RegisterPropertyHelper(@TFIELDSFIELDS_R,@TFIELDSFIELDS_W,'FIELDS');
+ end;
+end;
+
+{$IFNDEF FPC}
+procedure RIRegisterTFIELDLIST(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TFIELDLIST) do
+ begin
+ RegisterMethod(@TFIELDLIST.FIELDBYNAME, 'FIELDBYNAME');
+ RegisterMethod(@TFIELDLIST.FIND, 'FIND');
+ RegisterPropertyHelper(@TFIELDLISTFIELDS_R,nil,'FIELDS');
+ end;
+end;
+
+procedure RIRegisterTFIELDDEFLIST(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TFIELDDEFLIST) do
+ begin
+ RegisterMethod(@TFIELDDEFLIST.FIELDBYNAME, 'FIELDBYNAME');
+ RegisterMethod(@TFIELDDEFLIST.FIND, 'FIND');
+ RegisterPropertyHelper(@TFIELDDEFLISTFIELDDEFS_R,nil,'FIELDDEFS');
+ end;
+end;
+
+
+procedure RIRegisterTFLATLIST(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TFLATLIST) do
+ begin
+ RegisterConstructor(@TFLATLIST.CREATE, 'CREATE');
+ RegisterMethod(@TFLATLIST.UPDATE, 'UPDATE');
+ RegisterPropertyHelper(@TFLATLISTDATASET_R,nil,'DATASET');
+ end;
+end;
+{$ENDIF}
+
+
+procedure RIRegisterTINDEXDEFS(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TINDEXDEFS) do
+ begin
+ RegisterConstructor(@TINDEXDEFS.CREATE, 'CREATE');
+ RegisterMethod(@TINDEXDEFS.ADDINDEXDEF, 'ADDINDEXDEF');
+ RegisterMethod(@TINDEXDEFS.FIND, 'FIND');
+ RegisterMethod(@TINDEXDEFS.UPDATE, 'UPDATE');
+ RegisterMethod(@TINDEXDEFS.FINDINDEXFORFIELDS, 'FINDINDEXFORFIELDS');
+ RegisterMethod(@TINDEXDEFS.GETINDEXFORFIELDS, 'GETINDEXFORFIELDS');
+ RegisterMethod(@TINDEXDEFS.ADD, 'ADD');
+ RegisterPropertyHelper(@TINDEXDEFSITEMS_R,@TINDEXDEFSITEMS_W,'ITEMS');
+ end;
+end;
+
+procedure RIRegisterTINDEXDEF(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TINDEXDEF) do
+ begin
+ RegisterConstructor(@TINDEXDEF.CREATE, 'CREATE');
+{$IFNDEF FPC}
+ RegisterPropertyHelper(@TINDEXDEFFIELDEXPRESSION_R,nil,'FIELDEXPRESSION');
+ RegisterPropertyHelper(@TINDEXDEFCASEINSFIELDS_R,@TINDEXDEFCASEINSFIELDS_W,'CASEINSFIELDS');
+ RegisterPropertyHelper(@TINDEXDEFGROUPINGLEVEL_R,@TINDEXDEFGROUPINGLEVEL_W,'GROUPINGLEVEL');
+ RegisterPropertyHelper(@TINDEXDEFDESCFIELDS_R,@TINDEXDEFDESCFIELDS_W,'DESCFIELDS');
+
+{$ENDIF}
+ RegisterPropertyHelper(@TINDEXDEFEXPRESSION_R,@TINDEXDEFEXPRESSION_W,'EXPRESSION');
+ RegisterPropertyHelper(@TINDEXDEFFIELDS_R,@TINDEXDEFFIELDS_W,'FIELDS');
+ RegisterPropertyHelper(@TINDEXDEFOPTIONS_R,@TINDEXDEFOPTIONS_W,'OPTIONS');
+ RegisterPropertyHelper(@TINDEXDEFSOURCE_R,@TINDEXDEFSOURCE_W,'SOURCE');
+ end;
+end;
+
+procedure RIRegisterTFIELDDEFS(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TFIELDDEFS) do
+ begin
+ RegisterConstructor(@TFIELDDEFS.CREATE, 'CREATE');
+ RegisterMethod(@TFIELDDEFS.ADDFIELDDEF, 'ADDFIELDDEF');
+ RegisterMethod(@TFIELDDEFS.FIND, 'FIND');
+ RegisterMethod(@TFIELDDEFS.UPDATE, 'UPDATE');
+{$IFNDEF FPC}
+ RegisterMethod(@TFIELDDEFS.ADD, 'ADD');
+ RegisterPropertyHelper(@TFIELDDEFSPARENTDEF_R,nil,'PARENTDEF');
+
+{$ENDIF}
+ RegisterPropertyHelper(@TFIELDDEFSHIDDENFIELDS_R,@TFIELDDEFSHIDDENFIELDS_W,'HIDDENFIELDS');
+ RegisterPropertyHelper(@TFIELDDEFSITEMS_R,@TFIELDDEFSITEMS_W,'ITEMS');
+ end;
+end;
+
+procedure RIRegisterTFIELDDEF(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TFIELDDEF) do
+ begin
+// RegisterConstructor(@TFIELDDEF.CREATE, 'CREATE');
+{$IFNDEF FPC}
+ RegisterMethod(@TFIELDDEF.ADDCHILD, 'ADDCHILD');
+ RegisterMethod(@TFIELDDEF.HASCHILDDEFS, 'HASCHILDDEFS');
+
+{$ENDIF}
+ RegisterMethod(@TFIELDDEF.CREATEFIELD, 'CREATEFIELD');
+{$IFNDEF FPC}
+ RegisterPropertyHelper(@TFIELDDEFFIELDNO_R,@TFIELDDEFFIELDNO_W,'FIELDNO');
+ RegisterPropertyHelper(@TFIELDDEFPARENTDEF_R,nil,'PARENTDEF');
+ RegisterPropertyHelper(@TFIELDDEFCHILDDEFS_R,@TFIELDDEFCHILDDEFS_W,'CHILDDEFS');
+ RegisterPropertyHelper(@TFIELDDEFREQUIRED_R,@TFIELDDEFREQUIRED_W,'REQUIRED');
+
+{$ENDIF}
+ RegisterPropertyHelper(@TFIELDDEFFIELDCLASS_R,nil,'FIELDCLASS');
+ RegisterPropertyHelper(@TFIELDDEFINTERNALCALCFIELD_R,@TFIELDDEFINTERNALCALCFIELD_W,'INTERNALCALCFIELD');
+ RegisterPropertyHelper(@TFIELDDEFATTRIBUTES_R,@TFIELDDEFATTRIBUTES_W,'ATTRIBUTES');
+ RegisterPropertyHelper(@TFIELDDEFDATATYPE_R,@TFIELDDEFDATATYPE_W,'DATATYPE');
+ RegisterPropertyHelper(@TFIELDDEFPRECISION_R,@TFIELDDEFPRECISION_W,'PRECISION');
+ RegisterPropertyHelper(@TFIELDDEFSIZE_R,@TFIELDDEFSIZE_W,'SIZE');
+ end;
+end;
+
+{$IFNDEF FPC}
+procedure RIRegisterTDEFCOLLECTION(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TDEFCOLLECTION) do
+ begin
+ RegisterConstructor(@TDEFCOLLECTION.CREATE, 'CREATE');
+ RegisterMethod(@TDEFCOLLECTION.FIND, 'FIND');
+ RegisterMethod(@TDEFCOLLECTION.GETITEMNAMES, 'GETITEMNAMES');
+ RegisterMethod(@TDEFCOLLECTION.INDEXOF, 'INDEXOF');
+ RegisterPropertyHelper(@TDEFCOLLECTIONDATASET_R,nil,'DATASET');
+ RegisterPropertyHelper(@TDEFCOLLECTIONUPDATED_R,@TDEFCOLLECTIONUPDATED_W,'UPDATED');
+ end;
+end;
+
+procedure RIRegisterTNAMEDITEM(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TNAMEDITEM) do
+ begin
+ RegisterPropertyHelper(@TNAMEDITEMNAME_R,@TNAMEDITEMNAME_W,'NAME');
+ end;
+end;
+{$ENDIF}
+
+
+procedure RIRegister_DB(CL: TPSRuntimeClassImporter);
+Begin
+RIRegisterTFIELDDEF(Cl);
+RIRegisterTFIELDDEFS(Cl);
+RIRegisterTINDEXDEF(Cl);
+RIRegisterTINDEXDEFS(Cl);
+RIRegisterTFIELDS(Cl);
+RIRegisterTLOOKUPLIST(Cl);
+RIRegisterTFIELD(Cl);
+RIRegisterTSTRINGFIELD(Cl);
+RIRegisterTNUMERICFIELD(Cl);
+RIRegisterTINTEGERFIELD(Cl);
+RIRegisterTSMALLINTFIELD(Cl);
+RIRegisterTLARGEINTFIELD(Cl);
+RIRegisterTWORDFIELD(Cl);
+RIRegisterTAUTOINCFIELD(Cl);
+RIRegisterTFLOATFIELD(Cl);
+RIRegisterTCURRENCYFIELD(Cl);
+RIRegisterTBOOLEANFIELD(Cl);
+RIRegisterTDATETIMEFIELD(Cl);
+RIRegisterTDATEFIELD(Cl);
+RIRegisterTTIMEFIELD(Cl);
+RIRegisterTBINARYFIELD(Cl);
+RIRegisterTBYTESFIELD(Cl);
+RIRegisterTVARBYTESFIELD(Cl);
+{$IFNDEF FPC}
+RIRegisterTNAMEDITEM(Cl);
+RIRegisterTDEFCOLLECTION(Cl);
+RIRegisterTWIDESTRINGFIELD(Cl);
+RIRegisterTFLATLIST(Cl);
+RIRegisterTFIELDDEFLIST(Cl);
+RIRegisterTFIELDLIST(Cl);
+RIRegisterTBCDFIELD(Cl);
+{$IFDEF DELPHI6UP}
+RIRegisterTFMTBCDFIELD(Cl);
+{$ENDIF}
+{$ENDIF}
+
+RIRegisterTBLOBFIELD(Cl);
+RIRegisterTMEMOFIELD(Cl);
+RIRegisterTGRAPHICFIELD(Cl);
+{$IFNDEF FPC}
+RIRegisterTOBJECTFIELD(Cl);
+RIRegisterTADTFIELD(Cl);
+RIRegisterTARRAYFIELD(Cl);
+RIRegisterTDATASETFIELD(Cl);
+RIRegisterTREFERENCEFIELD(Cl);
+RIRegisterTVARIANTFIELD(Cl);
+RIRegisterTGUIDFIELD(Cl);
+{$ENDIF}
+RIRegisterTPARAM(Cl);
+RIRegisterTPARAMS(Cl);
+RIRegisterTDATASET(Cl);
+end;
+
+{$IFDEF USEIMPORTER}
+initialization
+RIImporter.Invoke(RIRegister_DB);
+{$ENDIF}
+end.
diff --git a/Units/PascalScript/uPSR_buttons.pas b/Units/PascalScript/uPSR_buttons.pas
new file mode 100644
index 0000000..8117e4e
--- /dev/null
+++ b/Units/PascalScript/uPSR_buttons.pas
@@ -0,0 +1,38 @@
+
+unit uPSR_buttons;
+{$I PascalScript.inc}
+interface
+uses
+ uPSRuntime, uPSUtils;
+
+
+procedure RIRegisterTSPEEDBUTTON(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTBITBTN(Cl: TPSRuntimeClassImporter);
+
+procedure RIRegister_Buttons(Cl: TPSRuntimeClassImporter);
+
+implementation
+uses
+ Classes{$IFDEF CLX}, QControls, QButtons{$ELSE}, Controls, Buttons{$ENDIF};
+
+procedure RIRegisterTSPEEDBUTTON(Cl: TPSRuntimeClassImporter);
+begin
+ Cl.Add(TSPEEDBUTTON);
+end;
+
+
+procedure RIRegisterTBITBTN(Cl: TPSRuntimeClassImporter);
+begin
+ Cl.Add(TBITBTN);
+end;
+
+procedure RIRegister_Buttons(Cl: TPSRuntimeClassImporter);
+begin
+ RIRegisterTSPEEDBUTTON(cl);
+ RIRegisterTBITBTN(cl);
+end;
+
+// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl)
+
+
+end.
diff --git a/Units/PascalScript/uPSR_classes.pas b/Units/PascalScript/uPSR_classes.pas
new file mode 100644
index 0000000..b29abc8
--- /dev/null
+++ b/Units/PascalScript/uPSR_classes.pas
@@ -0,0 +1,383 @@
+
+unit uPSR_classes;
+
+{$I PascalScript.inc}
+interface
+uses
+ uPSRuntime, uPSUtils;
+
+
+procedure RIRegisterTStrings(cl: TPSRuntimeClassImporter; Streams: Boolean);
+procedure RIRegisterTStringList(cl: TPSRuntimeClassImporter);
+{$IFNDEF PS_MINIVCL}
+procedure RIRegisterTBITS(Cl: TPSRuntimeClassImporter);
+{$ENDIF}
+procedure RIRegisterTSTREAM(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTHANDLESTREAM(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTFILESTREAM(Cl: TPSRuntimeClassImporter);
+{$IFNDEF PS_MINIVCL}
+procedure RIRegisterTCUSTOMMEMORYSTREAM(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTMEMORYSTREAM(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTRESOURCESTREAM(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTPARSER(Cl: TPSRuntimeClassImporter);
+{$IFDEF DELPHI3UP}
+procedure RIRegisterTOWNEDCOLLECTION(Cl: TPSRuntimeClassImporter);
+{$ENDIF}
+procedure RIRegisterTCOLLECTION(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTCOLLECTIONITEM(Cl: TPSRuntimeClassImporter);
+{$ENDIF}
+
+procedure RIRegister_Classes(Cl: TPSRuntimeClassImporter; Streams: Boolean{$IFDEF D4PLUS}=True{$ENDIF});
+
+implementation
+uses
+ Classes;
+
+procedure TStringsCountR(Self: TStrings; var T: Longint); begin T := Self.Count; end;
+
+procedure TStringsTextR(Self: TStrings; var T: string); begin T := Self.Text; end;
+procedure TStringsTextW(Self: TStrings; T: string); begin Self.Text:= T; end;
+
+procedure TStringsCommaTextR(Self: TStrings; var T: string); begin T := Self.CommaText; end;
+procedure TStringsCommaTextW(Self: TStrings; T: string); begin Self.CommaText:= T; end;
+
+procedure TStringsObjectsR(Self: TStrings; var T: TObject; I: Longint);
+begin
+T := Self.Objects[I];
+end;
+procedure TStringsObjectsW(Self: TStrings; const T: TObject; I: Longint);
+begin
+ Self.Objects[I]:= T;
+end;
+
+procedure TStringsStringsR(Self: TStrings; var T: string; I: Longint);
+begin
+T := Self.Strings[I];
+end;
+procedure TStringsStringsW(Self: TStrings; const T: string; I: Longint);
+begin
+ Self.Strings[I]:= T;
+end;
+
+procedure TStringsNamesR(Self: TStrings; var T: string; I: Longint);
+begin
+T := Self.Names[I];
+end;
+procedure TStringsValuesR(Self: TStrings; var T: string; const I: string);
+begin
+T := Self.Values[I];
+end;
+procedure TStringsValuesW(Self: TStrings; Const T, I: String);
+begin
+ Self.Values[I]:= T;
+end;
+
+procedure RIRegisterTStrings(cl: TPSRuntimeClassImporter; Streams: Boolean); // requires TPersistent
+begin
+ with Cl.Add(TStrings) do
+ begin
+ RegisterVirtualMethod(@TStrings.Add, 'ADD');
+ RegisterMethod(@TStrings.Append, 'APPEND');
+ RegisterVirtualMethod(@TStrings.AddStrings, 'ADDSTRINGS');
+ RegisterVirtualAbstractMethod(TStringList, @TStringList.Clear, 'CLEAR');
+ RegisterVirtualAbstractMethod(TStringList, @TStringList.Delete, 'DELETE');
+ RegisterVirtualMethod(@TStrings.IndexOf, 'INDEXOF');
+ RegisterVirtualAbstractMethod(TStringList, @TStringList.Insert, 'INSERT');
+ RegisterPropertyHelper(@TStringsCountR, nil, 'COUNT');
+ RegisterPropertyHelper(@TStringsTextR, @TStringsTextW, 'TEXT');
+ RegisterPropertyHelper(@TStringsCommaTextR, @TStringsCommatextW, 'COMMATEXT');
+ if Streams then
+ begin
+ RegisterVirtualMethod(@TStrings.LoadFromFile, 'LOADFROMFILE');
+ RegisterVirtualMethod(@TStrings.SaveToFile, 'SAVETOFILE');
+ end;
+ RegisterPropertyHelper(@TStringsStringsR, @TStringsStringsW, 'STRINGS');
+ RegisterPropertyHelper(@TStringsObjectsR, @TStringsObjectsW, 'OBJECTS');
+
+ {$IFNDEF PS_MINIVCL}
+ RegisterMethod(@TStrings.BeginUpdate, 'BEGINUPDATE');
+ RegisterMethod(@TStrings.EndUpdate, 'ENDUPDATE');
+ RegisterMethod(@TStrings.Equals, 'EQUALS');
+ RegisterVirtualMethod(@TStrings.Exchange, 'EXCHANGE');
+ RegisterMethod(@TStrings.IndexOfName, 'INDEXOFNAME');
+ if Streams then
+ RegisterVirtualMethod(@TStrings.LoadFromStream, 'LOADFROMSTREAM');
+ RegisterVirtualMethod(@TStrings.Move, 'MOVE');
+ if Streams then
+ RegisterVirtualMethod(@TStrings.SaveToStream, 'SAVETOSTREAM');
+ RegisterVirtualMethod(@TStrings.SetText, 'SETTEXT');
+ RegisterPropertyHelper(@TStringsNamesR, nil, 'NAMES');
+ RegisterPropertyHelper(@TStringsValuesR, @TStringsValuesW, 'VALUES');
+ RegisterVirtualMethod(@TSTRINGS.ADDOBJECT, 'ADDOBJECT');
+ RegisterVirtualMethod(@TSTRINGS.GETTEXT, 'GETTEXT');
+ RegisterMethod(@TSTRINGS.INDEXOFOBJECT, 'INDEXOFOBJECT');
+ RegisterMethod(@TSTRINGS.INSERTOBJECT, 'INSERTOBJECT');
+ {$ENDIF}
+ end;
+end;
+
+procedure TSTRINGLISTDUPLICATES_R(Self: TSTRINGLIST; var T: TDUPLICATES); begin T := Self.DUPLICATES; end;
+procedure TSTRINGLISTDUPLICATES_W(Self: TSTRINGLIST; const T: TDUPLICATES); begin Self.DUPLICATES := T; end;
+procedure TSTRINGLISTSORTED_R(Self: TSTRINGLIST; var T: BOOLEAN); begin T := Self.SORTED; end;
+procedure TSTRINGLISTSORTED_W(Self: TSTRINGLIST; const T: BOOLEAN); begin Self.SORTED := T; end;
+procedure TSTRINGLISTONCHANGE_R(Self: TSTRINGLIST; var T: TNOTIFYEVENT);
+begin
+T := Self.ONCHANGE; end;
+procedure TSTRINGLISTONCHANGE_W(Self: TSTRINGLIST; const T: TNOTIFYEVENT);
+begin
+Self.ONCHANGE := T; end;
+procedure TSTRINGLISTONCHANGING_R(Self: TSTRINGLIST; var T: TNOTIFYEVENT); begin T := Self.ONCHANGING; end;
+procedure TSTRINGLISTONCHANGING_W(Self: TSTRINGLIST; const T: TNOTIFYEVENT); begin Self.ONCHANGING := T; end;
+procedure RIRegisterTSTRINGLIST(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TSTRINGLIST) do
+ begin
+ RegisterVirtualMethod(@TSTRINGLIST.FIND, 'FIND');
+ RegisterVirtualMethod(@TSTRINGLIST.SORT, 'SORT');
+ RegisterPropertyHelper(@TSTRINGLISTDUPLICATES_R, @TSTRINGLISTDUPLICATES_W, 'DUPLICATES');
+ RegisterPropertyHelper(@TSTRINGLISTSORTED_R, @TSTRINGLISTSORTED_W, 'SORTED');
+ RegisterEventPropertyHelper(@TSTRINGLISTONCHANGE_R, @TSTRINGLISTONCHANGE_W, 'ONCHANGE');
+ RegisterEventPropertyHelper(@TSTRINGLISTONCHANGING_R, @TSTRINGLISTONCHANGING_W, 'ONCHANGING');
+ end;
+end;
+
+{$IFNDEF PS_MINIVCL}
+procedure TBITSBITS_W(Self: TBITS; T: BOOLEAN; t1: INTEGER); begin Self.BITS[t1] := T; end;
+procedure TBITSBITS_R(Self: TBITS; var T: BOOLEAN; t1: INTEGER); begin T := Self.Bits[t1]; end;
+procedure TBITSSIZE_R(Self: TBITS; T: INTEGER); begin Self.SIZE := T; end;
+procedure TBITSSIZE_W(Self: TBITS; var T: INTEGER); begin T := Self.SIZE; end;
+
+procedure RIRegisterTBITS(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TBITS) do
+ begin
+ RegisterMethod(@TBITS.OPENBIT, 'OPENBIT');
+ RegisterPropertyHelper(@TBITSBITS_R, @TBITSBITS_W, 'BITS');
+ RegisterPropertyHelper(@TBITSSIZE_R, @TBITSSIZE_W, 'SIZE');
+ end;
+end;
+{$ENDIF}
+
+procedure TSTREAMPOSITION_R(Self: TSTREAM; var T: LONGINT); begin t := Self.POSITION; end;
+procedure TSTREAMPOSITION_W(Self: TSTREAM; T: LONGINT); begin Self.POSITION := t; end;
+procedure TSTREAMSIZE_R(Self: TSTREAM; var T: LONGINT); begin t := Self.SIZE; end;
+{$IFDEF DELPHI3UP}
+procedure TSTREAMSIZE_W(Self: TSTREAM; T: LONGINT); begin Self.SIZE := t; end;
+{$ENDIF}
+
+procedure RIRegisterTSTREAM(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TSTREAM) do
+ begin
+ RegisterVirtualAbstractMethod(TMemoryStream, @TMemoryStream.READ, 'READ');
+ RegisterVirtualAbstractMethod(TMemoryStream, @TMemoryStream.WRITE, 'WRITE');
+ RegisterVirtualAbstractMethod(TMemoryStream, @TMemoryStream.SEEK, 'SEEK');
+ RegisterMethod(@TSTREAM.READBUFFER, 'READBUFFER');
+ RegisterMethod(@TSTREAM.WRITEBUFFER, 'WRITEBUFFER');
+ RegisterMethod(@TSTREAM.COPYFROM, 'COPYFROM');
+ RegisterPropertyHelper(@TSTREAMPOSITION_R, @TSTREAMPOSITION_W, 'POSITION');
+ RegisterPropertyHelper(@TSTREAMSIZE_R, {$IFDEF DELPHI3UP}@TSTREAMSIZE_W, {$ELSE}nil, {$ENDIF}'SIZE');
+ end;
+end;
+
+procedure THANDLESTREAMHANDLE_R(Self: THANDLESTREAM; var T: INTEGER); begin T := Self.HANDLE; end;
+
+procedure RIRegisterTHANDLESTREAM(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(THANDLESTREAM) do
+ begin
+ RegisterConstructor(@THANDLESTREAM.CREATE, 'CREATE');
+ RegisterPropertyHelper(@THANDLESTREAMHANDLE_R, nil, 'HANDLE');
+ end;
+end;
+
+{$IFDEF FPC}
+// mh: because FPC doesn't handle pointers to overloaded functions
+function TFileStreamCreate(filename: string; mode: word): TFileStream;
+begin
+ result := TFilestream.Create(filename, mode);
+end;
+{$ENDIF}
+
+procedure RIRegisterTFILESTREAM(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TFILESTREAM) do
+ begin
+ {$IFDEF FPC}
+ RegisterConstructor(@TFileStreamCreate, 'CREATE');
+ {$ELSE}
+ RegisterConstructor(@TFILESTREAM.CREATE, 'CREATE');
+ {$ENDIF}
+ end;
+end;
+
+{$IFNDEF PS_MINIVCL}
+procedure RIRegisterTCUSTOMMEMORYSTREAM(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TCUSTOMMEMORYSTREAM) do
+ begin
+ RegisterMethod(@TCUSTOMMEMORYSTREAM.SAVETOSTREAM, 'SAVETOSTREAM');
+ RegisterMethod(@TCUSTOMMEMORYSTREAM.SAVETOFILE, 'SAVETOFILE');
+ end;
+end;
+
+procedure RIRegisterTMEMORYSTREAM(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TMEMORYSTREAM) do
+ begin
+ RegisterMethod(@TMEMORYSTREAM.CLEAR, 'CLEAR');
+ RegisterMethod(@TMEMORYSTREAM.LOADFROMSTREAM, 'LOADFROMSTREAM');
+ RegisterMethod(@TMEMORYSTREAM.LOADFROMFILE, 'LOADFROMFILE');
+ RegisterMethod(@TMEMORYSTREAM.SETSIZE, 'SETSIZE');
+ end;
+end;
+
+procedure RIRegisterTRESOURCESTREAM(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TRESOURCESTREAM) do
+ begin
+ RegisterConstructor(@TRESOURCESTREAM.CREATE, 'CREATE');
+ RegisterConstructor(@TRESOURCESTREAM.CREATEFROMID, 'CREATEFROMID');
+ end;
+end;
+
+procedure TPARSERSOURCELINE_R(Self: TPARSER; var T: INTEGER); begin T := Self.SOURCELINE; end;
+procedure TPARSERTOKEN_R(Self: TPARSER; var T: CHAR); begin T := Self.TOKEN; end;
+
+procedure RIRegisterTPARSER(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TPARSER) do
+ begin
+ RegisterConstructor(@TPARSER.CREATE, 'CREATE');
+ RegisterMethod(@TPARSER.CHECKTOKEN, 'CHECKTOKEN');
+ RegisterMethod(@TPARSER.CHECKTOKENSYMBOL, 'CHECKTOKENSYMBOL');
+ RegisterMethod(@TPARSER.ERROR, 'ERROR');
+ RegisterMethod(@TPARSER.ERRORSTR, 'ERRORSTR');
+ RegisterMethod(@TPARSER.HEXTOBINARY, 'HEXTOBINARY');
+ RegisterMethod(@TPARSER.NEXTTOKEN, 'NEXTTOKEN');
+ RegisterMethod(@TPARSER.SOURCEPOS, 'SOURCEPOS');
+ RegisterMethod(@TPARSER.TOKENCOMPONENTIDENT, 'TOKENCOMPONENTIDENT');
+ RegisterMethod(@TPARSER.TOKENFLOAT, 'TOKENFLOAT');
+ RegisterMethod(@TPARSER.TOKENINT, 'TOKENINT');
+ RegisterMethod(@TPARSER.TOKENSTRING, 'TOKENSTRING');
+ RegisterMethod(@TPARSER.TOKENSYMBOLIS, 'TOKENSYMBOLIS');
+ RegisterPropertyHelper(@TPARSERSOURCELINE_R, nil, 'SOURCELINE');
+ RegisterPropertyHelper(@TPARSERTOKEN_R, nil, 'TOKEN');
+ end;
+end;
+
+procedure TCOLLECTIONITEMS_W(Self: TCOLLECTION; const T: TCOLLECTIONITEM; const t1: INTEGER);
+begin Self.ITEMS[t1] := T; end;
+
+procedure TCOLLECTIONITEMS_R(Self: TCOLLECTION; var T: TCOLLECTIONITEM; const t1: INTEGER);
+begin T := Self.ITEMS[t1]; end;
+
+{$IFDEF DELPHI3UP}
+procedure TCOLLECTIONITEMCLASS_R(Self: TCOLLECTION; var T: TCOLLECTIONITEMCLASS);
+begin T := Self.ITEMCLASS; end;
+{$ENDIF}
+
+procedure TCOLLECTIONCOUNT_R(Self: TCOLLECTION; var T: INTEGER);
+begin T := Self.COUNT; end;
+
+{$IFDEF DELPHI3UP}
+procedure TCOLLECTIONITEMDISPLAYNAME_W(Self: TCOLLECTIONITEM; const T: STRING);
+begin Self.DISPLAYNAME := T; end;
+{$ENDIF}
+
+{$IFDEF DELPHI3UP}
+procedure TCOLLECTIONITEMDISPLAYNAME_R(Self: TCOLLECTIONITEM; var T: STRING);
+begin T := Self.DISPLAYNAME; end;
+{$ENDIF}
+
+procedure TCOLLECTIONITEMINDEX_W(Self: TCOLLECTIONITEM; const T: INTEGER);
+begin Self.INDEX := T; end;
+
+procedure TCOLLECTIONITEMINDEX_R(Self: TCOLLECTIONITEM; var T: INTEGER);
+begin T := Self.INDEX; end;
+
+{$IFDEF DELPHI3UP}
+procedure TCOLLECTIONITEMID_R(Self: TCOLLECTIONITEM; var T: INTEGER);
+begin T := Self.ID; end;
+{$ENDIF}
+
+procedure TCOLLECTIONITEMCOLLECTION_W(Self: TCOLLECTIONITEM; const T: TCOLLECTION);
+begin Self.COLLECTION := T; end;
+
+procedure TCOLLECTIONITEMCOLLECTION_R(Self: TCOLLECTIONITEM; var T: TCOLLECTION);
+begin T := Self.COLLECTION; end;
+
+{$IFDEF DELPHI3UP}
+procedure RIRegisterTOWNEDCOLLECTION(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TOWNEDCOLLECTION) do
+ begin
+ RegisterConstructor(@TOWNEDCOLLECTION.CREATE, 'CREATE');
+ end;
+end;
+{$ENDIF}
+
+procedure RIRegisterTCOLLECTION(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TCOLLECTION) do
+ begin
+ RegisterConstructor(@TCOLLECTION.CREATE, 'CREATE');
+{$IFDEF DELPHI6UP} {$IFNDEF FPC} RegisterMethod(@TCOLLECTION.OWNER, 'OWNER'); {$ENDIF} {$ENDIF} // no owner in FPC
+ RegisterMethod(@TCOLLECTION.ADD, 'ADD');
+ RegisterVirtualMethod(@TCOLLECTION.BEGINUPDATE, 'BEGINUPDATE');
+ RegisterMethod(@TCOLLECTION.CLEAR, 'CLEAR');
+{$IFDEF DELPHI5UP} RegisterMethod(@TCOLLECTION.DELETE, 'DELETE'); {$ENDIF}
+ RegisterVirtualMethod(@TCOLLECTION.ENDUPDATE, 'ENDUPDATE');
+{$IFDEF DELPHI3UP} RegisterMethod(@TCOLLECTION.FINDITEMID, 'FINDITEMID'); {$ENDIF}
+{$IFDEF DELPHI3UP} RegisterMethod(@TCOLLECTION.INSERT, 'INSERT'); {$ENDIF}
+ RegisterPropertyHelper(@TCOLLECTIONCOUNT_R,nil,'COUNT');
+{$IFDEF DELPHI3UP} RegisterPropertyHelper(@TCOLLECTIONITEMCLASS_R,nil,'ITEMCLASS'); {$ENDIF}
+ RegisterPropertyHelper(@TCOLLECTIONITEMS_R,@TCOLLECTIONITEMS_W,'ITEMS');
+ end;
+end;
+
+procedure RIRegisterTCOLLECTIONITEM(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TCOLLECTIONITEM) do
+ begin
+ RegisterVirtualConstructor(@TCOLLECTIONITEM.CREATE, 'CREATE');
+ RegisterPropertyHelper(@TCOLLECTIONITEMCOLLECTION_R,@TCOLLECTIONITEMCOLLECTION_W,'COLLECTION');
+{$IFDEF DELPHI3UP} RegisterPropertyHelper(@TCOLLECTIONITEMID_R,nil,'ID'); {$ENDIF}
+ RegisterPropertyHelper(@TCOLLECTIONITEMINDEX_R,@TCOLLECTIONITEMINDEX_W,'INDEX');
+{$IFDEF DELPHI3UP} RegisterPropertyHelper(@TCOLLECTIONITEMDISPLAYNAME_R,@TCOLLECTIONITEMDISPLAYNAME_W,'DISPLAYNAME'); {$ENDIF}
+ end;
+end;
+{$ENDIF}
+
+procedure RIRegister_Classes(Cl: TPSRuntimeClassImporter; Streams: Boolean);
+begin
+ if Streams then
+ RIRegisterTSTREAM(Cl);
+ RIRegisterTStrings(cl, Streams);
+ RIRegisterTStringList(cl);
+ {$IFNDEF PS_MINIVCL}
+ RIRegisterTBITS(cl);
+ {$ENDIF}
+ if Streams then
+ begin
+ RIRegisterTHANDLESTREAM(Cl);
+ RIRegisterTFILESTREAM(Cl);
+ {$IFNDEF PS_MINIVCL}
+ RIRegisterTCUSTOMMEMORYSTREAM(Cl);
+ RIRegisterTMEMORYSTREAM(Cl);
+ RIRegisterTRESOURCESTREAM(Cl);
+ {$ENDIF}
+ end;
+ {$IFNDEF PS_MINIVCL}
+ RIRegisterTPARSER(Cl);
+ RIRegisterTCOLLECTIONITEM(Cl);
+ RIRegisterTCOLLECTION(Cl);
+ {$IFDEF DELPHI3UP}
+ RIRegisterTOWNEDCOLLECTION(Cl);
+ {$ENDIF}
+ {$ENDIF}
+end;
+
+// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl)
+
+end.
diff --git a/Units/PascalScript/uPSR_comobj.pas b/Units/PascalScript/uPSR_comobj.pas
new file mode 100644
index 0000000..67ec7df
--- /dev/null
+++ b/Units/PascalScript/uPSR_comobj.pas
@@ -0,0 +1,96 @@
+
+
+unit uPSR_comobj;
+
+{$I PascalScript.inc}
+interface
+uses
+ uPSRuntime, uPSUtils;
+
+
+procedure RIRegister_ComObj(cl: TPSExec);
+
+implementation
+uses
+{$IFDEF DELPHI3UP}
+ ComObj;
+{$ELSE}
+ SysUtils, Ole2;
+{$ENDIF}
+{$IFNDEF DELPHI3UP}
+
+{$IFDEF DELPHI3UP }
+resourceString
+{$ELSE }
+const
+{$ENDIF }
+
+ RPS_OLEError = 'OLE error %.8x';
+function OleErrorMessage(ErrorCode: HResult): String;
+begin
+ Result := SysErrorMessage(ErrorCode);
+ if Result = '' then
+ Result := Format(RPS_OLEError, [ErrorCode]);
+end;
+
+procedure OleError(ErrorCode: HResult);
+begin
+ raise Exception.Create(OleErrorMessage(ErrorCode));
+end;
+
+procedure OleCheck(Result: HResult);
+begin
+ if Result < 0 then OleError(Result);
+end;
+
+procedure CreateOleObject(const ClassName: string; var Disp: IDispatch);
+var
+ OldDisp: IDispatch;
+ ClassID: TCLSID;
+ WideCharBuf: array[0..127] of WideChar;
+begin
+ StringToWideChar(ClassName, WideCharBuf, SizeOf(WideCharBuf) div SizeOf(WideCharBuf[0]));
+ OleCheck(CLSIDFromProgID(WideCharBuf, ClassID));
+ if Disp <> nil then
+ begin
+ OldDisp := Disp;
+ Disp := nil;
+ OldDisp.Release;
+ end;
+ OleCheck(CoCreateInstance(ClassID, nil, CLSCTX_INPROC_SERVER or
+ CLSCTX_LOCAL_SERVER, IID_IDispatch, Disp));
+end;
+
+procedure GetActiveOleObject(const ClassName: string; var Disp: IDispatch);
+var
+ Unknown: IUnknown;
+ OldDisp: IDispatch;
+ ClassID: TCLSID;
+ WideCharBuf: array[0..127] of WideChar;
+begin
+ StringToWideChar(ClassName, WideCharBuf, SizeOf(WideCharBuf) div SizeOf(WideCharBuf[0]));
+ OleCheck(CLSIDFromProgID(WideCharBuf, ClassID));
+ OleCheck(GetActiveObject(ClassID, nil, Unknown));
+ try
+ if Disp <> nil then
+ begin
+ OldDisp := Disp;
+ Disp := nil;
+ OldDisp.Release;
+ end;
+ OleCheck(Unknown.QueryInterface(IID_IDispatch, Disp));
+ finally
+ Unknown.Release;
+ end;
+end;
+
+{$ENDIF}
+
+
+procedure RIRegister_ComObj(cl: TPSExec);
+begin
+ cl.RegisterDelphiFunction(@CreateOleObject, 'CREATEOLEOBJECT', cdRegister);
+ cl.RegisterDelphiFunction(@GetActiveOleObject, 'GETACTIVEOLEOBJECT', cdRegister);
+end;
+
+end.
diff --git a/Units/PascalScript/uPSR_controls.pas b/Units/PascalScript/uPSR_controls.pas
new file mode 100644
index 0000000..4bac801
--- /dev/null
+++ b/Units/PascalScript/uPSR_controls.pas
@@ -0,0 +1,249 @@
+
+unit uPSR_controls;
+
+{$I PascalScript.inc}
+interface
+uses
+ uPSRuntime, uPSUtils;
+
+
+
+
+procedure RIRegisterTControl(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTWinControl(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTGraphicControl(cl: TPSRuntimeClassImporter);
+procedure RIRegisterTCustomControl(cl: TPSRuntimeClassImporter);
+procedure RIRegister_TDragObject(CL: TPSRuntimeClassImporter);
+
+procedure RIRegister_Controls(Cl: TPSRuntimeClassImporter);
+
+implementation
+{$IFNDEF FPC}
+uses
+ Classes{$IFDEF CLX}, QControls, QGraphics{$ELSE}, Controls, Graphics, Windows{$ENDIF};
+{$ELSE}
+uses
+ Classes, Controls, Graphics;
+{$ENDIF}
+
+procedure TControlAlignR(Self: TControl; var T: Byte); begin T := Byte(Self.Align); end;
+procedure TControlAlignW(Self: TControl; T: Byte); begin Self.Align:= TAlign(T); end;
+
+procedure TControlClientHeightR(Self: TControl; var T: Longint); begin T := Self.ClientHeight; end;
+procedure TControlClientHeightW(Self: TControl; T: Longint); begin Self.ClientHeight := T; end;
+
+procedure TControlClientWidthR(Self: TControl; var T: Longint); begin T := Self.ClientWidth; end;
+procedure TControlClientWidthW(Self: TControl; T: Longint); begin Self.ClientWidth:= T; end;
+
+procedure TControlShowHintR(Self: TControl; var T: Boolean); begin T := Self.ShowHint; end;
+procedure TControlShowHintW(Self: TControl; T: Boolean); begin Self.ShowHint:= T; end;
+
+procedure TControlVisibleR(Self: TControl; var T: Boolean); begin T := Self.Visible; end;
+procedure TControlVisibleW(Self: TControl; T: Boolean); begin Self.Visible:= T; end;
+
+procedure TControlParentR(Self: TControl; var T: TWinControl); begin T := Self.Parent; end;
+procedure TControlParentW(Self: TControl; T: TWinControl); begin Self.Parent:= T; end;
+
+
+procedure TCONTROLSHOWHINT_W(Self: TCONTROL; T: BOOLEAN); begin Self.SHOWHINT := T; end;
+procedure TCONTROLSHOWHINT_R(Self: TCONTROL; var T: BOOLEAN); begin T := Self.SHOWHINT; end;
+procedure TCONTROLENABLED_W(Self: TCONTROL; T: BOOLEAN); begin Self.ENABLED := T; end;
+procedure TCONTROLENABLED_R(Self: TCONTROL; var T: BOOLEAN); begin T := Self.ENABLED; end;
+
+procedure RIRegisterTControl(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TControl) do
+ begin
+ RegisterVirtualConstructor(@TControl.Create, 'CREATE');
+ RegisterMethod(@TControl.BRingToFront, 'BRINGTOFRONT');
+ RegisterMethod(@TControl.Hide, 'HIDE');
+ RegisterVirtualMethod(@TControl.Invalidate, 'INVALIDATE');
+ RegisterMethod(@TControl.Refresh, 'REFRESH');
+ RegisterVirtualMethod(@TControl.Repaint, 'REPAINT');
+ RegisterMethod(@TControl.SendToBack, 'SENDTOBACK');
+ RegisterMethod(@TControl.Show, 'SHOW');
+ RegisterVirtualMethod(@TControl.Update, 'UPDATE');
+ RegisterVirtualMethod(@TControl.SetBounds, 'SETBOUNDS');
+
+ RegisterPropertyHelper(@TControlShowHintR, @TControlShowHintW, 'SHOWHINT');
+ RegisterPropertyHelper(@TControlAlignR, @TControlAlignW, 'ALIGN');
+ RegisterPropertyHelper(@TControlClientHeightR, @TControlClientHeightW, 'CLIENTHEIGHT');
+ RegisterPropertyHelper(@TControlClientWidthR, @TControlClientWidthW, 'CLIENTWIDTH');
+ RegisterPropertyHelper(@TControlVisibleR, @TControlVisibleW, 'VISIBLE');
+ RegisterPropertyHelper(@TCONTROLENABLED_R, @TCONTROLENABLED_W, 'ENABLED');
+
+ RegisterPropertyHelper(@TControlParentR, @TControlParentW, 'PARENT');
+
+ {$IFNDEF PS_MINIVCL}
+ RegisterMethod(@TControl.Dragging, 'DRAGGING');
+ RegisterMethod(@TControl.HasParent, 'HASPARENT');
+ RegisterMethod(@TCONTROL.CLIENTTOSCREEN, 'CLIENTTOSCREEN');
+ RegisterMethod(@TCONTROL.DRAGGING, 'DRAGGING');
+ {$IFNDEF FPC}
+ RegisterMethod(@TCONTROL.BEGINDRAG, 'BEGINDRAG');
+ RegisterMethod(@TCONTROL.ENDDRAG, 'ENDDRAG');
+ {$ENDIF}
+ {$IFNDEF CLX}
+ RegisterMethod(@TCONTROL.GETTEXTBUF, 'GETTEXTBUF');
+ RegisterMethod(@TCONTROL.GETTEXTLEN, 'GETTEXTLEN');
+ RegisterMethod(@TCONTROL.PERFORM, 'PERFORM');
+ RegisterMethod(@TCONTROL.SETTEXTBUF, 'SETTEXTBUF');
+ {$ENDIF}
+ RegisterMethod(@TCONTROL.SCREENTOCLIENT, 'SCREENTOCLIENT');
+ {$ENDIF}
+ end;
+end;
+{$IFNDEF CLX}
+procedure TWinControlHandleR(Self: TWinControl; var T: Longint); begin T := Self.Handle; end;
+{$ENDIF}
+procedure TWinControlShowingR(Self: TWinControl; var T: Boolean); begin T := Self.Showing; end;
+
+
+procedure TWinControlTabOrderR(Self: TWinControl; var T: Longint); begin T := Self.TabOrder; end;
+procedure TWinControlTabOrderW(Self: TWinControl; T: Longint); begin Self.TabOrder:= T; end;
+
+procedure TWinControlTabStopR(Self: TWinControl; var T: Boolean); begin T := Self.TabStop; end;
+procedure TWinControlTabStopW(Self: TWinControl; T: Boolean); begin Self.TabStop:= T; end;
+procedure TWINCONTROLBRUSH_R(Self: TWINCONTROL; var T: TBRUSH); begin T := Self.BRUSH; end;
+procedure TWINCONTROLCONTROLS_R(Self: TWINCONTROL; var T: TCONTROL; t1: INTEGER); begin t := Self.CONTROLS[t1]; end;
+procedure TWINCONTROLCONTROLCOUNT_R(Self: TWINCONTROL; var T: INTEGER); begin t := Self.CONTROLCOUNT; end;
+
+procedure RIRegisterTWinControl(Cl: TPSRuntimeClassImporter); // requires TControl
+begin
+ with Cl.Add(TWinControl) do
+ begin
+ {$IFNDEF CLX}
+ RegisterPropertyHelper(@TWinControlHandleR, nil, 'HANDLE');
+ {$ENDIF}
+ RegisterPropertyHelper(@TWinControlShowingR, nil, 'SHOWING');
+ RegisterPropertyHelper(@TWinControlTabOrderR, @TWinControlTabOrderW, 'TABORDER');
+ RegisterPropertyHelper(@TWinControlTabStopR, @TWinControlTabStopW, 'TABSTOP');
+ RegisterMethod(@TWINCONTROL.CANFOCUS, 'CANFOCUS');
+ RegisterMethod(@TWINCONTROL.FOCUSED, 'FOCUSED');
+ RegisterPropertyHelper(@TWINCONTROLCONTROLS_R, nil, 'CONTROLS');
+ RegisterPropertyHelper(@TWINCONTROLCONTROLCOUNT_R, nil, 'CONTROLCOUNT');
+ {$IFNDEF PS_MINIVCL}
+ RegisterMethod(@TWinControl.HandleAllocated, 'HANDLEALLOCATED');
+ RegisterMethod(@TWinControl.HandleNeeded, 'HANDLENEEDED');
+ RegisterMethod(@TWinControl.EnableAlign, 'ENABLEALIGN');
+ RegisterMethod(@TWinControl.RemoveControl, 'REMOVECONTROL');
+ {$IFNDEF FPC}
+ RegisterMethod(@TWinControl.InsertControl, 'INSERTCONTROL');
+ RegisterMethod(@TWinControl.ScaleBy, 'SCALEBY');
+ RegisterMethod(@TWinControl.ScrollBy, 'SCROLLBY');
+ {$IFNDEF CLX}
+ RegisterMethod(@TWINCONTROL.PAINTTO, 'PAINTTO');
+ {$ENDIF}
+ {$ENDIF}{FPC}
+ RegisterMethod(@TWinControl.Realign, 'REALIGN');
+ RegisterVirtualMethod(@TWinControl.SetFocus, 'SETFOCUS');
+ RegisterMethod(@TWINCONTROL.CONTAINSCONTROL, 'CONTAINSCONTROL');
+ RegisterMethod(@TWINCONTROL.DISABLEALIGN, 'DISABLEALIGN');
+ RegisterMethod(@TWINCONTROL.UPDATECONTROLSTATE, 'UPDATECONTROLSTATE');
+ RegisterPropertyHelper(@TWINCONTROLBRUSH_R, nil, 'BRUSH');
+ {$ENDIF}
+ end;
+end;
+
+procedure RIRegisterTGraphicControl(cl: TPSRuntimeClassImporter); // requires TControl
+begin
+ Cl.Add(TGraphicControl);
+end;
+procedure RIRegisterTCustomControl(cl: TPSRuntimeClassImporter); // requires TControl
+begin
+ Cl.Add(TCustomControl);
+end;
+
+{$IFDEF DELPHI4UP}
+(* === run-time registration functions === *)
+(*----------------------------------------------------------------------------*)
+procedure TDragObjectMouseDeltaY_R(Self: TDragObject; var T: Double);
+begin T := Self.MouseDeltaY; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TDragObjectMouseDeltaX_R(Self: TDragObject; var T: Double);
+begin T := Self.MouseDeltaX; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TDragObjectDragTarget_W(Self: TDragObject; const T: Pointer);
+begin Self.DragTarget := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TDragObjectDragTarget_R(Self: TDragObject; var T: Pointer);
+begin T := Self.DragTarget; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TDragObjectDragTargetPos_W(Self: TDragObject; const T: TPoint);
+begin Self.DragTargetPos := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TDragObjectDragTargetPos_R(Self: TDragObject; var T: TPoint);
+begin T := Self.DragTargetPos; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TDragObjectDragPos_W(Self: TDragObject; const T: TPoint);
+begin Self.DragPos := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TDragObjectDragPos_R(Self: TDragObject; var T: TPoint);
+begin T := Self.DragPos; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TDragObjectDragHandle_W(Self: TDragObject; const T: HWND);
+begin Self.DragHandle := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TDragObjectDragHandle_R(Self: TDragObject; var T: HWND);
+begin T := Self.DragHandle; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TDragObjectCancelling_W(Self: TDragObject; const T: Boolean);
+begin Self.Cancelling := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TDragObjectCancelling_R(Self: TDragObject; var T: Boolean);
+begin T := Self.Cancelling; end;
+{$ENDIF}
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TDragObject(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TDragObject) do
+ begin
+{$IFNDEF PS_MINIVCL}
+{$IFDEF DELPHI4UP}
+ RegisterVirtualMethod(@TDragObject.Assign, 'Assign');
+{$ENDIF}
+{$IFNDEF FPC}
+ RegisterVirtualMethod(@TDragObject.GetName, 'GetName');
+ RegisterVirtualMethod(@TDragObject.Instance, 'Instance');
+{$ENDIF}
+ RegisterVirtualMethod(@TDragObject.HideDragImage, 'HideDragImage');
+ RegisterVirtualMethod(@TDragObject.ShowDragImage, 'ShowDragImage');
+{$IFDEF DELPHI4UP}
+ RegisterPropertyHelper(@TDragObjectCancelling_R,@TDragObjectCancelling_W,'Cancelling');
+ RegisterPropertyHelper(@TDragObjectDragHandle_R,@TDragObjectDragHandle_W,'DragHandle');
+ RegisterPropertyHelper(@TDragObjectDragPos_R,@TDragObjectDragPos_W,'DragPos');
+ RegisterPropertyHelper(@TDragObjectDragTargetPos_R,@TDragObjectDragTargetPos_W,'DragTargetPos');
+ RegisterPropertyHelper(@TDragObjectDragTarget_R,@TDragObjectDragTarget_W,'DragTarget');
+ RegisterPropertyHelper(@TDragObjectMouseDeltaX_R,nil,'MouseDeltaX');
+ RegisterPropertyHelper(@TDragObjectMouseDeltaY_R,nil,'MouseDeltaY');
+{$ENDIF}
+{$ENDIF}
+ end;
+end;
+
+
+procedure RIRegister_Controls(Cl: TPSRuntimeClassImporter);
+begin
+ RIRegisterTControl(Cl);
+ RIRegisterTWinControl(Cl);
+ RIRegisterTGraphicControl(cl);
+ RIRegisterTCustomControl(cl);
+ RIRegister_TDragObject(cl);
+
+end;
+
+// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl)
+
+
+end.
diff --git a/Units/PascalScript/uPSR_dateutils.pas b/Units/PascalScript/uPSR_dateutils.pas
new file mode 100644
index 0000000..9c0fd5b
--- /dev/null
+++ b/Units/PascalScript/uPSR_dateutils.pas
@@ -0,0 +1,63 @@
+
+unit uPSR_dateutils;
+{$I PascalScript.inc}
+interface
+uses
+ SysUtils, uPSRuntime;
+
+
+
+procedure RegisterDateTimeLibrary_R(S: TPSExec);
+
+implementation
+
+function TryEncodeDate(Year, Month, Day: Word; var Date: TDateTime): Boolean;
+begin
+ try
+ Date := EncodeDate(Year, Month, Day);
+ Result := true;
+ except
+ Result := false;
+ end;
+end;
+
+function TryEncodeTime(Hour, Min, Sec, MSec: Word; var Time: TDateTime): Boolean;
+begin
+ try
+ Time := EncodeTime(hour, Min, Sec, MSec);
+ Result := true;
+ except
+ Result := false;
+ end;
+end;
+
+function DateTimeToUnix(D: TDateTime): Int64;
+begin
+ Result := Round((D - 25569) * 86400);
+end;
+
+function UnixToDateTime(U: Int64): TDateTime;
+begin
+ Result := U / 86400 + 25569;
+end;
+
+procedure RegisterDateTimeLibrary_R(S: TPSExec);
+begin
+ S.RegisterDelphiFunction(@EncodeDate, 'ENCODEDATE', cdRegister);
+ S.RegisterDelphiFunction(@EncodeTime, 'ENCODETIME', cdRegister);
+ S.RegisterDelphiFunction(@TryEncodeDate, 'TRYENCODEDATE', cdRegister);
+ S.RegisterDelphiFunction(@TryEncodeTime, 'TRYENCODETIME', cdRegister);
+ S.RegisterDelphiFunction(@DecodeDate, 'DECODEDATE', cdRegister);
+ S.RegisterDelphiFunction(@DecodeTime, 'DECODETIME', cdRegister);
+ S.RegisterDelphiFunction(@DayOfWeek, 'DAYOFWEEK', cdRegister);
+ S.RegisterDelphiFunction(@Date, 'DATE', cdRegister);
+ S.RegisterDelphiFunction(@Time, 'TIME', cdRegister);
+ S.RegisterDelphiFunction(@Now, 'NOW', cdRegister);
+ S.RegisterDelphiFunction(@DateTimeToUnix, 'DATETIMETOUNIX', cdRegister);
+ S.RegisterDelphiFunction(@UnixToDateTime, 'UNIXTODATETIME', cdRegister);
+ S.RegisterDelphiFunction(@DateToStr, 'DATETOSTR', cdRegister);
+ S.RegisterDelphiFunction(@FormatDateTime, 'FORMATDATETIME', cdRegister);
+ S.RegisterDelphiFunction(@StrToDate, 'STRTODATE', cdRegister);
+end;
+
+end.
diff --git a/Units/PascalScript/uPSR_dll.pas b/Units/PascalScript/uPSR_dll.pas
new file mode 100644
index 0000000..94ff209
--- /dev/null
+++ b/Units/PascalScript/uPSR_dll.pas
@@ -0,0 +1,312 @@
+
+unit uPSR_dll;
+
+{$I PascalScript.inc}
+interface
+uses
+ uPSRuntime, uPSUtils;
+
+procedure RegisterDLLRuntime(Caller: TPSExec);
+procedure RegisterDLLRuntimeEx(Caller: TPSExec; AddDllProcImport: Boolean);
+
+function ProcessDllImport(Caller: TPSExec; P: TPSExternalProcRec): Boolean;
+function ProcessDllImportEx(Caller: TPSExec; P: TPSExternalProcRec; ForceDelayLoad: Boolean): Boolean;
+function UnloadProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
+
+implementation
+uses
+ {$IFDEF UNIX}
+ {$IFDEF Darwin}
+ LCLIntf, Unix, baseunix, dynlibs, termio, sockets;
+ {$ELSE}
+ LibC{$IFNDEF FPC}, Windows{$ENDIF};
+ {$ENDIF}
+ {$ELSE}
+ Windows;
+ {$ENDIF}
+
+{
+p^.Ext1 contains the pointer to the Proc function
+p^.ExportDecl:
+ 'dll:'+DllName+#0+FunctionName+#0+chr(Cc)+Chr(DelayLoad)+Chr(AlternateSearchPath)+VarParams
+}
+
+type
+ PLoadedDll = ^TLoadedDll;
+ TLoadedDll = record
+ dllnamehash: Longint;
+ dllname: tbtstring;
+ {$IFDEF LINUX}
+ dllhandle: Pointer;
+ {$ELSE}
+ dllhandle: THandle;
+ {$ENDIF}
+ end;
+ TMyExec = class(TPSExec);
+ PInteger = ^Integer;
+
+procedure LAstErrorFree(Sender: TPSExec; P: PInteger);
+begin
+ dispose(p);
+end;
+
+procedure DLLSetLastError(Sender: TPSExec; P: Integer);
+var
+ pz: PInteger;
+begin
+ pz := Sender.FindProcResource(@LastErrorFree);
+ if pz = nil then
+ begin
+ new(pz);
+ Sender.AddResource(@LastErrorFree, PZ);
+ end;
+ pz^ := p;
+end;
+
+function DLLGetLastError(Sender: TPSExec): Integer;
+var
+ pz: PInteger;
+begin
+ pz := Sender.FindProcResource(@LastErrorFree);
+ if pz = nil then
+ result := 0
+ else
+ result := pz^;
+end;
+
+
+procedure DllFree(Sender: TPSExec; P: PLoadedDll);
+begin
+ {$IFDEF LINUX}
+ dlclose(p^.dllhandle);
+ {$ELSE}
+ FreeLibrary(p^.dllhandle);
+ {$ENDIF}
+ Dispose(p);
+end;
+
+function LoadDll(Caller: TPSExec; P: TPSExternalProcRec): Boolean;
+var
+ s, s2, s3: tbtstring;
+ h, i: Longint;
+ ph: PLoadedDll;
+ {$IFDEF LINUX}
+ dllhandle: Pointer;
+ {$ELSE}
+ dllhandle: THandle;
+ {$ENDIF}
+ loadwithalteredsearchpath: Boolean;
+begin
+ s := p.Decl;
+ Delete(s, 1, 4);
+ s2 := copy(s, 1, pos(tbtchar(#0), s)-1);
+ delete(s, 1, length(s2)+1);
+ h := makehash(s2);
+ s3 := copy(s, 1, pos(tbtchar(#0), s)-1);
+ delete(s, 1, length(s3)+1);
+ loadwithalteredsearchpath := bytebool(s[3]);
+ i := 2147483647; // maxint
+ dllhandle := 0;
+ repeat
+ ph := Caller.FindProcResource2(@dllFree, i);
+ if (ph = nil) then
+ begin
+ if s2 = '' then
+ begin
+ // don't pass an empty filename to LoadLibrary, just treat it as uncallable
+ p.Ext2 := Pointer(1);
+ Result := False;
+ exit;
+ end;
+ {$IFDEF UNIX}
+ {$IFDEF DARWIN}
+ dllhandle := LoadLibrary(PChar(s2));
+ {$ELSE}
+ dllhandle := dlopen(PChar(s2), RTLD_LAZY);
+ {$ENDIF}
+ {$ELSE}
+ if loadwithalteredsearchpath then
+ dllhandle := LoadLibraryExA(PAnsiChar(AnsiString(s2)), 0, LOAD_WITH_ALTERED_SEARCH_PATH)
+ else
+ dllhandle := LoadLibraryA(PAnsiChar(AnsiString(s2)));
+ {$ENDIF}
+ if dllhandle = {$IFDEF LINUX}nil{$ELSE}0{$ENDIF}then
+ begin
+ p.Ext2 := Pointer(1);
+ Result := False;
+ exit;
+ end;
+ new(ph);
+ ph^.dllnamehash := h;
+ ph^.dllname := s2;
+ ph^.dllhandle := dllhandle;
+ Caller.AddResource(@DllFree, ph);
+ end;
+ if (ph^.dllnamehash = h) and (ph^.dllname = s2) then
+ begin
+ dllhandle := ph^.dllhandle;
+ end;
+ until dllhandle <> {$IFDEF LINUX}nil{$ELSE}0{$ENDIF};
+ {$IFDEF LINUX}
+ p.Ext1 := dlsym(dllhandle, pchar(s3));
+ {$ELSE}
+ p.Ext1 := GetProcAddress(dllhandle, pansichar(s3));
+ {$ENDIF}
+ if p.Ext1 = nil then
+ begin
+ p.Ext2 := Pointer(1);
+ Result := false;
+ exit;
+ end;
+ Result := True;
+end;
+
+
+function DllProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
+
+var
+ i: Longint;
+ MyList: TIfList;
+ n: PPSVariantIFC;
+ CurrStack: Cardinal;
+ cc: TPSCallingConvention;
+ s: tbtstring;
+begin
+ if p.Ext2 <> nil then // error
+ begin
+ Result := false;
+ exit;
+ end;
+ if p.Ext1 = nil then
+ begin
+ if not LoadDll(Caller, P) then
+ begin
+ Result := false;
+ exit;
+ end;
+ end;
+ s := p.Decl;
+ delete(S, 1, pos(tbtchar(#0), s));
+ delete(S, 1, pos(tbtchar(#0), s));
+ if length(S) < 2 then
+ begin
+ Result := False;
+ exit;
+ end;
+ cc := TPSCallingConvention(s[1]);
+ delete(s, 1, 3); // cc + delayload + alternatesearchpath (delayload might also be forced!)
+ CurrStack := Cardinal(Stack.Count) - Cardinal(length(s));
+ if s[1] = #0 then inc(CurrStack);
+ MyList := tIfList.Create;
+ for i := 2 to length(s) do
+ begin
+ MyList.Add(nil);
+ end;
+ for i := length(s) downto 2 do
+ begin
+ MyList[i - 2] := NewPPSVariantIFC(Stack[CurrStack], s[i] <> #0);
+ inc(CurrStack);
+ end;
+ if s[1] <> #0 then
+ begin
+ n := NewPPSVariantIFC(Stack[CurrStack], true);
+ end else n := nil;
+ try
+ TMYExec(Caller).InnerfuseCall(nil, p.Ext1, cc, MyList, n);
+ {$IFNDEF LINUX}
+ DLLSetLastError(Caller, GetLastError);
+ {$ENDIF}
+ finally
+ DisposePPSvariantIFC(n);
+ DisposePPSVariantIFCList(MyList);
+ end;
+ result := true;
+end;
+
+function ProcessDllImport(Caller: TPSExec; P: TPSExternalProcRec): Boolean;
+begin
+ Result := ProcessDllImportEx(Caller, P, False);
+end;
+
+function ProcessDllImportEx(Caller: TPSExec; P: TPSExternalProcRec; ForceDelayLoad: Boolean): Boolean;
+var
+ DelayLoad: Boolean;
+ s: tbtstring;
+begin
+ if not ForceDelayLoad then begin
+ s := p.Decl;
+ Delete(s,1,pos(tbtchar(#0), s));
+ Delete(s,1,pos(tbtchar(#0), s));
+ DelayLoad := bytebool(s[2]);
+ end else
+ DelayLoad := True;
+
+ if DelayLoad then begin
+ p.ProcPtr := DllProc;
+ Result := True;
+ end else begin
+ p.ProcPtr := DllProc;
+ Result := LoadDll(Caller, p);
+ end;
+end;
+
+
+function GetLastErrorProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
+begin
+ Stack.SetInt(-1, DLLGetLastError(Caller));
+ Result := true;
+end;
+
+function UnloadProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
+var
+ h, i: Longint;
+ pv: TPSProcRec;
+ ph: PLoadedDll;
+ sname, s: tbtstring;
+begin
+ sname := Stack.GetAnsiString(-1);
+ for i := Caller.GetProcCount -1 downto 0 do
+ begin
+ pv := Caller.GetProcNo(i);
+ if not (pv is TPSExternalProcRec) then continue;
+ if @TPSExternalProcRec(pv).ProcPtr <> @DllProc then continue;
+ s := (TPSExternalProcRec(pv).Decl);
+ delete(s,1,4);
+ if copy(s,1,pos(tbtchar(#0),s)-1) = sname then
+ begin
+ TPSExternalProcRec(pv).Ext1 := nil;
+ end;
+ end;
+ h := MakeHash(sname);
+ i := 2147483647; // maxint
+ repeat
+ ph := Caller.FindProcResource2(@dllFree, i);
+ if (ph = nil) then break;
+ if (ph.dllnamehash = h) and (ph.dllname = sname) then
+ begin
+ {$IFDEF LINUX}
+ dlclose(ph^.dllhandle);
+ {$ELSE}
+ FreeLibrary(ph^.dllhandle);
+ {$ENDIF}
+ Caller.DeleteResource(ph);
+ dispose(ph);
+ end;
+ until false;
+ result := true;
+end;
+
+procedure RegisterDLLRuntime(Caller: TPSExec);
+begin
+ RegisterDLLRuntimeEx(Caller, True);
+end;
+
+procedure RegisterDLLRuntimeEx(Caller: TPSExec; AddDllProcImport: Boolean);
+begin
+ if AddDllProcImport then
+ Caller.AddSpecialProcImport('dll', @ProcessDllImport, nil);
+ Caller.RegisterFunctionName('UNLOADDLL', UnloadProc, nil, nil);
+ Caller.RegisterFunctionName('DLLGETLASTERROR', GetLastErrorProc, nil, nil);
+end;
+
+end.
diff --git a/Units/PascalScript/uPSR_extctrls.pas b/Units/PascalScript/uPSR_extctrls.pas
new file mode 100644
index 0000000..0f4a129
--- /dev/null
+++ b/Units/PascalScript/uPSR_extctrls.pas
@@ -0,0 +1,150 @@
+
+unit uPSR_extctrls;
+
+{$I PascalScript.inc}
+interface
+uses
+ uPSRuntime, uPSUtils;
+
+
+procedure RIRegister_ExtCtrls(cl: TPSRuntimeClassImporter);
+
+procedure RIRegisterTSHAPE(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTIMAGE(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTPAINTBOX(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTBEVEL(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTTIMER(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTCUSTOMPANEL(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTPANEL(Cl: TPSRuntimeClassImporter);
+{$IFNDEF CLX}
+procedure RIRegisterTPAGE(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTNOTEBOOK(Cl: TPSRuntimeClassImporter);
+{$IFNDEF FPC}procedure RIRegisterTHEADER(Cl: TPSRuntimeClassImporter);{$ENDIF}
+{$ENDIF}
+procedure RIRegisterTCUSTOMRADIOGROUP(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTRADIOGROUP(Cl: TPSRuntimeClassImporter);
+
+implementation
+
+uses
+ {$IFDEF CLX}
+ QExtCtrls, QGraphics;
+ {$ELSE}
+ ExtCtrls, Graphics;
+ {$ENDIF}
+
+procedure RIRegisterTSHAPE(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TSHAPE) do
+ begin
+ {$IFNDEF PS_MINIVCL}
+ RegisterMethod(@TSHAPE.STYLECHANGED, 'STYLECHANGED');
+ {$ENDIF}
+ end;
+end;
+
+procedure TIMAGECANVAS_R(Self: TIMAGE; var T: TCANVAS); begin T := Self.CANVAS; end;
+
+procedure RIRegisterTIMAGE(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TIMAGE) do
+ begin
+ RegisterPropertyHelper(@TIMAGECANVAS_R, nil, 'CANVAS');
+ end;
+end;
+
+procedure TPAINTBOXCANVAS_R(Self: TPAINTBOX; var T: TCanvas); begin T := Self.CANVAS; end;
+
+procedure RIRegisterTPAINTBOX(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TPAINTBOX) do
+ begin
+ RegisterPropertyHelper(@TPAINTBOXCANVAS_R, nil, 'CANVAS');
+ end;
+end;
+
+procedure RIRegisterTBEVEL(Cl: TPSRuntimeClassImporter);
+begin
+ Cl.Add(TBEVEL);
+end;
+
+procedure RIRegisterTTIMER(Cl: TPSRuntimeClassImporter);
+begin
+ Cl.Add(TTIMER);
+end;
+
+procedure RIRegisterTCUSTOMPANEL(Cl: TPSRuntimeClassImporter);
+begin
+ Cl.Add(TCUSTOMPANEL);
+end;
+
+procedure RIRegisterTPANEL(Cl: TPSRuntimeClassImporter);
+begin
+ Cl.Add(TPANEL);
+end;
+{$IFNDEF CLX}
+procedure RIRegisterTPAGE(Cl: TPSRuntimeClassImporter);
+begin
+ Cl.Add(TPAGE);
+end;
+
+procedure RIRegisterTNOTEBOOK(Cl: TPSRuntimeClassImporter);
+begin
+ Cl.Add(TNOTEBOOK);
+end;
+
+{$IFNDEF FPC}
+procedure THEADERSECTIONWIDTH_R(Self: THEADER; var T: INTEGER; t1: INTEGER); begin T := Self.SECTIONWIDTH[t1]; end;
+procedure THEADERSECTIONWIDTH_W(Self: THEADER; T: INTEGER; t1: INTEGER); begin Self.SECTIONWIDTH[t1] := T; end;
+
+procedure RIRegisterTHEADER(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(THEADER) do
+ begin
+ RegisterPropertyHelper(@THEADERSECTIONWIDTH_R, @THEADERSECTIONWIDTH_W, 'SECTIONWIDTH');
+ end;
+end;
+{$ENDIF}
+{$ENDIF}
+
+procedure RIRegisterTCUSTOMRADIOGROUP(Cl: TPSRuntimeClassImporter);
+begin
+ Cl.Add(TCUSTOMRADIOGROUP);
+end;
+
+procedure RIRegisterTRADIOGROUP(Cl: TPSRuntimeClassImporter);
+begin
+ Cl.Add(TRADIOGROUP);
+end;
+
+procedure RIRegister_ExtCtrls(cl: TPSRuntimeClassImporter);
+begin
+ {$IFNDEF PS_MINIVCL}
+ RIRegisterTSHAPE(Cl);
+ RIRegisterTIMAGE(Cl);
+ RIRegisterTPAINTBOX(Cl);
+ {$ENDIF}
+ RIRegisterTBEVEL(Cl);
+ {$IFNDEF PS_MINIVCL}
+ RIRegisterTTIMER(Cl);
+ {$ENDIF}
+ RIRegisterTCUSTOMPANEL(Cl);
+{$IFNDEF CLX}
+ RIRegisterTPANEL(Cl);
+{$ENDIF}
+ {$IFNDEF PS_MINIVCL}
+{$IFNDEF CLX}
+ RIRegisterTPAGE(Cl);
+ RIRegisterTNOTEBOOK(Cl);
+ {$IFNDEF FPC}
+ RIRegisterTHEADER(Cl);
+ {$ENDIF}{FPC}
+{$ENDIF}
+ RIRegisterTCUSTOMRADIOGROUP(Cl);
+ RIRegisterTRADIOGROUP(Cl);
+ {$ENDIF}
+end;
+
+end.
+
+
diff --git a/Units/PascalScript/uPSR_forms.pas b/Units/PascalScript/uPSR_forms.pas
new file mode 100644
index 0000000..4a0f8f7
--- /dev/null
+++ b/Units/PascalScript/uPSR_forms.pas
@@ -0,0 +1,264 @@
+
+unit uPSR_forms;
+
+{$I PascalScript.inc}
+interface
+uses
+ uPSRuntime, uPSUtils;
+
+procedure RIRegisterTCONTROLSCROLLBAR(Cl: TPSRuntimeClassImporter);
+{$IFNDEF FPC} procedure RIRegisterTSCROLLINGWINCONTROL(Cl: TPSRuntimeClassImporter);{$ENDIF}
+procedure RIRegisterTSCROLLBOX(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTFORM(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTAPPLICATION(Cl: TPSRuntimeClassImporter);
+
+procedure RIRegister_Forms(Cl: TPSRuntimeClassImporter);
+
+implementation
+uses
+ sysutils, classes, {$IFDEF CLX}QControls, QForms, QGraphics{$ELSE}Controls, Forms, Graphics{$ENDIF};
+
+procedure TCONTROLSCROLLBARKIND_R(Self: TCONTROLSCROLLBAR; var T: TSCROLLBARKIND); begin T := Self.KIND; end;
+procedure TCONTROLSCROLLBARSCROLLPOS_R(Self: TCONTROLSCROLLBAR; var T: INTEGER); begin t := Self.SCROLLPOS; end;
+
+procedure RIRegisterTCONTROLSCROLLBAR(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TCONTROLSCROLLBAR) do
+ begin
+ RegisterPropertyHelper(@TCONTROLSCROLLBARKIND_R, nil, 'KIND');
+ RegisterPropertyHelper(@TCONTROLSCROLLBARSCROLLPOS_R, nil, 'SCROLLPOS');
+ end;
+end;
+
+{$IFNDEF FPC}
+procedure RIRegisterTSCROLLINGWINCONTROL(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TSCROLLINGWINCONTROL) do
+ begin
+ RegisterMethod(@TSCROLLINGWINCONTROL.SCROLLINVIEW, 'SCROLLINVIEW');
+ end;
+end;
+{$ENDIF}
+
+procedure RIRegisterTSCROLLBOX(Cl: TPSRuntimeClassImporter);
+begin
+ Cl.Add(TSCROLLBOX);
+end;
+{$IFNDEF FPC}
+{$IFNDEF CLX}
+procedure TFORMACTIVEOLECONTROL_W(Self: TFORM; T: TWINCONTROL); begin Self.ACTIVEOLECONTROL := T; end;
+procedure TFORMACTIVEOLECONTROL_R(Self: TFORM; var T: TWINCONTROL); begin T := Self.ACTIVEOLECONTROL;
+end;
+procedure TFORMTILEMODE_W(Self: TFORM; T: TTILEMODE); begin Self.TILEMODE := T; end;
+procedure TFORMTILEMODE_R(Self: TFORM; var T: TTILEMODE); begin T := Self.TILEMODE; end;
+{$ENDIF}{CLX}
+procedure TFORMACTIVEMDICHILD_R(Self: TFORM; var T: TFORM); begin T := Self.ACTIVEMDICHILD; end;
+procedure TFORMDROPTARGET_W(Self: TFORM; T: BOOLEAN); begin Self.DROPTARGET := T; end;
+procedure TFORMDROPTARGET_R(Self: TFORM; var T: BOOLEAN); begin T := Self.DROPTARGET; end;
+procedure TFORMMDICHILDCOUNT_R(Self: TFORM; var T: INTEGER); begin T := Self.MDICHILDCOUNT; end;
+procedure TFORMMDICHILDREN_R(Self: TFORM; var T: TFORM; t1: INTEGER); begin T := Self.MDICHILDREN[T1];
+end;
+{$ENDIF}{FPC}
+
+procedure TFORMMODALRESULT_W(Self: TFORM; T: TMODALRESULT); begin Self.MODALRESULT := T; end;
+procedure TFORMMODALRESULT_R(Self: TFORM; var T: TMODALRESULT); begin T := Self.MODALRESULT; end;
+procedure TFORMACTIVE_R(Self: TFORM; var T: BOOLEAN); begin T := Self.ACTIVE; end;
+procedure TFORMCANVAS_R(Self: TFORM; var T: TCANVAS); begin T := Self.CANVAS; end;
+{$IFNDEF CLX}
+procedure TFORMCLIENTHANDLE_R(Self: TFORM; var T: Longint); begin T := Self.CLIENTHANDLE; end;
+{$ENDIF}
+
+{ Innerfuse Pascal Script Class Import Utility (runtime) }
+
+procedure RIRegisterTFORM(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TFORM) do
+ begin
+ {$IFDEF DELPHI4UP}
+ RegisterVirtualConstructor(@TFORM.CREATENEW, 'CREATENEW');
+ {$ELSE}
+ RegisterConstructor(@TFORM.CREATENEW, 'CREATENEW');
+ {$ENDIF}
+ RegisterMethod(@TFORM.CLOSE, 'CLOSE');
+ RegisterMethod(@TFORM.HIDE, 'HIDE');
+ RegisterMethod(@TFORM.SHOW, 'SHOW');
+ RegisterMethod(@TFORM.SHOWMODAL, 'SHOWMODAL');
+ RegisterMethod(@TFORM.RELEASE, 'RELEASE');
+ RegisterPropertyHelper(@TFORMACTIVE_R, nil, 'ACTIVE');
+
+ {$IFNDEF PS_MINIVCL}
+ {$IFNDEF FPC}
+{$IFNDEF CLX}
+ RegisterMethod(@TFORM.ARRANGEICONS, 'ARRANGEICONS');
+ RegisterMethod(@TFORM.GETFORMIMAGE, 'GETFORMIMAGE');
+ RegisterMethod(@TFORM.PRINT, 'PRINT');
+ RegisterMethod(@TFORM.SENDCANCELMODE, 'SENDCANCELMODE');
+ RegisterPropertyHelper(@TFORMACTIVEOLECONTROL_R, @TFORMACTIVEOLECONTROL_W, 'ACTIVEOLECONTROL');
+ RegisterPropertyHelper(@TFORMCLIENTHANDLE_R, nil, 'CLIENTHANDLE');
+ RegisterPropertyHelper(@TFORMTILEMODE_R, @TFORMTILEMODE_W, 'TILEMODE');
+{$ENDIF}{CLX}
+ RegisterMethod(@TFORM.CASCADE, 'CASCADE');
+ RegisterMethod(@TFORM.NEXT, 'NEXT');
+ RegisterMethod(@TFORM.PREVIOUS, 'PREVIOUS');
+ RegisterMethod(@TFORM.TILE, 'TILE');
+ RegisterPropertyHelper(@TFORMACTIVEMDICHILD_R, nil, 'ACTIVEMDICHILD');
+ RegisterPropertyHelper(@TFORMDROPTARGET_R, @TFORMDROPTARGET_W, 'DROPTARGET');
+ RegisterPropertyHelper(@TFORMMDICHILDCOUNT_R, nil, 'MDICHILDCOUNT');
+ RegisterPropertyHelper(@TFORMMDICHILDREN_R, nil, 'MDICHILDREN');
+ {$ENDIF}{FPC}
+ RegisterMethod(@TFORM.CLOSEQUERY, 'CLOSEQUERY');
+ RegisterMethod(@TFORM.DEFOCUSCONTROL, 'DEFOCUSCONTROL');
+ RegisterMethod(@TFORM.FOCUSCONTROL, 'FOCUSCONTROL');
+ RegisterMethod(@TFORM.SETFOCUSEDCONTROL, 'SETFOCUSEDCONTROL');
+ RegisterPropertyHelper(@TFORMCANVAS_R, nil, 'CANVAS');
+ RegisterPropertyHelper(@TFORMMODALRESULT_R, @TFORMMODALRESULT_W, 'MODALRESULT');
+ {$ENDIF}{PS_MINIVCL}
+ end;
+end;
+
+ {$IFNDEF FPC}
+procedure TAPPLICATIONACTIVE_R(Self: TAPPLICATION; var T: BOOLEAN); begin T := Self.ACTIVE; end;
+{$IFNDEF CLX}
+procedure TAPPLICATIONDIALOGHANDLE_R(Self: TAPPLICATION; var T: Longint); begin T := Self.DIALOGHANDLE; end;
+procedure TAPPLICATIONDIALOGHANDLE_W(Self: TAPPLICATION; T: Longint); begin Self.DIALOGHANDLE := T; end;
+procedure TAPPLICATIONHANDLE_R(Self: TAPPLICATION; var T: Longint); begin T := Self.HANDLE; end;
+procedure TAPPLICATIONHANDLE_W(Self: TAPPLICATION; T: Longint); begin Self.HANDLE := T; end;
+procedure TAPPLICATIONUPDATEFORMATSETTINGS_R(Self: TAPPLICATION; var T: BOOLEAN); begin T := Self.UPDATEFORMATSETTINGS; end;
+procedure TAPPLICATIONUPDATEFORMATSETTINGS_W(Self: TAPPLICATION; T: BOOLEAN); begin Self.UPDATEFORMATSETTINGS := T; end;
+{$ENDIF}
+{$ENDIF}{FPC}
+
+
+procedure TAPPLICATIONEXENAME_R(Self: TAPPLICATION; var T: STRING); begin T := Self.EXENAME; end;
+procedure TAPPLICATIONHELPFILE_R(Self: TAPPLICATION; var T: STRING); begin T := Self.HELPFILE; end;
+procedure TAPPLICATIONHELPFILE_W(Self: TAPPLICATION; T: STRING); begin Self.HELPFILE := T; end;
+procedure TAPPLICATIONHINT_R(Self: TAPPLICATION; var T: STRING); begin T := Self.HINT; end;
+procedure TAPPLICATIONHINT_W(Self: TAPPLICATION; T: STRING); begin Self.HINT := T; end;
+procedure TAPPLICATIONHINTCOLOR_R(Self: TAPPLICATION; var T: TCOLOR); begin T := Self.HINTCOLOR; end;
+procedure TAPPLICATIONHINTCOLOR_W(Self: TAPPLICATION; T: TCOLOR); begin Self.HINTCOLOR := T; end;
+procedure TAPPLICATIONHINTPAUSE_R(Self: TAPPLICATION; var T: INTEGER); begin T := Self.HINTPAUSE; end;
+procedure TAPPLICATIONHINTPAUSE_W(Self: TAPPLICATION; T: INTEGER); begin Self.HINTPAUSE := T; end;
+procedure TAPPLICATIONHINTSHORTPAUSE_R(Self: TAPPLICATION; var T: INTEGER); begin T := Self.HINTSHORTPAUSE; end;
+procedure TAPPLICATIONHINTSHORTPAUSE_W(Self: TAPPLICATION; T: INTEGER); begin Self.HINTSHORTPAUSE := T; end;
+procedure TAPPLICATIONHINTHIDEPAUSE_R(Self: TAPPLICATION; var T: INTEGER); begin T := Self.HINTHIDEPAUSE; end;
+procedure TAPPLICATIONHINTHIDEPAUSE_W(Self: TAPPLICATION; T: INTEGER); begin Self.HINTHIDEPAUSE := T; end;
+procedure TAPPLICATIONMAINFORM_R(Self: TAPPLICATION; var T: {$IFDEF DELPHI3UP}TCustomForm{$ELSE}TFORM{$ENDIF}); begin T := Self.MAINFORM; end;
+procedure TAPPLICATIONSHOWHINT_R(Self: TAPPLICATION; var T: BOOLEAN); begin T := Self.SHOWHINT; end;
+procedure TAPPLICATIONSHOWHINT_W(Self: TAPPLICATION; T: BOOLEAN); begin Self.SHOWHINT := T; end;
+procedure TAPPLICATIONSHOWMAINFORM_R(Self: TAPPLICATION; var T: BOOLEAN); begin T := Self.SHOWMAINFORM; end;
+procedure TAPPLICATIONSHOWMAINFORM_W(Self: TAPPLICATION; T: BOOLEAN); begin Self.SHOWMAINFORM := T; end;
+procedure TAPPLICATIONTERMINATED_R(Self: TAPPLICATION; var T: BOOLEAN); begin T := Self.TERMINATED; end;
+procedure TAPPLICATIONTITLE_R(Self: TAPPLICATION; var T: STRING); begin T := Self.TITLE; end;
+procedure TAPPLICATIONTITLE_W(Self: TAPPLICATION; T: STRING); begin Self.TITLE := T; end;
+
+{$IFNDEF FPC}
+procedure TAPPLICATIONONACTIVATE_R(Self: TAPPLICATION; var T: TNOTIFYEVENT); begin T := Self.ONACTIVATE; end;
+procedure TAPPLICATIONONACTIVATE_W(Self: TAPPLICATION; T: TNOTIFYEVENT); begin Self.ONACTIVATE := T; end;
+procedure TAPPLICATIONONDEACTIVATE_R(Self: TAPPLICATION; var T: TNOTIFYEVENT); begin T := Self.ONDEACTIVATE; end;
+procedure TAPPLICATIONONDEACTIVATE_W(Self: TAPPLICATION; T: TNOTIFYEVENT); begin Self.ONDEACTIVATE := T; end;
+{$ENDIF}
+
+procedure TAPPLICATIONONIDLE_R(Self: TAPPLICATION; var T: TIDLEEVENT); begin T := Self.ONIDLE; end;
+procedure TAPPLICATIONONIDLE_W(Self: TAPPLICATION; T: TIDLEEVENT); begin Self.ONIDLE := T; end;
+procedure TAPPLICATIONONHELP_R(Self: TAPPLICATION; var T: THELPEVENT); begin T := Self.ONHELP; end;
+procedure TAPPLICATIONONHELP_W(Self: TAPPLICATION; T: THELPEVENT); begin Self.ONHELP := T; end;
+procedure TAPPLICATIONONHINT_R(Self: TAPPLICATION; var T: TNOTIFYEVENT); begin T := Self.ONHINT; end;
+procedure TAPPLICATIONONHINT_W(Self: TAPPLICATION; T: TNOTIFYEVENT); begin Self.ONHINT := T; end;
+
+{$IFNDEF FPC}
+procedure TAPPLICATIONONMINIMIZE_R(Self: TAPPLICATION; var T: TNOTIFYEVENT); begin T := Self.ONMINIMIZE; end;
+procedure TAPPLICATIONONMINIMIZE_W(Self: TAPPLICATION; T: TNOTIFYEVENT); begin Self.ONMINIMIZE := T; end;
+
+procedure TAPPLICATIONONRESTORE_R(Self: TAPPLICATION; var T: TNOTIFYEVENT); begin T := Self.ONRESTORE; end;
+procedure TAPPLICATIONONRESTORE_W(Self: TAPPLICATION; T: TNOTIFYEVENT); begin Self.ONRESTORE := T; end;
+{$ENDIF}
+
+procedure RIRegisterTAPPLICATION(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TAPPLICATION) do
+ begin
+ {$IFNDEF FPC}
+ RegisterMethod(@TAPPLICATION.MINIMIZE, 'MINIMIZE');
+ RegisterMethod(@TAPPLICATION.RESTORE, 'RESTORE');
+ RegisterPropertyHelper(@TAPPLICATIONACTIVE_R, nil, 'ACTIVE');
+ RegisterPropertyHelper(@TAPPLICATIONONACTIVATE_R, @TAPPLICATIONONACTIVATE_W, 'ONACTIVATE');
+ RegisterPropertyHelper(@TAPPLICATIONONDEACTIVATE_R, @TAPPLICATIONONDEACTIVATE_W, 'ONDEACTIVATE');
+ RegisterPropertyHelper(@TAPPLICATIONONMINIMIZE_R, @TAPPLICATIONONMINIMIZE_W, 'ONMINIMIZE');
+ RegisterPropertyHelper(@TAPPLICATIONONRESTORE_R, @TAPPLICATIONONRESTORE_W, 'ONRESTORE');
+ RegisterPropertyHelper(@TAPPLICATIONDIALOGHANDLE_R, @TAPPLICATIONDIALOGHANDLE_W, 'DIALOGHANDLE');
+ RegisterMethod(@TAPPLICATION.CREATEHANDLE, 'CREATEHANDLE');
+ RegisterMethod(@TAPPLICATION.NORMALIZETOPMOSTS, 'NORMALIZETOPMOSTS');
+ RegisterMethod(@TAPPLICATION.RESTORETOPMOSTS, 'RESTORETOPMOSTS');
+ {$IFNDEF CLX}
+ RegisterPropertyHelper(@TAPPLICATIONHANDLE_R, @TAPPLICATIONHANDLE_W, 'HANDLE');
+ RegisterPropertyHelper(@TAPPLICATIONUPDATEFORMATSETTINGS_R, @TAPPLICATIONUPDATEFORMATSETTINGS_W, 'UPDATEFORMATSETTINGS');
+ {$ENDIF}
+ {$ENDIF}
+ RegisterMethod(@TAPPLICATION.BRINGTOFRONT, 'BRINGTOFRONT');
+ RegisterMethod(@TAPPLICATION.MESSAGEBOX, 'MESSAGEBOX');
+ RegisterMethod(@TAPPLICATION.PROCESSMESSAGES, 'PROCESSMESSAGES');
+ RegisterMethod(@TAPPLICATION.TERMINATE, 'TERMINATE');
+ RegisterPropertyHelper(@TAPPLICATIONEXENAME_R, nil, 'EXENAME');
+ RegisterPropertyHelper(@TAPPLICATIONHINT_R, @TAPPLICATIONHINT_W, 'HINT');
+ RegisterPropertyHelper(@TAPPLICATIONMAINFORM_R, nil, 'MAINFORM');
+ RegisterPropertyHelper(@TAPPLICATIONSHOWHINT_R, @TAPPLICATIONSHOWHINT_W, 'SHOWHINT');
+ RegisterPropertyHelper(@TAPPLICATIONSHOWMAINFORM_R, @TAPPLICATIONSHOWMAINFORM_W, 'SHOWMAINFORM');
+ RegisterPropertyHelper(@TAPPLICATIONTERMINATED_R, nil, 'TERMINATED');
+ RegisterPropertyHelper(@TAPPLICATIONTITLE_R, @TAPPLICATIONTITLE_W, 'TITLE');
+ RegisterPropertyHelper(@TAPPLICATIONONIDLE_R, @TAPPLICATIONONIDLE_W, 'ONIDLE');
+ RegisterPropertyHelper(@TAPPLICATIONONHINT_R, @TAPPLICATIONONHINT_W, 'ONHINT');
+ {$IFNDEF PS_MINIVCL}
+ RegisterMethod(@TAPPLICATION.CONTROLDESTROYED, 'CONTROLDESTROYED');
+ RegisterMethod(@TAPPLICATION.CANCELHINT, 'CANCELHINT');
+ {$IFNDEF CLX}
+ {$IFNDEF FPC}
+ RegisterMethod(@TAPPLICATION.HELPCOMMAND, 'HELPCOMMAND');
+ {$ENDIF}
+ RegisterMethod(@TAPPLICATION.HELPCONTEXT, 'HELPCONTEXT');
+ {$IFNDEF FPC}
+ RegisterMethod(@TAPPLICATION.HELPJUMP, 'HELPJUMP');
+ {$ENDIF}
+ {$ENDIF}
+// RegisterMethod(@TAPPLICATION.HANDLEEXCEPTION, 'HANDLEEXCEPTION');
+// RegisterMethod(@TAPPLICATION.HOOKMAINWINDOW, 'HOOKMAINWINDOW');
+// RegisterMethod(@TAPPLICATION.UNHOOKMAINWINDOW, 'UNHOOKMAINWINDOW');
+
+ RegisterMethod(@TAPPLICATION.HANDLEMESSAGE, 'HANDLEMESSAGE');
+ RegisterMethod(@TAPPLICATION.HIDEHINT, 'HIDEHINT');
+ RegisterMethod(@TAPPLICATION.HINTMOUSEMESSAGE, 'HINTMOUSEMESSAGE');
+ RegisterMethod(@TAPPLICATION.INITIALIZE, 'INITIALIZE');
+ RegisterMethod(@TAPPLICATION.RUN, 'RUN');
+// RegisterMethod(@TAPPLICATION.SHOWEXCEPTION, 'SHOWEXCEPTION');
+ RegisterPropertyHelper(@TAPPLICATIONHELPFILE_R, @TAPPLICATIONHELPFILE_W, 'HELPFILE');
+ RegisterPropertyHelper(@TAPPLICATIONHINTCOLOR_R, @TAPPLICATIONHINTCOLOR_W, 'HINTCOLOR');
+ RegisterPropertyHelper(@TAPPLICATIONHINTPAUSE_R, @TAPPLICATIONHINTPAUSE_W, 'HINTPAUSE');
+ RegisterPropertyHelper(@TAPPLICATIONHINTSHORTPAUSE_R, @TAPPLICATIONHINTSHORTPAUSE_W, 'HINTSHORTPAUSE');
+ RegisterPropertyHelper(@TAPPLICATIONHINTHIDEPAUSE_R, @TAPPLICATIONHINTHIDEPAUSE_W, 'HINTHIDEPAUSE');
+ RegisterPropertyHelper(@TAPPLICATIONONHELP_R, @TAPPLICATIONONHELP_W, 'ONHELP');
+ {$ENDIF}
+ end;
+end;
+
+procedure RIRegister_Forms(Cl: TPSRuntimeClassImporter);
+begin
+ {$IFNDEF PS_MINIVCL}
+ RIRegisterTCONTROLSCROLLBAR(cl);
+ RIRegisterTSCROLLBOX(cl);
+ {$ENDIF}
+{$IFNDEF FPC} RIRegisterTScrollingWinControl(cl);{$ENDIF}
+ RIRegisterTForm(Cl);
+ {$IFNDEF PS_MINIVCL}
+ RIRegisterTApplication(Cl);
+ {$ENDIF}
+end;
+
+
+// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl)
+// FPC changes by Boguslaw brandys (brandys at o2 _dot_ pl)
+
+end.
+
+
+
+
+
diff --git a/Units/PascalScript/uPSR_graphics.pas b/Units/PascalScript/uPSR_graphics.pas
new file mode 100644
index 0000000..7a7643a
--- /dev/null
+++ b/Units/PascalScript/uPSR_graphics.pas
@@ -0,0 +1,218 @@
+
+unit uPSR_graphics;
+{$I PascalScript.inc}
+interface
+uses
+ uPSRuntime, uPSUtils;
+
+
+
+procedure RIRegisterTGRAPHICSOBJECT(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTFont(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTPEN(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTBRUSH(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTCanvas(cl: TPSRuntimeClassImporter);
+procedure RIRegisterTGraphic(CL: TPSRuntimeClassImporter);
+procedure RIRegisterTBitmap(CL: TPSRuntimeClassImporter; Streams: Boolean);
+
+procedure RIRegister_Graphics(Cl: TPSRuntimeClassImporter; Streams: Boolean);
+
+implementation
+{$IFNDEF FPC}
+uses
+ Classes{$IFDEF CLX}, QGraphics{$ELSE}, Windows, Graphics{$ENDIF};
+{$ELSE}
+uses
+ Classes, Graphics,LCLType;
+{$ENDIF}
+
+{$IFNDEF CLX}
+procedure TFontHandleR(Self: TFont; var T: Longint); begin T := Self.Handle; end;
+procedure TFontHandleW(Self: TFont; T: Longint); begin Self.Handle := T; end;
+{$ENDIF}
+procedure TFontPixelsPerInchR(Self: TFont; var T: Longint); begin T := Self.PixelsPerInch; end;
+procedure TFontPixelsPerInchW(Self: TFont; T: Longint); begin {$IFNDEF FPC} Self.PixelsPerInch := T;{$ENDIF} end;
+procedure TFontStyleR(Self: TFont; var T: TFontStyles); begin T := Self.Style; end;
+procedure TFontStyleW(Self: TFont; T: TFontStyles); begin Self.Style:= T; end;
+
+procedure RIRegisterTFont(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TFont) do
+ begin
+ RegisterConstructor(@TFont.Create, 'CREATE');
+{$IFNDEF CLX}
+ RegisterPropertyHelper(@TFontHandleR, @TFontHandleW, 'HANDLE');
+{$ENDIF}
+ RegisterPropertyHelper(@TFontPixelsPerInchR, @TFontPixelsPerInchW, 'PIXELSPERINCH');
+ RegisterPropertyHelper(@TFontStyleR, @TFontStyleW, 'STYLE');
+ end;
+end;
+{$IFNDEF CLX}
+procedure TCanvasHandleR(Self: TCanvas; var T: Longint); begin T := Self.Handle; end;
+procedure TCanvasHandleW(Self: TCanvas; T: Longint); begin Self.Handle:= T; end;
+{$ENDIF}
+
+procedure TCanvasPixelsR(Self: TCanvas; var T: Longint; X,Y: Longint); begin T := Self.Pixels[X,Y]; end;
+procedure TCanvasPixelsW(Self: TCanvas; T, X, Y: Longint); begin Self.Pixels[X,Y]:= T; end;
+
+procedure RIRegisterTCanvas(cl: TPSRuntimeClassImporter); // requires TPersistent
+begin
+ with Cl.Add(TCanvas) do
+ begin
+{$IFNDEF FPC}
+ RegisterMethod(@TCanvas.Arc, 'ARC');
+ RegisterMethod(@TCanvas.Chord, 'CHORD');
+ RegisterMethod(@TCanvas.Rectangle, 'RECTANGLE');
+ RegisterMethod(@TCanvas.RoundRect, 'ROUNDRECT');
+ RegisterMethod(@TCanvas.Ellipse, 'ELLIPSE');
+ RegisterMethod(@TCanvas.FillRect, 'FILLRECT');
+{$ENDIF}
+ RegisterMethod(@TCanvas.Draw, 'DRAW');
+{$IFNDEF CLX}
+ RegisterMethod(@TCanvas.FloodFill, 'FLOODFILL');
+{$ENDIF}
+ RegisterMethod(@TCanvas.Lineto, 'LINETO');
+ RegisterMethod(@TCanvas.Moveto, 'MOVETO');
+ RegisterMethod(@TCanvas.Pie, 'PIE');
+ RegisterMethod(@TCanvas.Refresh, 'REFRESH');
+ RegisterMethod(@TCanvas.TextHeight, 'TEXTHEIGHT');
+ RegisterMethod(@TCanvas.TextOut, 'TEXTOUT');
+ RegisterMethod(@TCanvas.TextWidth, 'TEXTWIDTH');
+{$IFNDEF CLX}
+ RegisterPropertyHelper(@TCanvasHandleR, @TCanvasHandleW, 'HANDLE');
+{$ENDIF}
+ RegisterPropertyHelper(@TCanvasPixelsR, @TCanvasPixelsW, 'PIXELS');
+ end;
+end;
+
+
+procedure TGRAPHICSOBJECTONCHANGE_W(Self: TGraphicsObject; T: TNotifyEvent); begin Self.OnChange := t; end;
+procedure TGRAPHICSOBJECTONCHANGE_R(Self: TGraphicsObject; var T: TNotifyEvent); begin T :=Self.OnChange; end;
+
+
+procedure RIRegisterTGRAPHICSOBJECT(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TGRAPHICSOBJECT) do
+ begin
+ RegisterPropertyHelper(@TGRAPHICSOBJECTONCHANGE_R, @TGRAPHICSOBJECTONCHANGE_W, 'ONCHANGE');
+ end;
+end;
+
+procedure RIRegisterTPEN(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TPEN) do
+ begin
+ RegisterConstructor(@TPEN.CREATE, 'CREATE');
+ end;
+end;
+
+procedure RIRegisterTBRUSH(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TBRUSH) do
+ begin
+ RegisterConstructor(@TBRUSH.CREATE, 'CREATE');
+ end;
+end;
+
+procedure TGraphicOnChange_W(Self: TGraphic; const T: TNotifyEvent); begin Self.OnChange := T; end;
+procedure TGraphicOnChange_R(Self: TGraphic; var T: TNotifyEvent); begin T := Self.OnChange; end;
+procedure TGraphicWidth_W(Self: TGraphic; const T: Integer); begin Self.Width := T; end;
+procedure TGraphicWidth_R(Self: TGraphic; var T: Integer); begin T := Self.Width; end;
+procedure TGraphicModified_W(Self: TGraphic; const T: Boolean); begin Self.Modified := T; end;
+procedure TGraphicModified_R(Self: TGraphic; var T: Boolean); begin T := Self.Modified; end;
+procedure TGraphicHeight_W(Self: TGraphic; const T: Integer); begin Self.Height := T; end;
+procedure TGraphicHeight_R(Self: TGraphic; var T: Integer); begin T := Self.Height; end;
+procedure TGraphicEmpty_R(Self: TGraphic; var T: Boolean); begin T := Self.Empty; end;
+
+procedure RIRegisterTGraphic(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TGraphic) do
+ begin
+ RegisterVirtualConstructor(@TGraphic.Create, 'Create');
+ RegisterVirtualMethod(@TGraphic.LoadFromFile, 'LoadFromFile');
+ RegisterVirtualMethod(@TGraphic.SaveToFile, 'SaveToFile');
+ RegisterPropertyHelper(@TGraphicEmpty_R,nil,'Empty');
+ RegisterPropertyHelper(@TGraphicHeight_R,@TGraphicHeight_W,'Height');
+ RegisterPropertyHelper(@TGraphicWidth_R,@TGraphicWidth_W,'Width');
+ RegisterPropertyHelper(@TGraphicOnChange_R,@TGraphicOnChange_W,'OnChange');
+
+ {$IFNDEF PS_MINIVCL}
+ RegisterPropertyHelper(@TGraphicModified_R,@TGraphicModified_W,'Modified');
+ {$ENDIF}
+ end;
+end;
+
+procedure TBitmapTransparentColor_R(Self: TBitmap; var T: TColor); begin T := Self.TransparentColor; end;
+{$IFNDEF CLX}
+{$IFNDEF FPC}
+procedure TBitmapIgnorePalette_W(Self: TBitmap; const T: Boolean); begin Self.IgnorePalette := T; end;
+procedure TBitmapIgnorePalette_R(Self: TBitmap; var T: Boolean); begin T := Self.IgnorePalette; end;
+{$ENDIF}
+procedure TBitmapPalette_W(Self: TBitmap; const T: HPALETTE); begin Self.Palette := T; end;
+procedure TBitmapPalette_R(Self: TBitmap; var T: HPALETTE); begin T := Self.Palette; end;
+{$ENDIF}
+procedure TBitmapMonochrome_W(Self: TBitmap; const T: Boolean); begin Self.Monochrome := T; end;
+procedure TBitmapMonochrome_R(Self: TBitmap; var T: Boolean); begin T := Self.Monochrome; end;
+{$IFNDEF CLX}
+procedure TBitmapHandle_W(Self: TBitmap; const T: HBITMAP); begin Self.Handle := T; end;
+procedure TBitmapHandle_R(Self: TBitmap; var T: HBITMAP); begin T := Self.Handle; end;
+{$ENDIF}
+procedure TBitmapCanvas_R(Self: TBitmap; var T: TCanvas); begin T := Self.Canvas; end;
+
+procedure RIRegisterTBitmap(CL: TPSRuntimeClassImporter; Streams: Boolean);
+begin
+ with CL.Add(TBitmap) do
+ begin
+ if Streams then begin
+ RegisterMethod(@TBitmap.LoadFromStream, 'LoadFromStream');
+ RegisterMethod(@TBitmap.SaveToStream, 'SaveToStream');
+ end;
+ RegisterPropertyHelper(@TBitmapCanvas_R,nil,'Canvas');
+{$IFNDEF CLX}
+ RegisterPropertyHelper(@TBitmapHandle_R,@TBitmapHandle_W,'Handle');
+{$ENDIF}
+
+ {$IFNDEF PS_MINIVCL}
+{$IFNDEF FPC}
+ RegisterMethod(@TBitmap.Dormant, 'Dormant');
+{$ENDIF}
+ RegisterMethod(@TBitmap.FreeImage, 'FreeImage');
+{$IFNDEF CLX}
+ RegisterMethod(@TBitmap.LoadFromClipboardFormat, 'LoadFromClipboardFormat');
+{$ENDIF}
+ RegisterMethod(@TBitmap.LoadFromResourceName, 'LoadFromResourceName');
+ RegisterMethod(@TBitmap.LoadFromResourceID, 'LoadFromResourceID');
+{$IFNDEF CLX}
+ RegisterMethod(@TBitmap.ReleaseHandle, 'ReleaseHandle');
+ RegisterMethod(@TBitmap.ReleasePalette, 'ReleasePalette');
+ RegisterMethod(@TBitmap.SaveToClipboardFormat, 'SaveToClipboardFormat');
+ RegisterPropertyHelper(@TBitmapMonochrome_R,@TBitmapMonochrome_W,'Monochrome');
+ RegisterPropertyHelper(@TBitmapPalette_R,@TBitmapPalette_W,'Palette');
+{$IFNDEF FPC}
+ RegisterPropertyHelper(@TBitmapIgnorePalette_R,@TBitmapIgnorePalette_W,'IgnorePalette');
+{$ENDIF}
+{$ENDIF}
+ RegisterPropertyHelper(@TBitmapTransparentColor_R,nil,'TransparentColor');
+ {$ENDIF}
+ end;
+end;
+
+procedure RIRegister_Graphics(Cl: TPSRuntimeClassImporter; Streams: Boolean);
+begin
+ RIRegisterTGRAPHICSOBJECT(cl);
+ RIRegisterTFont(Cl);
+ RIRegisterTCanvas(cl);
+ RIRegisterTPEN(cl);
+ RIRegisterTBRUSH(cl);
+ RIRegisterTGraphic(CL);
+ RIRegisterTBitmap(CL, Streams);
+end;
+
+// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl)
+
+end.
+
+
+
+
+
diff --git a/Units/PascalScript/uPSR_menus.pas b/Units/PascalScript/uPSR_menus.pas
new file mode 100644
index 0000000..a4b4206
--- /dev/null
+++ b/Units/PascalScript/uPSR_menus.pas
@@ -0,0 +1,460 @@
+
+Unit uPSR_menus;
+{$I PascalScript.inc}
+Interface
+Uses uPSRuntime;
+
+procedure RIRegister_Menus_Routines(S: TPSExec);
+{$IFNDEF FPC}
+procedure RIRegisterTMENUITEMSTACK(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTPOPUPLIST(Cl: TPSRuntimeClassImporter);
+{$ENDIF}
+procedure RIRegisterTPOPUPMENU(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTMAINMENU(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTMENU(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTMENUITEM(Cl: TPSRuntimeClassImporter);
+procedure RIRegister_Menus(CL: TPSRuntimeClassImporter);
+
+implementation
+{$IFDEF LINUX}
+{$IFNDEF FPC}
+Uses
+ Libc, SysUtils, Classes, QControls, QMenus, QGraphics;
+{$ELSE}
+Uses
+ Libc, SysUtils, Classes, Controls, Menus, Graphics, LCLType, ImgList;
+{$ENDIF}
+{$ELSE}
+Uses {$IFNDEF FPC}WINDOWS,{$ELSE} LCLType,{$ENDIF} SYSUTILS, CLASSES, CONTNRS, MESSAGES, GRAPHICS, IMGLIST, ACTNLIST, Menus;
+{$ENDIF}
+
+
+{$IFNDEF FPC}
+procedure TPOPUPLISTWINDOW_R(Self: TPOPUPLIST; var T: HWND);
+begin T := Self.WINDOW; end;
+{$ENDIF}
+
+procedure TPOPUPMENUONPOPUP_W(Self: TPOPUPMENU; const T: TNOTIFYEVENT);
+begin Self.ONPOPUP := T; end;
+
+procedure TPOPUPMENUONPOPUP_R(Self: TPOPUPMENU; var T: TNOTIFYEVENT);
+begin T := Self.ONPOPUP; end;
+
+{$IFNDEF FPC}
+procedure TPOPUPMENUTRACKBUTTON_W(Self: TPOPUPMENU; const T: TTRACKBUTTON);
+begin Self.TRACKBUTTON := T; end;
+
+procedure TPOPUPMENUTRACKBUTTON_R(Self: TPOPUPMENU; var T: TTRACKBUTTON);
+begin T := Self.TRACKBUTTON; end;
+
+
+procedure TPOPUPMENUMENUANIMATION_W(Self: TPOPUPMENU; const T: TMENUANIMATION);
+begin Self.MENUANIMATION := T; end;
+
+procedure TPOPUPMENUMENUANIMATION_R(Self: TPOPUPMENU; var T: TMENUANIMATION);
+begin T := Self.MENUANIMATION; end;
+
+procedure TPOPUPMENUHELPCONTEXT_W(Self: TPOPUPMENU; const T: THELPCONTEXT);
+begin Self.HELPCONTEXT := T; end;
+
+procedure TPOPUPMENUHELPCONTEXT_R(Self: TPOPUPMENU; var T: THELPCONTEXT);
+begin T := Self.HELPCONTEXT; end;
+{$ENDIF}
+
+procedure TPOPUPMENUAUTOPOPUP_W(Self: TPOPUPMENU; const T: BOOLEAN);
+begin Self.AUTOPOPUP := T; end;
+
+procedure TPOPUPMENUAUTOPOPUP_R(Self: TPOPUPMENU; var T: BOOLEAN);
+begin T := Self.AUTOPOPUP; end;
+
+{$IFNDEF FPC}
+procedure TPOPUPMENUALIGNMENT_W(Self: TPOPUPMENU; const T: TPOPUPALIGNMENT);
+begin Self.ALIGNMENT := T; end;
+
+procedure TPOPUPMENUALIGNMENT_R(Self: TPOPUPMENU; var T: TPOPUPALIGNMENT);
+begin T := Self.ALIGNMENT; end;
+{$ENDIF}
+
+procedure TPOPUPMENUPOPUPCOMPONENT_W(Self: TPOPUPMENU; const T: TCOMPONENT);
+begin Self.POPUPCOMPONENT := T; end;
+
+procedure TPOPUPMENUPOPUPCOMPONENT_R(Self: TPOPUPMENU; var T: TCOMPONENT);
+begin T := Self.POPUPCOMPONENT; end;
+
+{$IFNDEF FPC}
+procedure TMAINMENUAUTOMERGE_W(Self: TMAINMENU; const T: BOOLEAN);
+begin Self.AUTOMERGE := T; end;
+
+procedure TMAINMENUAUTOMERGE_R(Self: TMAINMENU; var T: BOOLEAN);
+begin T := Self.AUTOMERGE; end;
+{$ENDIF}
+
+procedure TMENUITEMS_R(Self: TMENU; var T: TMENUITEM);
+begin T := Self.ITEMS; end;
+
+
+{$IFNDEF FPC}
+procedure TMENUWINDOWHANDLE_W(Self: TMENU; const T: HWND);
+begin Self.WINDOWHANDLE := T; end;
+
+procedure TMENUWINDOWHANDLE_R(Self: TMENU; var T: HWND);
+begin T := Self.WINDOWHANDLE; end;
+
+procedure TMENUPARENTBIDIMODE_W(Self: TMENU; const T: BOOLEAN);
+begin Self.PARENTBIDIMODE := T; end;
+
+procedure TMENUPARENTBIDIMODE_R(Self: TMENU; var T: BOOLEAN);
+begin T := Self.PARENTBIDIMODE; end;
+
+procedure TMENUOWNERDRAW_W(Self: TMENU; const T: BOOLEAN);
+begin Self.OWNERDRAW := T; end;
+
+procedure TMENUOWNERDRAW_R(Self: TMENU; var T: BOOLEAN);
+begin T := Self.OWNERDRAW; end;
+
+procedure TMENUBIDIMODE_W(Self: TMENU; const T: TBIDIMODE);
+begin Self.BIDIMODE := T; end;
+
+procedure TMENUBIDIMODE_R(Self: TMENU; var T: TBIDIMODE);
+begin T := Self.BIDIMODE; end;
+
+procedure TMENUAUTOLINEREDUCTION_W(Self: TMENU; const T: TMENUAUTOFLAG);
+begin Self.AUTOLINEREDUCTION := T; end;
+
+procedure TMENUAUTOLINEREDUCTION_R(Self: TMENU; var T: TMENUAUTOFLAG);
+begin T := Self.AUTOLINEREDUCTION; end;
+
+procedure TMENUAUTOHOTKEYS_W(Self: TMENU; const T: TMENUAUTOFLAG);
+begin Self.AUTOHOTKEYS := T; end;
+
+procedure TMENUAUTOHOTKEYS_R(Self: TMENU; var T: TMENUAUTOFLAG);
+begin T := Self.AUTOHOTKEYS; end;
+
+{$ENDIF}
+
+
+procedure TMENUHANDLE_R(Self: TMENU; var T: HMENU);
+begin T := Self.HANDLE; end;
+
+
+
+
+procedure TMENUIMAGES_W(Self: TMENU; const T: TCUSTOMIMAGELIST);
+begin Self.IMAGES := T; end;
+
+procedure TMENUIMAGES_R(Self: TMENU; var T: TCUSTOMIMAGELIST);
+begin T := Self.IMAGES; end;
+
+{$IFNDEF FPC}
+procedure TMENUITEMONMEASUREITEM_W(Self: TMENUITEM; const T: TMENUMEASUREITEMEVENT);
+begin Self.ONMEASUREITEM := T; end;
+
+procedure TMENUITEMONMEASUREITEM_R(Self: TMENUITEM; var T: TMENUMEASUREITEMEVENT);
+begin T := Self.ONMEASUREITEM; end;
+
+procedure TMENUITEMONADVANCEDDRAWITEM_W(Self: TMENUITEM; const T: TADVANCEDMENUDRAWITEMEVENT);
+begin Self.ONADVANCEDDRAWITEM := T; end;
+
+procedure TMENUITEMONADVANCEDDRAWITEM_R(Self: TMENUITEM; var T: TADVANCEDMENUDRAWITEMEVENT);
+begin T := Self.ONADVANCEDDRAWITEM; end;
+
+procedure TMENUITEMONDRAWITEM_W(Self: TMENUITEM; const T: TMENUDRAWITEMEVENT);
+begin Self.ONDRAWITEM := T; end;
+
+procedure TMENUITEMONDRAWITEM_R(Self: TMENUITEM; var T: TMENUDRAWITEMEVENT);
+begin T := Self.ONDRAWITEM; end;
+{$ENDIF}
+
+procedure TMENUITEMONCLICK_W(Self: TMENUITEM; const T: TNOTIFYEVENT);
+begin Self.ONCLICK := T; end;
+
+procedure TMENUITEMONCLICK_R(Self: TMENUITEM; var T: TNOTIFYEVENT);
+begin T := Self.ONCLICK; end;
+
+procedure TMENUITEMVISIBLE_W(Self: TMENUITEM; const T: BOOLEAN);
+begin Self.VISIBLE := T; end;
+
+procedure TMENUITEMVISIBLE_R(Self: TMENUITEM; var T: BOOLEAN);
+begin T := Self.VISIBLE; end;
+
+procedure TMENUITEMSHORTCUT_W(Self: TMENUITEM; const T: TSHORTCUT);
+begin Self.SHORTCUT := T; end;
+
+procedure TMENUITEMSHORTCUT_R(Self: TMENUITEM; var T: TSHORTCUT);
+begin T := Self.SHORTCUT; end;
+
+procedure TMENUITEMRADIOITEM_W(Self: TMENUITEM; const T: BOOLEAN);
+begin Self.RADIOITEM := T; end;
+
+procedure TMENUITEMRADIOITEM_R(Self: TMENUITEM; var T: BOOLEAN);
+begin T := Self.RADIOITEM; end;
+
+procedure TMENUITEMIMAGEINDEX_W(Self: TMENUITEM; const T: TIMAGEINDEX);
+begin Self.IMAGEINDEX := T; end;
+
+procedure TMENUITEMIMAGEINDEX_R(Self: TMENUITEM; var T: TIMAGEINDEX);
+begin T := Self.IMAGEINDEX; end;
+
+procedure TMENUITEMHINT_W(Self: TMENUITEM; const T: STRING);
+begin Self.HINT := T; end;
+
+procedure TMENUITEMHINT_R(Self: TMENUITEM; var T: STRING);
+begin T := Self.HINT; end;
+
+procedure TMENUITEMHELPCONTEXT_W(Self: TMENUITEM; const T: THELPCONTEXT);
+begin Self.HELPCONTEXT := T; end;
+
+procedure TMENUITEMHELPCONTEXT_R(Self: TMENUITEM; var T: THELPCONTEXT);
+begin T := Self.HELPCONTEXT; end;
+
+procedure TMENUITEMGROUPINDEX_W(Self: TMENUITEM; const T: BYTE);
+begin Self.GROUPINDEX := T; end;
+
+procedure TMENUITEMGROUPINDEX_R(Self: TMENUITEM; var T: BYTE);
+begin T := Self.GROUPINDEX; end;
+
+procedure TMENUITEMENABLED_W(Self: TMENUITEM; const T: BOOLEAN);
+begin Self.ENABLED := T; end;
+
+procedure TMENUITEMENABLED_R(Self: TMENUITEM; var T: BOOLEAN);
+begin T := Self.ENABLED; end;
+
+procedure TMENUITEMDEFAULT_W(Self: TMENUITEM; const T: BOOLEAN);
+begin Self.DEFAULT := T; end;
+
+procedure TMENUITEMDEFAULT_R(Self: TMENUITEM; var T: BOOLEAN);
+begin T := Self.DEFAULT; end;
+
+procedure TMENUITEMSUBMENUIMAGES_W(Self: TMENUITEM; const T: TCUSTOMIMAGELIST);
+begin Self.SUBMENUIMAGES := T; end;
+
+procedure TMENUITEMSUBMENUIMAGES_R(Self: TMENUITEM; var T: TCUSTOMIMAGELIST);
+begin T := Self.SUBMENUIMAGES; end;
+
+procedure TMENUITEMCHECKED_W(Self: TMENUITEM; const T: BOOLEAN);
+begin Self.CHECKED := T; end;
+
+procedure TMENUITEMCHECKED_R(Self: TMENUITEM; var T: BOOLEAN);
+begin T := Self.CHECKED; end;
+
+procedure TMENUITEMCAPTION_W(Self: TMENUITEM; const T: STRING);
+begin Self.CAPTION := T; end;
+
+procedure TMENUITEMCAPTION_R(Self: TMENUITEM; var T: STRING);
+begin T := Self.CAPTION; end;
+
+procedure TMENUITEMBITMAP_W(Self: TMENUITEM; const T: TBITMAP);
+begin Self.BITMAP := T; end;
+
+procedure TMENUITEMBITMAP_R(Self: TMENUITEM; var T: TBITMAP);
+begin T := Self.BITMAP; end;
+
+{$IFNDEF FPC}
+procedure TMENUITEMAUTOLINEREDUCTION_W(Self: TMENUITEM; const T: TMENUITEMAUTOFLAG);
+begin Self.AUTOLINEREDUCTION := T; end;
+
+procedure TMENUITEMAUTOLINEREDUCTION_R(Self: TMENUITEM; var T: TMENUITEMAUTOFLAG);
+begin T := Self.AUTOLINEREDUCTION; end;
+
+procedure TMENUITEMAUTOHOTKEYS_W(Self: TMENUITEM; const T: TMENUITEMAUTOFLAG);
+begin Self.AUTOHOTKEYS := T; end;
+
+procedure TMENUITEMAUTOHOTKEYS_R(Self: TMENUITEM; var T: TMENUITEMAUTOFLAG);
+begin T := Self.AUTOHOTKEYS; end;
+{$ENDIF}
+
+procedure TMENUITEMACTION_W(Self: TMENUITEM; const T: TBASICACTION);
+begin Self.ACTION := T; end;
+
+procedure TMENUITEMACTION_R(Self: TMENUITEM; var T: TBASICACTION);
+begin T := Self.ACTION; end;
+
+procedure TMENUITEMPARENT_R(Self: TMENUITEM; var T: TMENUITEM);
+begin T := Self.PARENT; end;
+
+procedure TMENUITEMMENUINDEX_W(Self: TMENUITEM; const T: INTEGER);
+begin Self.MENUINDEX := T; end;
+
+procedure TMENUITEMMENUINDEX_R(Self: TMENUITEM; var T: INTEGER);
+begin T := Self.MENUINDEX; end;
+
+procedure TMENUITEMITEMS_R(Self: TMENUITEM; var T: TMENUITEM; const t1: INTEGER);
+begin T := Self.ITEMS[t1]; end;
+
+procedure TMENUITEMCOUNT_R(Self: TMENUITEM; var T: INTEGER);
+begin T := Self.COUNT; end;
+
+procedure TMENUITEMHANDLE_R(Self: TMENUITEM; var T: HMENU);
+begin T := Self.HANDLE; end;
+
+procedure TMENUITEMCOMMAND_R(Self: TMENUITEM; var T: WORD);
+begin T := Self.COMMAND; end;
+
+procedure RIRegister_Menus_Routines(S: TPSExec);
+begin
+ S.RegisterDelphiFunction(@SHORTCUT, 'SHORTCUT', cdRegister);
+ S.RegisterDelphiFunction(@SHORTCUTTOKEY, 'SHORTCUTTOKEY', cdRegister);
+{$IFNDEF FPC}
+ S.RegisterDelphiFunction(@SHORTCUTTOTEXT, 'SHORTCUTTOTEXT', cdRegister);
+ S.RegisterDelphiFunction(@TEXTTOSHORTCUT, 'TEXTTOSHORTCUT', cdRegister);
+ S.RegisterDelphiFunction(@NEWMENU, 'NEWMENU', cdRegister);
+ S.RegisterDelphiFunction(@NEWPOPUPMENU, 'NEWPOPUPMENU', cdRegister);
+ S.RegisterDelphiFunction(@NEWSUBMENU, 'NEWSUBMENU', cdRegister);
+ S.RegisterDelphiFunction(@NEWITEM, 'NEWITEM', cdRegister);
+ S.RegisterDelphiFunction(@NEWLINE, 'NEWLINE', cdRegister);
+ S.RegisterDelphiFunction(@DRAWMENUITEM, 'DRAWMENUITEM', cdRegister);
+{$ENDIF}
+end;
+
+{$IFNDEF FPC}
+procedure RIRegisterTMENUITEMSTACK(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TMENUITEMSTACK) do
+ begin
+ RegisterMethod(@TMENUITEMSTACK.CLEARITEM, 'CLEARITEM');
+ end;
+end;
+
+procedure RIRegisterTPOPUPLIST(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TPOPUPLIST) do
+ begin
+ RegisterPropertyHelper(@TPOPUPLISTWINDOW_R,nil,'WINDOW');
+ RegisterMethod(@TPOPUPLIST.ADD, 'ADD');
+ RegisterMethod(@TPOPUPLIST.REMOVE, 'REMOVE');
+ end;
+end;
+{$ENDIF}
+
+
+procedure RIRegisterTPOPUPMENU(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TPOPUPMENU) do
+ begin
+ RegisterConstructor(@TPOPUPMENU.CREATE, 'CREATE');
+ RegisterVirtualMethod(@TPOPUPMENU.POPUP, 'POPUP');
+ RegisterPropertyHelper(@TPOPUPMENUPOPUPCOMPONENT_R,@TPOPUPMENUPOPUPCOMPONENT_W,'POPUPCOMPONENT');
+ RegisterEventPropertyHelper(@TPOPUPMENUONPOPUP_R,@TPOPUPMENUONPOPUP_W,'ONPOPUP');
+{$IFNDEF FPC}
+ RegisterPropertyHelper(@TPOPUPMENUALIGNMENT_R,@TPOPUPMENUALIGNMENT_W,'ALIGNMENT');
+ RegisterPropertyHelper(@TPOPUPMENUAUTOPOPUP_R,@TPOPUPMENUAUTOPOPUP_W,'AUTOPOPUP');
+ RegisterPropertyHelper(@TPOPUPMENUHELPCONTEXT_R,@TPOPUPMENUHELPCONTEXT_W,'HELPCONTEXT');
+ RegisterPropertyHelper(@TPOPUPMENUMENUANIMATION_R,@TPOPUPMENUMENUANIMATION_W,'MENUANIMATION');
+ RegisterPropertyHelper(@TPOPUPMENUTRACKBUTTON_R,@TPOPUPMENUTRACKBUTTON_W,'TRACKBUTTON');
+{$ENDIF}
+ end;
+end;
+
+procedure RIRegisterTMAINMENU(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TMAINMENU) do
+ begin
+{$IFNDEF FPC}
+ RegisterMethod(@TMAINMENU.MERGE, 'MERGE');
+ RegisterMethod(@TMAINMENU.UNMERGE, 'UNMERGE');
+ RegisterMethod(@TMAINMENU.POPULATEOLE2MENU, 'POPULATEOLE2MENU');
+ RegisterMethod(@TMAINMENU.GETOLE2ACCELERATORTABLE, 'GETOLE2ACCELERATORTABLE');
+ RegisterMethod(@TMAINMENU.SETOLE2MENUHANDLE, 'SETOLE2MENUHANDLE');
+ RegisterPropertyHelper(@TMAINMENUAUTOMERGE_R,@TMAINMENUAUTOMERGE_W,'AUTOMERGE');
+{$ENDIF}
+ end;
+end;
+
+
+procedure RIRegisterTMENU(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TMENU) do
+ begin
+ RegisterConstructor(@TMENU.CREATE, 'CREATE');
+ RegisterMethod(@TMENU.DISPATCHCOMMAND, 'DISPATCHCOMMAND');
+ RegisterMethod(@TMENU.FINDITEM, 'FINDITEM');
+ RegisterPropertyHelper(@TMENUIMAGES_R,@TMENUIMAGES_W,'IMAGES');
+ RegisterMethod(@TMENU.ISRIGHTTOLEFT, 'ISRIGHTTOLEFT');
+ RegisterPropertyHelper(@TMENUHANDLE_R,nil,'HANDLE');
+ RegisterPropertyHelper(@TMENUITEMS_R,nil,'ITEMS');
+{$IFNDEF FPC}
+ RegisterMethod(@TMENU.DISPATCHPOPUP, 'DISPATCHPOPUP');
+ RegisterMethod(@TMENU.PARENTBIDIMODECHANGED, 'PARENTBIDIMODECHANGED');
+ RegisterMethod(@TMENU.PROCESSMENUCHAR, 'PROCESSMENUCHAR');
+ RegisterPropertyHelper(@TMENUAUTOHOTKEYS_R,@TMENUAUTOHOTKEYS_W,'AUTOHOTKEYS');
+ RegisterPropertyHelper(@TMENUAUTOLINEREDUCTION_R,@TMENUAUTOLINEREDUCTION_W,'AUTOLINEREDUCTION');
+ RegisterPropertyHelper(@TMENUBIDIMODE_R,@TMENUBIDIMODE_W,'BIDIMODE');
+ RegisterMethod(@TMENU.GETHELPCONTEXT, 'GETHELPCONTEXT');
+ RegisterPropertyHelper(@TMENUOWNERDRAW_R,@TMENUOWNERDRAW_W,'OWNERDRAW');
+ RegisterPropertyHelper(@TMENUPARENTBIDIMODE_R,@TMENUPARENTBIDIMODE_W,'PARENTBIDIMODE');
+ RegisterPropertyHelper(@TMENUWINDOWHANDLE_R,@TMENUWINDOWHANDLE_W,'WINDOWHANDLE');
+{$ENDIF}
+ end;
+end;
+
+procedure RIRegisterTMENUITEM(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TMENUITEM) do
+ begin
+ RegisterConstructor(@TMENUITEM.CREATE, 'CREATE');
+ RegisterVirtualMethod(@TMENUITEM.INITIATEACTION, 'INITIATEACTION');
+ RegisterMethod(@TMENUITEM.INSERT, 'INSERT');
+ RegisterMethod(@TMENUITEM.DELETE, 'DELETE');
+ RegisterMethod(@TMENUITEM.CLEAR, 'CLEAR');
+ RegisterVirtualMethod(@TMENUITEM.CLICK, 'CLICK');
+{$IFNDEF FPC}
+ RegisterMethod(@TMENUITEM.FIND, 'FIND');
+ RegisterMethod(@TMENUITEM.NEWTOPLINE, 'NEWTOPLINE');
+ RegisterMethod(@TMENUITEM.NEWBOTTOMLINE, 'NEWBOTTOMLINE');
+ RegisterMethod(@TMENUITEM.INSERTNEWLINEBEFORE, 'INSERTNEWLINEBEFORE');
+ RegisterMethod(@TMENUITEM.INSERTNEWLINEAFTER, 'INSERTNEWLINEAFTER');
+ RegisterMethod(@TMENUITEM.RETHINKHOTKEYS, 'RETHINKHOTKEYS');
+ RegisterMethod(@TMENUITEM.RETHINKLINES, 'RETHINKLINES');
+ RegisterMethod(@TMENUITEM.ISLINE, 'ISLINE');
+{$ENDIF}
+ RegisterMethod(@TMENUITEM.INDEXOF, 'INDEXOF');
+ RegisterMethod(@TMENUITEM.GETIMAGELIST, 'GETIMAGELIST');
+ RegisterMethod(@TMENUITEM.GETPARENTCOMPONENT, 'GETPARENTCOMPONENT');
+ RegisterMethod(@TMENUITEM.GETPARENTMENU, 'GETPARENTMENU');
+ RegisterMethod(@TMENUITEM.HASPARENT, 'HASPARENT');
+ RegisterMethod(@TMENUITEM.ADD, 'ADD');
+ RegisterMethod(@TMENUITEM.REMOVE, 'REMOVE');
+{$IFNDEF FPC}
+ RegisterPropertyHelper(@TMENUITEMAUTOHOTKEYS_R,@TMENUITEMAUTOHOTKEYS_W,'AUTOHOTKEYS');
+ RegisterPropertyHelper(@TMENUITEMAUTOLINEREDUCTION_R,@TMENUITEMAUTOLINEREDUCTION_W,'AUTOLINEREDUCTION');
+ RegisterEventPropertyHelper(@TMENUITEMONDRAWITEM_R,@TMENUITEMONDRAWITEM_W,'ONDRAWITEM');
+ RegisterEventPropertyHelper(@TMENUITEMONADVANCEDDRAWITEM_R,@TMENUITEMONADVANCEDDRAWITEM_W,'ONADVANCEDDRAWITEM');
+ RegisterEventPropertyHelper(@TMENUITEMONMEASUREITEM_R,@TMENUITEMONMEASUREITEM_W,'ONMEASUREITEM');
+{$ENDIF}
+ RegisterPropertyHelper(@TMENUITEMCOMMAND_R,nil,'COMMAND');
+ RegisterPropertyHelper(@TMENUITEMHANDLE_R,nil,'HANDLE');
+ RegisterPropertyHelper(@TMENUITEMCOUNT_R,nil,'COUNT');
+ RegisterPropertyHelper(@TMENUITEMITEMS_R,nil,'ITEMS');
+ RegisterPropertyHelper(@TMENUITEMMENUINDEX_R,@TMENUITEMMENUINDEX_W,'MENUINDEX');
+ RegisterPropertyHelper(@TMENUITEMPARENT_R,nil,'PARENT');
+ RegisterPropertyHelper(@TMENUITEMACTION_R,@TMENUITEMACTION_W,'ACTION');
+ RegisterPropertyHelper(@TMENUITEMBITMAP_R,@TMENUITEMBITMAP_W,'BITMAP');
+ RegisterPropertyHelper(@TMENUITEMCAPTION_R,@TMENUITEMCAPTION_W,'CAPTION');
+ RegisterPropertyHelper(@TMENUITEMCHECKED_R,@TMENUITEMCHECKED_W,'CHECKED');
+ RegisterPropertyHelper(@TMENUITEMSUBMENUIMAGES_R,@TMENUITEMSUBMENUIMAGES_W,'SUBMENUIMAGES');
+ RegisterPropertyHelper(@TMENUITEMDEFAULT_R,@TMENUITEMDEFAULT_W,'DEFAULT');
+ RegisterPropertyHelper(@TMENUITEMENABLED_R,@TMENUITEMENABLED_W,'ENABLED');
+ RegisterPropertyHelper(@TMENUITEMGROUPINDEX_R,@TMENUITEMGROUPINDEX_W,'GROUPINDEX');
+ RegisterPropertyHelper(@TMENUITEMHELPCONTEXT_R,@TMENUITEMHELPCONTEXT_W,'HELPCONTEXT');
+ RegisterPropertyHelper(@TMENUITEMHINT_R,@TMENUITEMHINT_W,'HINT');
+ RegisterPropertyHelper(@TMENUITEMIMAGEINDEX_R,@TMENUITEMIMAGEINDEX_W,'IMAGEINDEX');
+ RegisterPropertyHelper(@TMENUITEMRADIOITEM_R,@TMENUITEMRADIOITEM_W,'RADIOITEM');
+ RegisterPropertyHelper(@TMENUITEMSHORTCUT_R,@TMENUITEMSHORTCUT_W,'SHORTCUT');
+ RegisterPropertyHelper(@TMENUITEMVISIBLE_R,@TMENUITEMVISIBLE_W,'VISIBLE');
+ RegisterEventPropertyHelper(@TMENUITEMONCLICK_R,@TMENUITEMONCLICK_W,'ONCLICK');
+ end;
+end;
+
+procedure RIRegister_Menus(CL: TPSRuntimeClassImporter);
+begin
+ RIRegisterTMENUITEM(Cl);
+ RIRegisterTMENU(Cl);
+ RIRegisterTPOPUPMENU(Cl);
+ RIRegisterTMAINMENU(Cl);
+ {$IFNDEF FPC}
+ RIRegisterTPOPUPLIST(Cl);
+ RIRegisterTMENUITEMSTACK(Cl);
+ {$ENDIF}
+end;
+
+end.
diff --git a/Units/PascalScript/uPSR_std.pas b/Units/PascalScript/uPSR_std.pas
new file mode 100644
index 0000000..a67946e
--- /dev/null
+++ b/Units/PascalScript/uPSR_std.pas
@@ -0,0 +1,85 @@
+
+unit uPSR_std;
+{$I PascalScript.inc}
+interface
+uses
+ uPSRuntime, uPSUtils;
+
+
+procedure RIRegisterTObject(CL: TPSRuntimeClassImporter);
+procedure RIRegisterTPersistent(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTComponent(Cl: TPSRuntimeClassImporter);
+procedure RIRegister_Std(Cl: TPSRuntimeClassImporter);
+
+implementation
+uses
+ Classes;
+
+
+
+procedure RIRegisterTObject(CL: TPSRuntimeClassImporter);
+begin
+ with cl.Add(TObject) do
+ begin
+ RegisterConstructor(@TObject.Create, 'CREATE');
+ RegisterMethod(@TObject.Free, 'FREE');
+ end;
+end;
+
+procedure RIRegisterTPersistent(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TPersistent) do
+ begin
+ RegisterVirtualMethod(@TPersistent.Assign, 'ASSIGN');
+ end;
+end;
+
+procedure TComponentOwnerR(Self: TComponent; var T: TComponent); begin T := Self.Owner; end;
+
+
+procedure TCOMPONENTCOMPONENTS_R(Self: TCOMPONENT; var T: TCOMPONENT; t1: INTEGER); begin T := Self.COMPONENTS[t1]; end;
+procedure TCOMPONENTCOMPONENTCOUNT_R(Self: TCOMPONENT; var T: INTEGER); begin t := Self.COMPONENTCOUNT; end;
+procedure TCOMPONENTCOMPONENTINDEX_R(Self: TCOMPONENT; var T: INTEGER); begin t := Self.COMPONENTINDEX; end;
+procedure TCOMPONENTCOMPONENTINDEX_W(Self: TCOMPONENT; T: INTEGER); begin Self.COMPONENTINDEX := t; end;
+procedure TCOMPONENTCOMPONENTSTATE_R(Self: TCOMPONENT; var T: TCOMPONENTSTATE); begin t := Self.COMPONENTSTATE; end;
+procedure TCOMPONENTDESIGNINFO_R(Self: TCOMPONENT; var T: LONGINT); begin t := Self.DESIGNINFO; end;
+procedure TCOMPONENTDESIGNINFO_W(Self: TCOMPONENT; T: LONGINT); begin Self.DESIGNINFO := t; end;
+
+
+procedure RIRegisterTComponent(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TComponent) do
+ begin
+ RegisterMethod(@TComponent.FindComponent, 'FINDCOMPONENT');
+ RegisterVirtualConstructor(@TComponent.Create, 'CREATE');
+ RegisterPropertyHelper(@TComponentOwnerR, nil, 'OWNER');
+
+ RegisterMethod(@TCOMPONENT.DESTROYCOMPONENTS, 'DESTROYCOMPONENTS');
+ RegisterPropertyHelper(@TCOMPONENTCOMPONENTS_R, nil, 'COMPONENTS');
+ RegisterPropertyHelper(@TCOMPONENTCOMPONENTCOUNT_R, nil, 'COMPONENTCOUNT');
+ RegisterPropertyHelper(@TCOMPONENTCOMPONENTINDEX_R, @TCOMPONENTCOMPONENTINDEX_W, 'COMPONENTINDEX');
+ RegisterPropertyHelper(@TCOMPONENTCOMPONENTSTATE_R, nil, 'COMPONENTSTATE');
+ RegisterPropertyHelper(@TCOMPONENTDESIGNINFO_R, @TCOMPONENTDESIGNINFO_W, 'DESIGNINFO');
+ end;
+end;
+
+
+
+
+
+
+
+procedure RIRegister_Std(Cl: TPSRuntimeClassImporter);
+begin
+ RIRegisterTObject(CL);
+ RIRegisterTPersistent(Cl);
+ RIRegisterTComponent(Cl);
+end;
+// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl)
+
+end.
+
+
+
+
+
diff --git a/Units/PascalScript/uPSR_stdctrls.pas b/Units/PascalScript/uPSR_stdctrls.pas
new file mode 100644
index 0000000..87eeab9
--- /dev/null
+++ b/Units/PascalScript/uPSR_stdctrls.pas
@@ -0,0 +1,287 @@
+{ STDCtrls import unit }
+unit uPSR_stdctrls;
+
+{$I PascalScript.inc}
+interface
+uses
+ uPSRuntime, uPSUtils;
+
+
+procedure RIRegisterTCUSTOMGROUPBOX(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTGROUPBOX(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTCUSTOMLABEL(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTLABEL(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTCUSTOMEDIT(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTEDIT(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTCUSTOMMEMO(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTMEMO(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTCUSTOMCOMBOBOX(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTCOMBOBOX(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTBUTTONCONTROL(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTBUTTON(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTCUSTOMCHECKBOX(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTCHECKBOX(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTRADIOBUTTON(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTCUSTOMLISTBOX(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTLISTBOX(Cl: TPSRuntimeClassImporter);
+procedure RIRegisterTSCROLLBAR(Cl: TPSRuntimeClassImporter);
+
+procedure RIRegister_stdctrls(cl: TPSRuntimeClassImporter);
+
+implementation
+uses
+ sysutils, classes{$IFDEF CLX}, QControls, QStdCtrls, QGraphics{$ELSE}, controls, stdctrls, Graphics{$ENDIF}{$IFDEF FPC},buttons{$ENDIF};
+
+procedure RIRegisterTCUSTOMGROUPBOX(Cl: TPSRuntimeClassImporter);
+begin
+ Cl.Add(TCUSTOMGROUPBOX);
+end;
+
+
+procedure RIRegisterTGROUPBOX(Cl: TPSRuntimeClassImporter);
+begin
+ Cl.Add(TGROUPBOX);
+end;
+{$IFNDEF CLX}
+procedure TCUSTOMLABELCANVAS_R(Self: TCUSTOMLABEL; var T: TCanvas); begin T := Self.CANVAS; end;
+{$ENDIF}
+
+procedure RIRegisterTCUSTOMLABEL(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TCUSTOMLABEL) do
+ begin
+ {$IFNDEF PS_MINIVCL}
+{$IFNDEF CLX}
+ RegisterPropertyHelper(@TCUSTOMLABELCANVAS_R, nil, 'CANVAS');
+{$ENDIF}
+ {$ENDIF}
+ end;
+end;
+
+procedure RIRegisterTLABEL(Cl: TPSRuntimeClassImporter);
+begin
+ Cl.Add(TLABEL);
+end;
+procedure TCUSTOMEDITMODIFIED_R(Self: TCUSTOMEDIT; var T: BOOLEAN); begin T := Self.MODIFIED; end;
+procedure TCUSTOMEDITMODIFIED_W(Self: TCUSTOMEDIT; T: BOOLEAN); begin Self.MODIFIED := T; end;
+procedure TCUSTOMEDITSELLENGTH_R(Self: TCUSTOMEDIT; var T: INTEGER); begin T := Self.SELLENGTH; end;
+procedure TCUSTOMEDITSELLENGTH_W(Self: TCUSTOMEDIT; T: INTEGER); begin Self.SELLENGTH := T; end;
+procedure TCUSTOMEDITSELSTART_R(Self: TCUSTOMEDIT; var T: INTEGER); begin T := Self.SELSTART; end;
+procedure TCUSTOMEDITSELSTART_W(Self: TCUSTOMEDIT; T: INTEGER); begin Self.SELSTART := T; end;
+procedure TCUSTOMEDITSELTEXT_R(Self: TCUSTOMEDIT; var T: STRING); begin T := Self.SELTEXT; end;
+procedure TCUSTOMEDITSELTEXT_W(Self: TCUSTOMEDIT; T: STRING); begin Self.SELTEXT := T; end;
+procedure TCUSTOMEDITTEXT_R(Self: TCUSTOMEDIT; var T: string); begin T := Self.TEXT; end;
+procedure TCUSTOMEDITTEXT_W(Self: TCUSTOMEDIT; T: string); begin Self.TEXT := T; end;
+
+
+procedure RIRegisterTCUSTOMEDIT(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TCUSTOMEDIT) do
+ begin
+ RegisterMethod(@TCUSTOMEDIT.CLEAR, 'CLEAR');
+ RegisterMethod(@TCUSTOMEDIT.CLEARSELECTION, 'CLEARSELECTION');
+ RegisterMethod(@TCUSTOMEDIT.SELECTALL, 'SELECTALL');
+ RegisterPropertyHelper(@TCUSTOMEDITMODIFIED_R, @TCUSTOMEDITMODIFIED_W, 'MODIFIED');
+ RegisterPropertyHelper(@TCUSTOMEDITSELLENGTH_R, @TCUSTOMEDITSELLENGTH_W, 'SELLENGTH');
+ RegisterPropertyHelper(@TCUSTOMEDITSELSTART_R, @TCUSTOMEDITSELSTART_W, 'SELSTART');
+ RegisterPropertyHelper(@TCUSTOMEDITSELTEXT_R, @TCUSTOMEDITSELTEXT_W, 'SELTEXT');
+ RegisterPropertyHelper(@TCUSTOMEDITTEXT_R, @TCUSTOMEDITTEXT_W, 'TEXT');
+
+ {$IFNDEF PS_MINIVCL}
+ RegisterMethod(@TCUSTOMEDIT.COPYTOCLIPBOARD, 'COPYTOCLIPBOARD');
+ RegisterMethod(@TCUSTOMEDIT.CUTTOCLIPBOARD, 'CUTTOCLIPBOARD');
+ RegisterMethod(@TCUSTOMEDIT.PASTEFROMCLIPBOARD, 'PASTEFROMCLIPBOARD');
+ {$IFNDEF FPC}
+ RegisterMethod(@TCUSTOMEDIT.GETSELTEXTBUF, 'GETSELTEXTBUF');
+ RegisterMethod(@TCUSTOMEDIT.SETSELTEXTBUF, 'SETSELTEXTBUF');
+ {$ENDIF}{FPC}
+ {$ENDIF}
+ end;
+end;
+
+procedure RIRegisterTEDIT(Cl: TPSRuntimeClassImporter);
+begin
+ Cl.Add(TEDIT);
+end;
+
+
+procedure TCUSTOMMEMOLINES_R(Self: {$IFDEF CLX}TMemo{$ELSE}TCUSTOMMEMO{$ENDIF}; var T: TSTRINGS); begin T := Self.LINES; end;
+procedure TCUSTOMMEMOLINES_W(Self: {$IFDEF CLX}TMemo{$ELSE}TCUSTOMMEMO{$ENDIF}; T: TSTRINGS); begin Self.LINES := T; end;
+
+
+procedure RIRegisterTCUSTOMMEMO(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TCUSTOMMEMO) do
+ begin
+ {$IFNDEF CLX}
+ RegisterPropertyHelper(@TCUSTOMMEMOLINES_R, @TCUSTOMMEMOLINES_W, 'LINES');
+ {$ENDIF}
+ end;
+end;
+
+
+procedure RIRegisterTMEMO(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TMEMO) do
+ begin
+ {$IFDEF CLX}
+ RegisterPropertyHelper(@TCUSTOMMEMOLINES_R, @TCUSTOMMEMOLINES_W, 'LINES');
+ {$ENDIF}
+ end;
+end;
+
+
+procedure TCUSTOMCOMBOBOXCANVAS_R(Self: TCUSTOMCOMBOBOX; var T: TCANVAS); begin T := Self.CANVAS; end;
+procedure TCUSTOMCOMBOBOXDROPPEDDOWN_R(Self: TCUSTOMCOMBOBOX; var T: BOOLEAN); begin T := Self.DROPPEDDOWN; end;
+procedure TCUSTOMCOMBOBOXDROPPEDDOWN_W(Self: TCUSTOMCOMBOBOX; T: BOOLEAN); begin Self.DROPPEDDOWN := T; end;
+procedure TCUSTOMCOMBOBOXITEMS_R(Self: TCUSTOMCOMBOBOX; var T: TSTRINGS); begin T := Self.ITEMS; end;
+procedure TCUSTOMCOMBOBOXITEMS_W(Self: TCUSTOMCOMBOBOX; T: TSTRINGS); begin Self.ITEMS := T; end;
+procedure TCUSTOMCOMBOBOXITEMINDEX_R(Self: TCUSTOMCOMBOBOX; var T: INTEGER); begin T := Self.ITEMINDEX; end;
+procedure TCUSTOMCOMBOBOXITEMINDEX_W(Self: TCUSTOMCOMBOBOX; T: INTEGER); begin Self.ITEMINDEX := T; end;
+procedure TCUSTOMCOMBOBOXSELLENGTH_R(Self: TCUSTOMCOMBOBOX; var T: INTEGER); begin T := Self.SELLENGTH; end;
+procedure TCUSTOMCOMBOBOXSELLENGTH_W(Self: TCUSTOMCOMBOBOX; T: INTEGER); begin Self.SELLENGTH := T; end;
+procedure TCUSTOMCOMBOBOXSELSTART_R(Self: TCUSTOMCOMBOBOX; var T: INTEGER); begin T := Self.SELSTART; end;
+procedure TCUSTOMCOMBOBOXSELSTART_W(Self: TCUSTOMCOMBOBOX; T: INTEGER); begin Self.SELSTART := T; end;
+procedure TCUSTOMCOMBOBOXSELTEXT_R(Self: TCUSTOMCOMBOBOX; var T: STRING); begin T := Self.SELTEXT; end;
+procedure TCUSTOMCOMBOBOXSELTEXT_W(Self: TCUSTOMCOMBOBOX; T: STRING); begin Self.SELTEXT := T; end;
+
+
+procedure RIRegisterTCUSTOMCOMBOBOX(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TCUSTOMCOMBOBOX) do
+ begin
+ RegisterPropertyHelper(@TCUSTOMCOMBOBOXDROPPEDDOWN_R, @TCUSTOMCOMBOBOXDROPPEDDOWN_W, 'DROPPEDDOWN');
+ RegisterPropertyHelper(@TCUSTOMCOMBOBOXITEMS_R, @TCUSTOMCOMBOBOXITEMS_W, 'ITEMS');
+ RegisterPropertyHelper(@TCUSTOMCOMBOBOXITEMINDEX_R, @TCUSTOMCOMBOBOXITEMINDEX_W, 'ITEMINDEX');
+
+ {$IFNDEF PS_MINIVCL}
+ RegisterMethod(@TCUSTOMCOMBOBOX.CLEAR, 'CLEAR');
+ RegisterMethod(@TCUSTOMCOMBOBOX.SELECTALL, 'SELECTALL');
+ RegisterPropertyHelper(@TCUSTOMCOMBOBOXCANVAS_R, nil, 'CANVAS');
+ RegisterPropertyHelper(@TCUSTOMCOMBOBOXSELLENGTH_R, @TCUSTOMCOMBOBOXSELLENGTH_W, 'SELLENGTH');
+ RegisterPropertyHelper(@TCUSTOMCOMBOBOXSELSTART_R, @TCUSTOMCOMBOBOXSELSTART_W, 'SELSTART');
+ RegisterPropertyHelper(@TCUSTOMCOMBOBOXSELTEXT_R, @TCUSTOMCOMBOBOXSELTEXT_W, 'SELTEXT');
+ {$ENDIF}
+ end;
+end;
+
+
+
+
+procedure RIRegisterTCOMBOBOX(Cl: TPSRuntimeClassImporter);
+begin
+ Cl.Add(TCOMBOBOX);
+end;
+
+
+
+procedure RIRegisterTBUTTONCONTROL(Cl: TPSRuntimeClassImporter);
+begin
+ Cl.Add(TBUTTONCONTROL);
+end;
+
+
+
+procedure RIRegisterTBUTTON(Cl: TPSRuntimeClassImporter);
+begin
+ Cl.Add(TBUTTON);
+end;
+
+
+
+
+procedure RIRegisterTCUSTOMCHECKBOX(Cl: TPSRuntimeClassImporter);
+begin
+ Cl.Add(TCUSTOMCHECKBOX);
+end;
+
+
+procedure RIRegisterTCHECKBOX(Cl: TPSRuntimeClassImporter);
+begin
+ Cl.Add(TCHECKBOX);
+end;
+
+
+procedure RIRegisterTRADIOBUTTON(Cl: TPSRuntimeClassImporter);
+begin
+ Cl.Add(TRADIOBUTTON);
+end;
+
+procedure TCUSTOMLISTBOXCANVAS_R(Self: TCUSTOMLISTBOX; var T: TCANVAS); begin T := Self.CANVAS; end;
+procedure TCUSTOMLISTBOXITEMS_R(Self: TCUSTOMLISTBOX; var T: TSTRINGS); begin T := Self.ITEMS; end;
+procedure TCUSTOMLISTBOXITEMS_W(Self: TCUSTOMLISTBOX; T: TSTRINGS); begin Self.ITEMS := T; end;
+procedure TCUSTOMLISTBOXITEMINDEX_R(Self: TCUSTOMLISTBOX; var T: INTEGER); begin T := Self.ITEMINDEX; end;
+procedure TCUSTOMLISTBOXITEMINDEX_W(Self: TCUSTOMLISTBOX; T: INTEGER); begin Self.ITEMINDEX := T; end;
+procedure TCUSTOMLISTBOXSELCOUNT_R(Self: TCUSTOMLISTBOX; var T: INTEGER); begin T := Self.SELCOUNT; end;
+procedure TCUSTOMLISTBOXSELECTED_R(Self: TCUSTOMLISTBOX; var T: BOOLEAN; t1: INTEGER); begin T := Self.SELECTED[t1]; end;
+procedure TCUSTOMLISTBOXSELECTED_W(Self: TCUSTOMLISTBOX; T: BOOLEAN; t1: INTEGER); begin Self.SELECTED[t1] := T; end;
+procedure TCUSTOMLISTBOXTOPINDEX_R(Self: TCUSTOMLISTBOX; var T: INTEGER); begin T := Self.TOPINDEX; end;
+procedure TCUSTOMLISTBOXTOPINDEX_W(Self: TCUSTOMLISTBOX; T: INTEGER); begin Self.TOPINDEX := T; end;
+
+
+procedure RIRegisterTCUSTOMLISTBOX(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TCUSTOMLISTBOX) do
+ begin
+ RegisterPropertyHelper(@TCUSTOMLISTBOXITEMS_R, @TCUSTOMLISTBOXITEMS_W, 'ITEMS');
+ RegisterPropertyHelper(@TCUSTOMLISTBOXITEMINDEX_R, @TCUSTOMLISTBOXITEMINDEX_W, 'ITEMINDEX');
+ RegisterPropertyHelper(@TCUSTOMLISTBOXSELCOUNT_R, nil, 'SELCOUNT');
+ RegisterPropertyHelper(@TCUSTOMLISTBOXSELECTED_R, @TCUSTOMLISTBOXSELECTED_W, 'SELECTED');
+
+ {$IFNDEF PS_MINIVCL}
+ RegisterMethod(@TCUSTOMLISTBOX.CLEAR, 'CLEAR');
+ RegisterMethod(@TCUSTOMLISTBOX.ITEMATPOS, 'ITEMATPOS');
+ RegisterMethod(@TCUSTOMLISTBOX.ITEMRECT, 'ITEMRECT');
+ RegisterPropertyHelper(@TCUSTOMLISTBOXCANVAS_R, nil, 'CANVAS');
+ RegisterPropertyHelper(@TCUSTOMLISTBOXTOPINDEX_R, @TCUSTOMLISTBOXTOPINDEX_W, 'TOPINDEX');
+ {$ENDIF}
+ end;
+end;
+
+
+procedure RIRegisterTLISTBOX(Cl: TPSRuntimeClassImporter);
+begin
+ Cl.Add(TLISTBOX);
+end;
+
+
+procedure RIRegisterTSCROLLBAR(Cl: TPSRuntimeClassImporter);
+begin
+ with Cl.Add(TSCROLLBAR) do
+ begin
+ RegisterMethod(@TSCROLLBAR.SETPARAMS, 'SETPARAMS');
+ end;
+end;
+
+
+procedure RIRegister_stdctrls(cl: TPSRuntimeClassImporter);
+begin
+ {$IFNDEF PS_MINIVCL}
+ RIRegisterTCUSTOMGROUPBOX(Cl);
+ RIRegisterTGROUPBOX(Cl);
+ {$ENDIF}
+ RIRegisterTCUSTOMLABEL(Cl);
+ RIRegisterTLABEL(Cl);
+ RIRegisterTCUSTOMEDIT(Cl);
+ RIRegisterTEDIT(Cl);
+ RIRegisterTCUSTOMMEMO(Cl);
+ RIRegisterTMEMO(Cl);
+ RIRegisterTCUSTOMCOMBOBOX(Cl);
+ RIRegisterTCOMBOBOX(Cl);
+ RIRegisterTBUTTONCONTROL(Cl);
+ RIRegisterTBUTTON(Cl);
+ RIRegisterTCUSTOMCHECKBOX(Cl);
+ RIRegisterTCHECKBOX(Cl);
+ RIRegisterTRADIOBUTTON(Cl);
+ RIRegisterTCUSTOMLISTBOX(Cl);
+ RIRegisterTLISTBOX(Cl);
+ {$IFNDEF PS_MINIVCL}
+ RIRegisterTSCROLLBAR(Cl);
+ {$ENDIF}
+end;
+
+// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl)
+
+end.
+
+
diff --git a/Units/PascalScript/uPSRuntime.pas b/Units/PascalScript/uPSRuntime.pas
new file mode 100644
index 0000000..7d61acb
--- /dev/null
+++ b/Units/PascalScript/uPSRuntime.pas
@@ -0,0 +1,12454 @@
+unit uPSRuntime;
+{$I PascalScript.inc}
+{
+
+RemObjects Pascal Script III
+Copyright (C) 2000-2009 by Carlo Kok (ck@carlo-kok.com)
+
+}
+interface
+uses
+ SysUtils, uPSUtils{$IFDEF DELPHI6UP}, variants{$ENDIF}{$IFNDEF PS_NOIDISPATCH}{$IFDEF DELPHI3UP}, ActiveX, Windows{$ELSE}, Ole2{$ENDIF}{$ENDIF};
+
+
+type
+ TPSExec = class;
+ TPSStack = class;
+ TPSRuntimeAttributes = class;
+ TPSRuntimeAttribute = class;
+
+ TPSError = (ErNoError, erCannotImport, erInvalidType, ErInternalError,
+ erInvalidHeader, erInvalidOpcode, erInvalidOpcodeParameter, erNoMainProc,
+ erOutOfGlobalVarsRange, erOutOfProcRange, ErOutOfRange, erOutOfStackRange,
+ ErTypeMismatch, erUnexpectedEof, erVersionError, ErDivideByZero, ErMathError,
+ erCouldNotCallProc, erOutofRecordRange, erOutOfMemory, erException,
+ erNullPointerException, erNullVariantError, erInterfaceNotSupported, erCustomError);
+
+ TPSStatus = (isNotLoaded, isLoaded, isRunning, isPaused);
+
+ PByteArray = ^TByteArray;
+
+ TByteArray = array[0..1023] of Byte;
+
+ PDWordArray = ^TDWordArray;
+
+ TDWordArray = array[0..1023] of Cardinal;
+{@link(TPSProcRec)
+ PIFProcRec is a pointer to a TIProcRec record}
+ TPSProcRec = class;
+ TIFProcRec = TPSProcRec;
+ TPSExternalProcRec = class;
+ TIFPSExternalProcRec = TPSExternalProcRec;
+ TIFExternalProcRec = TPSExternalProcRec;
+ PIFProcRec = TPSProcRec;
+ PProcRec = ^TProcRec;
+
+ TPSProcPtr = function(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
+
+ TPSFreeProc = procedure (Caller: TPSExec; p: PProcRec);
+
+ TPSProcRec = class
+ private
+ FAttributes: TPSRuntimeAttributes;
+ public
+
+ constructor Create(Owner: TPSExec);
+
+ destructor Destroy; override;
+
+
+ property Attributes: TPSRuntimeAttributes read FAttributes;
+ end;
+
+ TPSExternalProcRec = class(TPSProcRec)
+ private
+ FExt1: Pointer;
+ FExt2: Pointer;
+ FName: tbtstring;
+ FProcPtr: TPSProcPtr;
+ FDecl: tbtstring;
+ public
+
+ property Name: tbtstring read FName write FName;
+
+ property Decl: tbtstring read FDecl write FDecl;
+
+ property Ext1: Pointer read FExt1 write FExt1;
+
+ property Ext2: Pointer read FExt2 write FExt2;
+
+ property ProcPtr: TPSProcPtr read FProcPtr write FProcPtr;
+ end;
+
+ TPSInternalProcRec = class(TPSProcRec)
+ private
+ FData: PByteArray;
+ FLength: Cardinal;
+ FExportNameHash: Longint;
+ FExportDecl: tbtstring;
+ FExportName: tbtstring;
+ public
+
+ property Data: PByteArray read FData;
+
+ property Length: Cardinal read FLength;
+
+ property ExportNameHash: Longint read FExportNameHash;
+
+ property ExportName: tbtstring read FExportName write FExportName;
+
+ property ExportDecl: tbtstring read FExportDecl write FExportDecl;
+
+
+ destructor Destroy; override;
+ end;
+
+ TProcRec = record
+
+ Name: ShortString;
+
+ Hash: Longint;
+
+ ProcPtr: TPSProcPtr;
+
+ FreeProc: TPSFreeProc;
+
+ Ext1, Ext2: Pointer;
+ end;
+
+ PBTReturnAddress = ^TBTReturnAddress;
+
+ TBTReturnAddress = packed record
+
+ ProcNo: TPSInternalProcRec;
+
+ Position, StackBase: Cardinal;
+ end;
+
+ TPSTypeRec = class
+ private
+ FExportNameHash: Longint;
+ FExportName: tbtstring;
+ FBaseType: TPSBaseType;
+ FAttributes: TPSRuntimeAttributes;
+ protected
+ FRealSize: Cardinal;
+ public
+
+ property RealSize: Cardinal read FRealSize;
+
+ property BaseType: TPSBaseType read FBaseType write FBaseType;
+
+ property ExportName: tbtstring read FExportName write FExportName;
+
+ property ExportNameHash: Longint read FExportNameHash write FExportNameHash;
+
+ property Attributes: TPSRuntimeAttributes read FAttributes write FAttributes;
+
+ procedure CalcSize; virtual;
+
+ constructor Create(Owner: TPSExec);
+ destructor Destroy; override;
+ end;
+
+ TPSTypeRec_ProcPtr = class(TPSTypeRec)
+ private
+ FParamInfo: tbtstring;
+ public
+
+ property ParamInfo: tbtstring read FParamInfo write FParamInfo;
+ procedure CalcSize; override;
+ end;
+ PIFTypeRec = TPSTypeRec;
+
+ TPSTypeRec_Class = class(TPSTypeRec)
+ private
+ FCN: tbtstring;
+ public
+
+ property CN: tbtstring read FCN write FCN;
+ end;
+{$IFNDEF PS_NOINTERFACES}
+
+ TPSTypeRec_Interface = class(TPSTypeRec)
+ private
+ FGuid: TGUID;
+ public
+
+ property Guid: TGUID read FGuid write FGuid;
+ end;
+{$ENDIF}
+
+ TPSTypeRec_Array = class(TPSTypeRec)
+ private
+ FArrayType: TPSTypeRec;
+ public
+
+ property ArrayType: TPSTypeRec read FArrayType write FArrayType;
+ procedure CalcSize; override;
+ end;
+
+ TPSTypeRec_StaticArray = class(TPSTypeRec_Array)
+ private
+ FSize: Longint;
+ FStartOffset: LongInt;
+ public
+
+ property Size: Longint read FSize write FSize;
+ property StartOffset: LongInt read FStartOffset write FStartOffset;
+
+ procedure CalcSize; override;
+ end;
+
+ TPSTypeRec_Set = class(TPSTypeRec)
+ private
+ FBitSize: Longint;
+ FByteSize: Longint;
+ public
+ {The number of bytes this would require (same as realsize)}
+ property aByteSize: Longint read FByteSize write FByteSize;
+ property aBitSize: Longint read FBitSize write FBitSize;
+ procedure CalcSize; override;
+ end;
+
+ TPSTypeRec_Record = class(TPSTypeRec)
+ private
+ FFieldTypes: TPSList;
+ FRealFieldOffsets: TPSList;
+ public
+
+ property FieldTypes: TPSList read FFieldTypes;
+
+ property RealFieldOffsets: TPSList read FRealFieldOffsets;
+
+ procedure CalcSize; override;
+
+ constructor Create(Owner: TPSExec);
+ destructor Destroy; override;
+ end;
+
+ PPSVariant = ^TPSVariant;
+
+ PIFVariant = PPSVariant;
+
+ TPSVariant = packed record
+ FType: TPSTypeRec;
+ end;
+
+ PPSVariantData = ^TPSVariantData;
+
+ TPSVariantData = packed record
+ VI: TPSVariant;
+ Data: array[0..0] of Byte;
+ end;
+
+ PPSVariantU8 = ^TPSVariantU8;
+
+ TPSVariantU8 = packed record
+ VI: TPSVariant;
+ Data: tbtU8;
+ end;
+
+
+ PPSVariantS8 = ^TPSVariantS8;
+
+ TPSVariantS8 = packed record
+ VI: TPSVariant;
+ Data: tbts8;
+ end;
+
+
+ PPSVariantU16 = ^TPSVariantU16;
+
+ TPSVariantU16 = packed record
+ VI: TPSVariant;
+ Data: tbtU16;
+ end;
+
+
+ PPSVariantS16 = ^TPSVariantS16;
+
+ TPSVariantS16 = packed record
+ VI: TPSVariant;
+ Data: tbts16;
+ end;
+
+
+ PPSVariantU32 = ^TPSVariantU32;
+
+ TPSVariantU32 = packed record
+ VI: TPSVariant;
+ Data: tbtU32;
+ end;
+
+
+ PPSVariantS32 = ^TPSVariantS32;
+
+ TPSVariantS32 = packed record
+ VI: TPSVariant;
+ Data: tbts32;
+ end;
+{$IFNDEF PS_NOINT64}
+
+ PPSVariantS64 = ^TPSVariantS64;
+
+ TPSVariantS64 = packed record
+ VI: TPSVariant;
+ Data: tbts64;
+ end;
+{$ENDIF}
+
+ PPSVariantAChar = ^TPSVariantAChar;
+
+ TPSVariantAChar = packed record
+ VI: TPSVariant;
+ Data: tbtChar;
+ end;
+
+{$IFNDEF PS_NOWIDESTRING}
+
+ PPSVariantWChar = ^TPSVariantWChar;
+
+ TPSVariantWChar = packed record
+ VI: TPSVariant;
+ Data: tbtWideChar;
+ end;
+{$ENDIF}
+
+ PPSVariantAString = ^TPSVariantAString;
+
+ TPSVariantAString = packed record
+ VI: TPSVariant;
+ Data: tbtString;
+ end;
+
+{$IFNDEF PS_NOWIDESTRING}
+
+ PPSVariantWString = ^TPSVariantWString;
+
+ TPSVariantWString = {$IFNDEF DELPHI2009UP}packed {$ENDIF}record
+ VI: TPSVariant;
+ Data: tbtWideString;
+ end;
+
+ PPSVariantUString = ^TPSVariantUString;
+
+ TPSVariantUString = {$IFNDEF DELPHI2009UP}packed {$ENDIF}record
+ VI: TPSVariant;
+ Data: tbtunicodestring;
+ end;
+
+{$ENDIF}
+
+
+ PPSVariantSingle = ^TPSVariantSingle;
+
+ TPSVariantSingle = packed record
+ VI: TPSVariant;
+ Data: tbtsingle;
+ end;
+
+
+ PPSVariantDouble = ^TPSVariantDouble;
+
+ TPSVariantDouble = packed record
+ VI: TPSVariant;
+ Data: tbtDouble;
+ end;
+
+
+ PPSVariantExtended = ^TPSVariantExtended;
+
+ TPSVariantExtended = packed record
+ VI: TPSVariant;
+ Data: tbtExtended;
+ end;
+
+
+ PPSVariantCurrency = ^TPSVariantCurrency;
+
+ TPSVariantCurrency = packed record
+ VI: TPSVariant;
+ Data: tbtCurrency;
+ end;
+
+ PPSVariantSet = ^TPSVariantSet;
+
+ TPSVariantSet = packed record
+ VI: TPSVariant;
+ Data: array[0..0] of Byte;
+ end;
+
+{$IFNDEF PS_NOINTERFACES}
+
+ PPSVariantInterface = ^TPSVariantInterface;
+
+ TPSVariantInterface = packed record
+ VI: TPSVariant;
+ Data: IUnknown;
+ end;
+{$ENDIF}
+
+ PPSVariantClass = ^TPSVariantClass;
+
+ TPSVariantClass = packed record
+ VI: TPSVariant;
+ Data: TObject;
+ end;
+
+
+ PPSVariantRecord = ^TPSVariantRecord;
+
+ TPSVariantRecord = packed record
+ VI: TPSVariant;
+ data: array[0..0] of byte;
+ end;
+
+
+ PPSVariantDynamicArray = ^TPSVariantDynamicArray;
+
+ TPSVariantDynamicArray = packed record
+ VI: TPSVariant;
+ Data: Pointer;
+ end;
+
+
+ PPSVariantStaticArray = ^TPSVariantStaticArray;
+
+ TPSVariantStaticArray = packed record
+ VI: TPSVariant;
+ data: array[0..0] of byte;
+ end;
+
+
+ PPSVariantPointer = ^TPSVariantPointer;
+
+ TPSVariantPointer = packed record
+ VI: TPSVariant;
+ DataDest: Pointer;
+ DestType: TPSTypeRec;
+ FreeIt: LongBool;
+ end;
+
+
+ PPSVariantReturnAddress = ^TPSVariantReturnAddress;
+
+ TPSVariantReturnAddress = packed record
+ VI: TPSVariant;
+ Addr: TBTReturnAddress;
+ end;
+
+
+ PPSVariantVariant = ^TPSVariantVariant;
+
+ TPSVariantVariant = packed record
+ VI: TPSVariant;
+ Data: Variant;
+ end;
+
+ PPSVariantProcPtr = ^TPSVariantProcPtr;
+ TPSVariantProcPtr = packed record
+ VI: TPSVariant;
+ ProcNo: Cardinal;
+ Self: Pointer;
+ Ptr: Pointer;
+ {
+ ProcNo = 0 means Self/Ptr become active (Ptr = nil means it's nil)
+ }
+ end;
+
+
+ TPSVarFreeType = (
+ vtNone,
+ vtTempVar
+ );
+
+ TPSResultData = packed record
+ P: Pointer;
+ aType: TPSTypeRec;
+ FreeType: TPSVarFreeType;
+ end;
+
+
+ PPSResource = ^TPSResource;
+
+ TPSResource = record
+ Proc: Pointer;
+ P: Pointer;
+ end;
+
+ TPSAttributeUseProc = function (Sender: TPSExec; const AttribType: tbtstring; Attr: TPSRuntimeAttribute): Boolean;
+
+ TPSAttributeType = class
+ private
+ FTypeName: tbtstring;
+ FUseProc: TPSAttributeUseProc;
+ FTypeNameHash: Longint;
+ public
+
+ property UseProc: TPSAttributeUseProc read FUseProc write FUseProc;
+
+ property TypeName: tbtstring read FTypeName write FTypeName;
+
+ property TypeNameHash: Longint read FTypeNameHash write FTypeNameHash;
+ end;
+
+ PClassItem = ^TClassItem;
+
+ TClassItem = record
+
+ FName: tbtstring;
+
+ FNameHash: Longint;
+
+ b: byte;
+ case byte of
+ 0: (Ptr: Pointer);
+ 1: (PointerInList: Pointer);
+ 3: (FReadFunc, FWriteFunc: Pointer); {Property Helper}
+ 4: (Ptr2: Pointer);
+ 5: (PointerInList2: Pointer);
+ 6: (); {Property helper, like 3}
+ 7: (); {Property helper that will pass it's name}
+ end;
+
+
+ PPSVariantIFC = ^TPSVariantIFC;
+ {Temporary variant into record}
+ TPSVariantIFC = packed record
+ Dta: Pointer;
+ aType: TPSTypeRec;
+ VarParam: Boolean;
+ end;
+ PIFPSVariantIFC = PPSVariantIFC;
+ TIFPSVariantIFC = TPSVariantIFC;
+
+ TPSRuntimeAttribute = class(TObject)
+ private
+ FValues: TPSStack;
+ FAttribType: tbtstring;
+ FOwner: TPSRuntimeAttributes;
+ FAttribTypeHash: Longint;
+ function GetValue(I: Longint): PIFVariant;
+ function GetValueCount: Longint;
+ public
+
+ property Owner: TPSRuntimeAttributes read FOwner;
+
+ property AttribType: tbtstring read FAttribType write FAttribType;
+
+ property AttribTypeHash: Longint read FAttribTypeHash write FAttribTypeHash;
+
+ property ValueCount: Longint read GetValueCount;
+
+ property Value[I: Longint]: PIFVariant read GetValue;
+
+ function AddValue(aType: TPSTypeRec): PPSVariant;
+
+ procedure DeleteValue(i: Longint);
+
+ procedure AdjustSize;
+
+
+ constructor Create(Owner: TPSRuntimeAttributes);
+
+ destructor Destroy; override;
+ end;
+
+ TPSRuntimeAttributes = class(TObject)
+ private
+ FAttributes: TPSList;
+ FOwner: TPSExec;
+ function GetCount: Longint;
+ function GetItem(I: Longint): TPSRuntimeAttribute;
+ public
+
+ property Owner: TPSExec read FOwner;
+
+ property Count: Longint read GetCount;
+
+ property Items[I: Longint]: TPSRuntimeAttribute read GetItem; default;
+
+ procedure Delete(I: Longint);
+
+ function Add: TPSRuntimeAttribute;
+
+ function FindAttribute(const Name: tbtstring): TPSRuntimeAttribute;
+
+
+ constructor Create(AOwner: TPSExec);
+
+ destructor Destroy; override;
+ end;
+ TPSOnGetNVariant = function (Sender: TPSExec; const Name: tbtstring): Variant;
+ TPSOnSetNVariant = procedure (Sender: TPSExec; const Name: tbtstring; V: Variant);
+
+ TPSOnLineEvent = procedure(Sender: TPSExec);
+
+ TPSOnSpecialProcImport = function (Sender: TPSExec; p: TPSExternalProcRec; Tag: Pointer): Boolean;
+
+ TPSOnException = procedure (Sender: TPSExec; ExError: TPSError; const ExParam: tbtstring; ExObject: TObject; ProcNo, Position: Cardinal);
+
+ TPSExec = class(TObject)
+ Private
+ FOnGetNVariant: TPSOnGetNVariant;
+ FOnSetNVariant: TPSOnSetNVariant;
+ FId: Pointer;
+ FJumpFlag: Boolean;
+ FCallCleanup: Boolean;
+ FOnException: TPSOnException;
+ function ReadData(var Data; Len: Cardinal): Boolean;
+ function ReadLong(var b: Cardinal): Boolean;
+ function DoCalc(var1, Var2: Pointer; var1Type, var2type: TPSTypeRec; CalcType: Cardinal): Boolean;
+ function DoBooleanCalc(var1, Var2, into: Pointer; var1Type, var2type, intotype: TPSTypeRec; Cmd: Cardinal): Boolean;
+ function SetVariantValue(dest, Src: Pointer; desttype, srctype: TPSTypeRec): Boolean;
+ function ReadVariable(var Dest: TPSResultData; UsePointer: Boolean): Boolean;
+ function DoBooleanNot(Dta: Pointer; aType: TPSTypeRec): Boolean;
+ function DoMinus(Dta: Pointer; aType: TPSTypeRec): Boolean;
+ function DoIntegerNot(Dta: Pointer; aType: TPSTypeRec): Boolean;
+ procedure RegisterStandardProcs;
+ Protected
+
+ FReturnAddressType: TPSTypeRec;
+
+ FVariantType: TPSTypeRec;
+
+ FVariantArrayType: TPSTypeRec;
+
+ FAttributeTypes: TPSList;
+
+ FExceptionStack: TPSList;
+
+ FResources: TPSList;
+
+ FExportedVars: TPSList;
+
+ FTypes: TPSList;
+
+ FProcs: TPSList;
+
+ FGlobalVars: TPSStack;
+
+ FTempVars: TPSStack;
+
+ FStack: TPSStack;
+
+ FMainProc: Cardinal;
+
+ FStatus: TPSStatus;
+
+ FCurrProc: TPSInternalProcRec;
+
+ FData: PByteArray;
+
+ FDataLength: Cardinal;
+
+ FCurrentPosition: Cardinal;
+
+ FCurrStackBase: Cardinal;
+
+ FOnRunLine: TPSOnLineEvent;
+
+ FSpecialProcList: TPSList;
+
+ FRegProcs: TPSList;
+
+ ExObject: TObject;
+
+ ExProc: Cardinal;
+
+ ExPos: Cardinal;
+
+ ExEx: TPSError;
+
+ ExParam: tbtstring;
+
+ function InvokeExternalMethod(At: TPSTypeRec_ProcPtr; Slf, Ptr: Pointer): Boolean;
+
+ function InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean;
+
+ procedure RunLine; virtual;
+
+ function ImportProc(const Name: ShortString; proc: TPSExternalProcRec): Boolean; Virtual;
+
+ procedure ExceptionProc(proc, Position: Cardinal; Ex: TPSError; const s: tbtstring; NewObject: TObject); Virtual;
+
+ function FindSpecialProcImport(P: TPSOnSpecialProcImport): pointer;
+ Public
+ function LastEx: TPSError;
+ function LastExParam: tbtstring;
+ function LastExProc: Integer;
+ function LastExPos: Integer;
+ procedure CMD_Err(EC: TPSError);
+
+ procedure CMD_Err2(EC: TPSError; const Param: tbtstring);
+
+ procedure CMD_Err3(EC: TPSError; const Param: tbtstring; ExObject: TObject);
+
+ property Id: Pointer read FID write FID;
+
+ class function About: tbtstring;
+
+ function RunProc(Params: TPSList; ProcNo: Cardinal): Boolean;
+
+ function RunProcP(const Params: array of Variant; const Procno: Cardinal): Variant;
+ function RunProcPVar(var Params: array of Variant; const Procno: Cardinal): Variant;
+
+ function RunProcPN(const Params: array of Variant; const ProcName: tbtstring): Variant;
+
+ function FindType(StartAt: Cardinal; BaseType: TPSBaseType; var l: Cardinal): PIFTypeRec;
+
+ function FindType2(BaseType: TPSBaseType): PIFTypeRec;
+
+ function GetTypeNo(l: Cardinal): PIFTypeRec;
+
+ function GetType(const Name: tbtstring): Cardinal;
+
+ function GetProc(const Name: tbtstring): Cardinal;
+
+ function GetVar(const Name: tbtstring): Cardinal;
+
+ function GetVar2(const Name: tbtstring): PIFVariant;
+
+ function GetVarNo(C: Cardinal): PIFVariant;
+
+ function GetProcNo(C: Cardinal): PIFProcRec;
+
+ function GetProcCount: Cardinal;
+
+ function GetVarCount: Longint;
+
+ function GetTypeCount: Longint;
+
+
+ constructor Create;
+
+ destructor Destroy; Override;
+
+
+ function RunScript: Boolean;
+
+
+ function LoadData(const s: tbtstring): Boolean; virtual;
+
+ procedure Clear; Virtual;
+
+ procedure Cleanup; Virtual;
+
+ procedure Stop; Virtual;
+
+ procedure Pause; Virtual;
+
+ property CallCleanup: Boolean read FCallCleanup write FCallCleanup;
+
+ property Status: TPSStatus Read FStatus;
+
+ property OnRunLine: TPSOnLineEvent Read FOnRunLine Write FOnRunLine;
+
+ procedure ClearspecialProcImports;
+
+ procedure AddSpecialProcImport(const FName: tbtstring; P: TPSOnSpecialProcImport; Tag: Pointer);
+
+ function RegisterFunctionName(const Name: tbtstring; ProcPtr: TPSProcPtr;
+ Ext1, Ext2: Pointer): PProcRec;
+
+ procedure RegisterDelphiFunction(ProcPtr: Pointer; const Name: tbtstring; CC: TPSCallingConvention);
+
+ procedure RegisterDelphiMethod(Slf, ProcPtr: Pointer; const Name: tbtstring; CC: TPSCallingConvention);
+
+ function GetProcAsMethod(const ProcNo: Cardinal): TMethod;
+
+ function GetProcAsMethodN(const ProcName: tbtstring): TMethod;
+
+ procedure RegisterAttributeType(useproc: TPSAttributeUseProc; const TypeName: tbtstring);
+
+ procedure ClearFunctionList;
+
+ property ExceptionProcNo: Cardinal Read ExProc;
+
+ property ExceptionPos: Cardinal Read ExPos;
+
+ property ExceptionCode: TPSError Read ExEx;
+
+ property ExceptionString: tbtstring read ExParam;
+
+ property ExceptionObject: TObject read ExObject write ExObject;
+
+ procedure AddResource(Proc, P: Pointer);
+
+ function IsValidResource(Proc, P: Pointer): Boolean;
+
+ procedure DeleteResource(P: Pointer);
+
+ function FindProcResource(Proc: Pointer): Pointer;
+
+ function FindProcResource2(Proc: Pointer; var StartAt: Longint): Pointer;
+
+ procedure RaiseCurrentException;
+
+ property OnException: TPSOnException read FOnException write FOnException;
+ property OnGetNVariant: TPSOnGetNVariant read FOnGetNVariant write FOnGetNVariant;
+ property OnSetNVariant: TPSOnSetNVariant read FOnSetNVariant write FOnSetNVariant;
+ end;
+
+ TPSStack = class(TPSList)
+ private
+ FDataPtr: Pointer;
+ FCapacity,
+ FLength: Longint;
+ function GetItem(I: Longint): PPSVariant;
+ procedure SetCapacity(const Value: Longint);
+ procedure AdjustLength;
+ public
+
+ property DataPtr: Pointer read FDataPtr;
+
+ property Capacity: Longint read FCapacity write SetCapacity;
+
+ property Length: Longint read FLength;
+
+
+ constructor Create;
+
+ destructor Destroy; override;
+
+ procedure Clear; {$IFDEF DELPHI5UP} reintroduce;{$ELSE} override; {$ENDIF}
+
+ function Push(TotalSize: Longint): PPSVariant;
+
+ function PushType(aType: TPSTypeRec): PPSVariant;
+
+ procedure Pop;
+ function GetInt(ItemNo: Longint): Longint;
+ function GetUInt(ItemNo: Longint): Cardinal;
+{$IFNDEF PS_NOINT64}
+ function GetInt64(ItemNo: Longint): Int64;
+{$ENDIF}
+ function GetString(ItemNo: Longint): string; // calls the native method
+ function GetAnsiString(ItemNo: Longint): tbtstring;
+{$IFNDEF PS_NOWIDESTRING}
+ function GetWideString(ItemNo: Longint): tbtWideString;
+ function GetUnicodeString(ItemNo: Longint): tbtunicodestring;
+{$ENDIF}
+ function GetReal(ItemNo: Longint): Extended;
+ function GetCurrency(ItemNo: Longint): Currency;
+ function GetBool(ItemNo: Longint): Boolean;
+ function GetClass(ItemNo: Longint): TObject;
+
+ procedure SetInt(ItemNo: Longint; const Data: Longint);
+ procedure SetUInt(ItemNo: Longint; const Data: Cardinal);
+{$IFNDEF PS_NOINT64}
+ procedure SetInt64(ItemNo: Longint; const Data: Int64);
+{$ENDIF}
+ procedure SetString(ItemNo: Longint; const Data: string);
+ procedure SetAnsiString(ItemNo: Longint; const Data: tbtstring);
+{$IFNDEF PS_NOWIDESTRING}
+ procedure SetWideString(ItemNo: Longint; const Data: tbtWideString);
+ procedure SetUnicodeString(ItemNo: Longint; const Data: tbtunicodestring);
+{$ENDIF}
+ procedure SetReal(ItemNo: Longint; const Data: Extended);
+ procedure SetCurrency(ItemNo: Longint; const Data: Currency);
+ procedure SetBool(ItemNo: Longint; const Data: Boolean);
+ procedure SetClass(ItemNo: Longint; const Data: TObject);
+
+ property Items[I: Longint]: PPSVariant read GetItem; default;
+ end;
+
+
+function PSErrorToString(x: TPSError; const Param: tbtstring): tbtstring;
+function TIFErrorToString(x: TPSError; const Param: tbtstring): tbtstring;
+function CreateHeapVariant(aType: TPSTypeRec): PPSVariant;
+procedure DestroyHeapVariant(v: PPSVariant);
+
+procedure FreePIFVariantList(l: TPSList);
+procedure FreePSVariantList(l: TPSList);
+
+const
+ ENoError = ERNoError;
+
+
+function PIFVariantToVariant(Src: PIFVariant; var Dest: Variant): Boolean;
+function VariantToPIFVariant(Exec: TPSExec; const Src: Variant; Dest: PIFVariant): Boolean;
+
+function PSGetRecField(const avar: TPSVariantIFC; Fieldno: Longint): TPSVariantIFC;
+function PSGetArrayField(const avar: TPSVariantIFC; Fieldno: Longint): TPSVariantIFC;
+function NewTPSVariantRecordIFC(avar: PPSVariant; Fieldno: Longint): TPSVariantIFC;
+
+function NewTPSVariantIFC(avar: PPSVariant; varparam: boolean): TPSVariantIFC;
+
+function NewPPSVariantIFC(avar: PPSVariant; varparam: boolean): PPSVariantIFC;
+
+procedure DisposePPSVariantIFC(aVar: PPSVariantIFC);
+
+procedure DisposePPSVariantIFCList(list: TPSList);
+
+
+function PSGetObject(Src: Pointer; aType: TPSTypeRec): TObject;
+function PSGetUInt(Src: Pointer; aType: TPSTypeRec): Cardinal;
+{$IFNDEF PS_NOINT64}
+function PSGetInt64(Src: Pointer; aType: TPSTypeRec): Int64;
+{$ENDIF}
+function PSGetReal(Src: Pointer; aType: TPSTypeRec): Extended;
+function PSGetCurrency(Src: Pointer; aType: TPSTypeRec): Currency;
+function PSGetInt(Src: Pointer; aType: TPSTypeRec): Longint;
+function PSGetString(Src: Pointer; aType: TPSTypeRec): string;
+function PSGetAnsiString(Src: Pointer; aType: TPSTypeRec): tbtString;
+{$IFNDEF PS_NOWIDESTRING}
+function PSGetWideString(Src: Pointer; aType: TPSTypeRec): tbtWideString;
+function PSGetUnicodeString(Src: Pointer; aType: TPSTypeRec): tbtunicodestring;
+{$ENDIF}
+
+procedure PSSetObject(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; Const val: TObject);
+procedure PSSetUInt(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Cardinal);
+{$IFNDEF PS_NOINT64}
+procedure PSSetInt64(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Int64);
+{$ENDIF}
+procedure PSSetReal(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Extended);
+procedure PSSetCurrency(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Currency);
+procedure PSSetInt(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Longint);
+procedure PSSetString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: String);
+procedure PSSetAnsiString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: tbtString);
+{$IFNDEF PS_NOWIDESTRING}
+procedure PSSetWideString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: tbtWideString);
+procedure PSSetUnicodeString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: tbtunicodestring);
+{$ENDIF}
+
+procedure VNSetPointerTo(const Src: TPSVariantIFC; Data: Pointer; aType: TPSTypeRec);
+
+function VNGetUInt(const Src: TPSVariantIFC): Cardinal;
+{$IFNDEF PS_NOINT64}
+function VNGetInt64(const Src: TPSVariantIFC): Int64;
+{$ENDIF}
+function VNGetReal(const Src: TPSVariantIFC): Extended;
+function VNGetCurrency(const Src: TPSVariantIFC): Currency;
+function VNGetInt(const Src: TPSVariantIFC): Longint;
+function VNGetString(const Src: TPSVariantIFC): String;
+function VNGetAnsiString(const Src: TPSVariantIFC): tbtString;
+{$IFNDEF PS_NOWIDESTRING}
+function VNGetWideString(const Src: TPSVariantIFC): tbtWideString;
+function VNGetUnicodeString(const Src: TPSVariantIFC): tbtunicodestring;
+{$ENDIF}
+
+procedure VNSetUInt(const Src: TPSVariantIFC; const Val: Cardinal);
+{$IFNDEF PS_NOINT64}
+procedure VNSetInt64(const Src: TPSVariantIFC; const Val: Int64);
+{$ENDIF}
+procedure VNSetReal(const Src: TPSVariantIFC; const Val: Extended);
+procedure VNSetCurrency(const Src: TPSVariantIFC; const Val: Currency);
+procedure VNSetInt(const Src: TPSVariantIFC; const Val: Longint);
+procedure VNSetString(const Src: TPSVariantIFC; const Val: String);
+procedure VNSetAnsiString(const Src: TPSVariantIFC; const Val: tbtString);
+{$IFNDEF PS_NOWIDESTRING}
+procedure VNSetWideString(const Src: TPSVariantIFC; const Val: tbtWideString);
+procedure VNSetUnicodeString(const Src: TPSVariantIFC; const Val: tbtunicodestring);
+{$ENDIF}
+
+function VGetUInt(const Src: PIFVariant): Cardinal;
+{$IFNDEF PS_NOINT64}
+function VGetInt64(const Src: PIFVariant): Int64;
+{$ENDIF}
+function VGetReal(const Src: PIFVariant): Extended;
+function VGetCurrency(const Src: PIFVariant): Currency;
+function VGetInt(const Src: PIFVariant): Longint;
+function VGetString(const Src: PIFVariant): String;
+function VGetAnsiString(const Src: PIFVariant): tbtString;
+{$IFNDEF PS_NOWIDESTRING}
+function VGetWideString(const Src: PIFVariant): tbtWideString;
+function VGetUnicodeString(const Src: PIFVariant): tbtunicodestring;
+{$ENDIF}
+
+procedure VSetPointerTo(const Src: PIFVariant; Data: Pointer; aType: TPSTypeRec);
+procedure VSetUInt(const Src: PIFVariant; const Val: Cardinal);
+{$IFNDEF PS_NOINT64}
+procedure VSetInt64(const Src: PIFVariant; const Val: Int64);
+{$ENDIF}
+procedure VSetReal(const Src: PIFVariant; const Val: Extended);
+procedure VSetCurrency(const Src: PIFVariant; const Val: Currency);
+procedure VSetInt(const Src: PIFVariant; const Val: Longint);
+procedure VSetString(const Src: PIFVariant; const Val: string);
+procedure VSetAnsiString(const Src: PIFVariant; const Val: tbtString);
+{$IFNDEF PS_NOWIDESTRING}
+procedure VSetWideString(const Src: PIFVariant; const Val: tbtWideString);
+procedure VSetUnicodeString(const Src: PIFVariant; const Val: tbtunicodestring);
+{$ENDIF}
+
+type
+
+ EPSException = class(Exception)
+ private
+ FProcPos: Cardinal;
+ FProcNo: Cardinal;
+ FExec: TPSExec;
+ public
+
+ constructor Create(const Error: tbtstring; Exec: TPSExec; Procno, ProcPos: Cardinal);
+
+ property ProcNo: Cardinal read FProcNo;
+
+ property ProcPos: Cardinal read FProcPos;
+
+ property Exec: TPSExec read FExec;
+ end;
+
+ TPSRuntimeClass = class
+ protected
+ FClassName: tbtstring;
+ FClassNameHash: Longint;
+
+ FClassItems: TPSList;
+ FClass: TClass;
+
+ FEndOfVmt: Longint;
+ public
+
+ procedure RegisterConstructor(ProcPtr: Pointer; const Name: tbtstring);
+
+ procedure RegisterVirtualConstructor(ProcPtr: Pointer; const Name: tbtstring);
+
+ procedure RegisterMethod(ProcPtr: Pointer; const Name: tbtstring);
+
+ procedure RegisterVirtualMethod(ProcPtr: Pointer; const Name: tbtstring);
+
+ procedure RegisterVirtualAbstractMethod(ClassDef: TClass; ProcPtr: Pointer; const Name: tbtstring);
+
+ procedure RegisterPropertyHelper(ReadFunc, WriteFunc: Pointer; const Name: tbtstring);
+
+ procedure RegisterPropertyHelperName(ReadFunc, WriteFunc: Pointer; const Name: tbtstring);
+
+ procedure RegisterEventPropertyHelper(ReadFunc, WriteFunc: Pointer; const Name: tbtstring);
+
+ constructor Create(aClass: TClass; const AName: tbtstring);
+
+ destructor Destroy; override;
+ end;
+
+ TPSRuntimeClassImporter = class
+ private
+ FClasses: TPSList;
+ public
+
+ constructor Create;
+
+ constructor CreateAndRegister(Exec: TPSexec; AutoFree: Boolean);
+
+ destructor Destroy; override;
+
+ function Add(aClass: TClass): TPSRuntimeClass;
+
+ function Add2(aClass: TClass; const Name: tbtstring): TPSRuntimeClass;
+
+ procedure Clear;
+
+ function FindClass(const Name: tbtstring): TPSRuntimeClass;
+ end;
+ TIFPSRuntimeClassImporter = TPSRuntimeClassImporter;
+ TPSResourceFreeProc = procedure (Sender: TPSExec; P: TPSRuntimeClassImporter);
+
+
+procedure RegisterClassLibraryRuntime(SE: TPSExec; Importer: TPSRuntimeClassImporter);
+
+procedure SetVariantToClass(V: PIFVariant; Cl: TObject);
+{$IFNDEF PS_NOINTERFACES}
+procedure SetVariantToInterface(V: PIFVariant; Cl: IUnknown);
+{$ENDIF}
+
+procedure MyAllMethodsHandler;
+
+function GetMethodInfoRec(SE: TPSExec; ProcNo: Cardinal): Pointer;
+
+function MkMethod(FSE: TPSExec; No: Cardinal): TMethod;
+
+type
+ TIFInternalProcRec = TPSInternalProcRec;
+ TIFError = TPSError;
+ TIFStatus = TPSStatus;
+ TIFPSExec = TPSExec;
+ TIFPSStack = TPSStack;
+ TIFTypeRec = TPSTypeRec;
+
+
+ TPSCallingConvention = uPSUtils.TPSCallingConvention;
+const
+
+ cdRegister = uPSUtils.cdRegister;
+
+ cdPascal = uPSUtils.cdPascal;
+
+ cdCdecl = uPSUtils.cdCdecl;
+
+ cdStdCall = uPSUtils.cdStdCall;
+
+ InvalidVal = Cardinal(-1);
+
+function PSDynArrayGetLength(arr: Pointer; aType: TPSTypeRec): Longint;
+procedure PSDynArraySetLength(var arr: Pointer; aType: TPSTypeRec; NewLength: Longint);
+
+function GetPSArrayLength(Arr: PIFVariant): Longint;
+procedure SetPSArrayLength(Arr: PIFVariant; NewLength: Longint);
+
+function PSVariantToString(const p: TPSVariantIFC; const ClassProperties: tbtstring): tbtstring;
+function MakeString(const s: tbtstring): tbtstring;
+{$IFNDEF PS_NOWIDESTRING}
+function MakeWString(const s: tbtunicodestring): tbtstring;
+{$ENDIF}
+
+{$IFNDEF PS_NOIDISPATCH}
+function IDispatchInvoke(Self: IDispatch; PropertySet: Boolean; const Name: tbtString; const Par: array of Variant): Variant;
+{$ENDIF}
+
+
+implementation
+uses
+ TypInfo {$IFDEF DELPHI3UP}{$IFNDEF FPC} , ComObj {$ENDIF}{$ENDIF};
+
+{$IFDEF DELPHI3UP }
+resourceString
+{$ELSE }
+const
+{$ENDIF }
+
+ RPS_UnknownIdentifier = 'Unknown Identifier';
+ RPS_Exception = 'Exception: %s';
+ RPS_Invalid = '[Invalid]';
+
+ //- PSErrorToString
+ RPS_NoError = 'No Error';
+ RPS_CannotImport = 'Cannot Import %s';
+ RPS_InvalidType = 'Invalid Type';
+ RPS_InternalError = 'Internal error';
+ RPS_InvalidHeader = 'Invalid Header';
+ RPS_InvalidOpcode = 'Invalid Opcode';
+ RPS_InvalidOpcodeParameter = 'Invalid Opcode Parameter';
+ RPS_NoMainProc = 'no Main Proc';
+ RPS_OutOfGlobalVarsRange = 'Out of Global Vars range';
+ RPS_OutOfProcRange = 'Out of Proc Range';
+ RPS_OutOfRange = 'Out Of Range';
+ RPS_OutOfStackRange = 'Out Of Stack Range';
+ RPS_TypeMismatch = 'Type Mismatch';
+ RPS_UnexpectedEof = 'Unexpected End Of File';
+ RPS_VersionError = 'Version error';
+ RPS_DivideByZero = 'divide by Zero';
+ RPS_MathError = 'Math error';
+ RPS_CouldNotCallProc = 'Could not call proc';
+ RPS_OutofRecordRange = 'Out of Record Fields Range';
+ RPS_NullPointerException = 'Null Pointer Exception';
+ RPS_NullVariantError = 'Null variant error';
+ RPS_OutOfMemory = 'Out Of Memory';
+ RPS_InterfaceNotSupported = 'Interface not supported';
+ RPS_UnknownError = 'Unknown error';
+
+
+ RPS_InvalidVariable = 'Invalid variable';
+ RPS_InvalidArray = 'Invalid array';
+ RPS_OLEError = 'OLE error %.8x';
+ RPS_UnknownProcedure = 'Unknown procedure';
+ RPS_NotEnoughParameters = 'Not enough parameters';
+ RPS_InvalidParameter = 'Invalid parameter';
+ RPS_TooManyParameters = 'Too many parameters';
+ RPS_OutOfStringRange = 'Out of string range';
+ RPS_CannotCastInterface = 'Cannot cast an interface';
+ RPS_CannotCastObject = 'Cannot cast an object';
+ RPS_CapacityLength = 'Capacity < Length';
+ RPS_CanOnlySendLastItem = 'Can only remove last item from stack';
+ RPS_NILInterfaceException = 'Nil interface';
+ RPS_UnknownMethod = 'Unknown method';
+
+
+
+type
+ PPSExportedVar = ^TPSExportedVar;
+ TPSExportedVar = record
+ FName: tbtstring;
+ FNameHash: Longint;
+ FVarNo: Cardinal;
+ end;
+ PRaiseFrame = ^TRaiseFrame;
+ TRaiseFrame = record
+ NextRaise: PRaiseFrame;
+ ExceptAddr: Pointer;
+ ExceptObject: TObject;
+ ExceptionRecord: Pointer;
+ end;
+ TPSExceptionHandler = class
+ CurrProc: TPSInternalProcRec;
+ BasePtr, StackSize: Cardinal;
+ FinallyOffset, ExceptOffset, Finally2Offset, EndOfBlock: Cardinal;
+ ExceptionData: TPSError;
+ ExceptionObject: TObject;
+ ExceptionParam: tbtString;
+ destructor Destroy; override;
+ end;
+ TPSHeader = packed record
+ HDR: Cardinal;
+ PSBuildNo: Cardinal;
+ TypeCount: Cardinal;
+ ProcCount: Cardinal;
+ VarCount: Cardinal;
+ MainProcNo: Cardinal;
+ ImportTableSize: Cardinal;
+ end;
+
+ TPSExportItem = packed record
+ ProcNo: Cardinal;
+ NameLength: Cardinal;
+ DeclLength: Cardinal;
+ end;
+
+ TPSType = packed record
+ BaseType: TPSBaseType;
+ end;
+ TPSProc = packed record
+ Flags: Byte;
+ end;
+
+ TPSVar = packed record
+ TypeNo: Cardinal;
+ Flags: Byte;
+ end;
+ PSpecialProc = ^TSpecialProc;
+ TSpecialProc = record
+ P: TPSOnSpecialProcImport;
+ namehash: Longint;
+ Name: tbtstring;
+ tag: pointer;
+ end;
+
+destructor TPSExceptionHandler.Destroy;
+begin
+ ExceptionObject.Free;
+ inherited;
+end;
+
+procedure P_CM_A; begin end;
+procedure P_CM_CA; begin end;
+procedure P_CM_P; begin end;
+procedure P_CM_PV; begin end;
+procedure P_CM_PO; begin end;
+procedure P_CM_C; begin end;
+procedure P_CM_G; begin end;
+procedure P_CM_CG; begin end;
+procedure P_CM_CNG; begin end;
+procedure P_CM_R; begin end;
+procedure P_CM_ST; begin end;
+procedure P_CM_PT; begin end;
+procedure P_CM_CO; begin end;
+procedure P_CM_CV; begin end;
+procedure P_CM_SP; begin end;
+procedure P_CM_BN; begin end;
+procedure P_CM_VM; begin end;
+procedure P_CM_SF; begin end;
+procedure P_CM_FG; begin end;
+procedure P_CM_PUEXH; begin end;
+procedure P_CM_POEXH; begin end;
+procedure P_CM_IN; begin end;
+procedure P_CM_SPB; begin end;
+procedure P_CM_INC; begin end;
+procedure P_CM_DEC; begin end;
+
+function IntPIFVariantToVariant(Src: pointer; aType: TPSTypeRec; var Dest: Variant): Boolean; forward;
+
+
+procedure Set_Union(Dest, Src: PByteArray; ByteSize: Integer);
+var
+ i: Longint;
+begin
+ for i := ByteSize -1 downto 0 do
+ Dest^[i] := Dest^[i] or Src^[i];
+end;
+
+procedure Set_Diff(Dest, Src: PByteArray; ByteSize: Integer);
+var
+ i: Longint;
+begin
+ for i := ByteSize -1 downto 0 do
+ Dest^[i] := Dest^[i] and not Src^[i];
+end;
+
+procedure Set_Intersect(Dest, Src: PByteArray; ByteSize: Integer);
+var
+ i: Longint;
+begin
+ for i := ByteSize -1 downto 0 do
+ Dest^[i] := Dest^[i] and Src^[i];
+end;
+
+procedure Set_Subset(Dest, Src: PByteArray; ByteSize: Integer; var Val: Boolean);
+var
+ i: Integer;
+begin
+ for i := ByteSize -1 downto 0 do
+ begin
+ if not (Src^[i] and Dest^[i] = Dest^[i]) then
+ begin
+ Val := False;
+ exit;
+ end;
+ end;
+ Val := True;
+end;
+
+procedure Set_Equal(Dest, Src: PByteArray; ByteSize: Integer; var Val: Boolean);
+var
+ i: Longint;
+begin
+ for i := ByteSize -1 downto 0 do
+ begin
+ if Dest^[i] <> Src^[i] then
+ begin
+ Val := False;
+ exit;
+ end;
+ end;
+ val := True;
+end;
+
+procedure Set_membership(Item: Longint; Src: PByteArray; var Val: Boolean);
+begin
+ Val := (Src^[Item shr 3] and (1 shl (Item and 7))) <> 0;
+end;
+
+
+procedure RCIFreeProc(Sender: TPSExec; P: TPSRuntimeClassImporter);
+begin
+ p.Free;
+end;
+
+function Trim(const s: tbtstring): tbtstring;
+begin
+ Result := s;
+ while (Length(result) > 0) and (Result[1] = #32) do Delete(Result, 1, 1);
+ while (Length(result) > 0) and (Result[Length(Result)] = #32) do Delete(Result, Length(Result), 1);
+end;
+(*function FloatToStr(E: Extended): tbtstring;
+begin
+ Result := Sysutils.FloatToStr(e);
+end;*)
+
+//-------------------------------------------------------------------
+
+function Padl(s: tbtstring; i: longInt): tbtstring;
+begin
+ result := StringOfChar(tbtchar(' '), i - length(s)) + s;
+end;
+//-------------------------------------------------------------------
+
+function Padz(s: tbtString; i: longInt): tbtString;
+begin
+ result := StringOfChar(tbtchar('0'), i - length(s)) + s;
+end;
+//-------------------------------------------------------------------
+
+function Padr(s: tbtString; i: longInt): tbtString;
+begin
+ result := s + StringOfChar(tbtchar(' '), i - Length(s));
+end;
+//-------------------------------------------------------------------
+
+{$IFNDEF PS_NOWIDESTRING}
+function wPadl(s: tbtwidestring; i: longInt): tbtwidestring;
+begin
+ result := StringOfChar(tbtwidechar(' '), i - length(s)) + s;
+end;
+//-------------------------------------------------------------------
+
+function wPadz(s: tbtwidestring; i: longInt): tbtwidestring;
+begin
+ result := StringOfChar(tbtwidechar('0'), i - length(s)) + s;
+end;
+//-------------------------------------------------------------------
+
+function wPadr(s: tbtwidestring; i: longInt): tbtwidestring;
+begin
+ result := s + StringOfChar(tbtwidechar(' '), i - Length(s));
+end;
+
+function uPadl(s: tbtunicodestring; i: longInt): tbtunicodestring;
+begin
+ result := StringOfChar(tbtwidechar(' '), i - length(s)) + s;
+end;
+//-------------------------------------------------------------------
+
+function uPadz(s: tbtunicodestring; i: longInt): tbtunicodestring;
+begin
+ result := StringOfChar(tbtwidechar('0'), i - length(s)) + s;
+end;
+//-------------------------------------------------------------------
+
+function uPadr(s: tbtunicodestring; i: longInt): tbtunicodestring;
+begin
+ result := s + StringOfChar(tbtwidechar(' '), i - Length(s));
+end;
+
+{$ENDIF}
+{$IFNDEF PS_NOWIDESTRING}
+function MakeWString(const s: tbtunicodestring): tbtString;
+var
+ i: Longint;
+ e: tbtString;
+ b: boolean;
+begin
+ Result := tbtString(s);
+ i := 1;
+ b := false;
+ while i <= length(result) do
+ begin
+ if Result[i] = '''' then
+ begin
+ if not b then
+ begin
+ b := true;
+ Insert('''', Result, i);
+ inc(i);
+ end;
+ Insert('''', Result, i);
+ inc(i, 2);
+ end else if (Result[i] < #32) or (Result[i] > #255) then
+ begin
+ e := '#'+inttostr(ord(Result[i]));
+ Delete(Result, i, 1);
+ if b then
+ begin
+ b := false;
+ Insert('''', Result, i);
+ inc(i);
+ end;
+ Insert(e, Result, i);
+ inc(i, length(e));
+ end else begin
+ if not b then
+ begin
+ b := true;
+ Insert('''', Result, i);
+ inc(i, 2);
+ end else
+ inc(i);
+ end;
+ end;
+ if b then
+ begin
+ Result := Result + '''';
+ end;
+ if Result = '' then
+ Result := '''''';
+end;
+{$ENDIF}
+function MakeString(const s: tbtString): tbtString;
+var
+ i: Longint;
+ e: tbtString;
+ b: boolean;
+begin
+ Result := s;
+ i := 1;
+ b := false;
+ while i <= length(result) do
+ begin
+ if Result[i] = '''' then
+ begin
+ if not b then
+ begin
+ b := true;
+ Insert('''', Result, i);
+ inc(i);
+ end;
+ Insert('''', Result, i);
+ inc(i, 2);
+ end else if (Result[i] < #32) then
+ begin
+ e := '#'+inttostr(ord(Result[i]));
+ Delete(Result, i, 1);
+ if b then
+ begin
+ b := false;
+ Insert('''', Result, i);
+ inc(i);
+ end;
+ Insert(e, Result, i);
+ inc(i, length(e));
+ end else begin
+ if not b then
+ begin
+ b := true;
+ Insert('''', Result, i);
+ inc(i, 2);
+ end else
+ inc(i);
+ end;
+ end;
+ if b then
+ begin
+ Result := Result + '''';
+ end;
+ if Result = '' then
+ Result := '''''';
+end;
+
+function SafeStr(const s: tbtString): tbtString;
+var
+ i : Longint;
+begin
+ Result := s;
+ for i := 1 to length(s) do
+ begin
+ if s[i] in [#0..#31] then
+ begin
+ Result := Copy(s, 1, i-1);
+ exit;
+ end;
+ end;
+
+end;
+
+function PropertyToString(Instance: TObject; PName: tbtString): tbtString;
+var
+ s: tbtString;
+ i: Longint;
+ PP: PPropInfo;
+begin
+ if PName = '' then
+ begin
+ Result := tbtString(Instance.ClassName);
+ exit;
+ end;
+ while Length(PName) > 0 do
+ begin
+ i := pos(tbtChar('.'), pname);
+ if i = 0 then
+ begin
+ s := Trim(PNAme);
+ pname := '';
+ end else begin
+ s := trim(Copy(PName, 1, i-1));
+ Delete(PName, 1, i);
+ end;
+ pp := GetPropInfo(PTypeInfo(Instance.ClassInfo), string(s));
+ if pp = nil then begin Result := tbtstring(RPS_UnknownIdentifier); exit; end;
+
+
+ case pp^.PropType^.Kind of
+ tkInteger: begin Result := IntToStr(GetOrdProp(Instance, pp)); exit; end;
+ tkChar: begin Result := '#'+IntToStr(GetOrdProp(Instance, pp)); exit; end;
+ tkEnumeration: begin Result := tbtstring(GetEnumName(pp^.PropType{$IFNDEF FPC}{$IFDEF DELPHI3UP}^{$ENDIF}{$ENDIF}, GetOrdProp(Instance, pp))); exit; end;
+ tkFloat: begin Result := FloatToStr(GetFloatProp(Instance, PP)); exit; end;
+ tkString, tkLString: begin Result := ''''+tbtString(GetStrProp(Instance, PP))+''''; exit; end;
+ tkSet: begin Result := '[Set]'; exit; end;
+ tkClass: begin Instance := TObject(GetOrdProp(Instance, pp)); end;
+ tkMethod: begin Result := '[Method]'; exit; end;
+ tkVariant: begin Result := '[Variant]'; exit; end;
+ {$IFDEF DELPHI6UP}
+ {$IFNDEF PS_NOWIDESTRING}
+ tkWString: begin Result := ''''+tbtString(GetWideStrProp(Instance, pp))+''; end; {$ENDIF}
+ {$ENDIF}
+ else begin Result := '[Unknown]'; exit; end;
+ end;
+ if Instance = nil then begin result := 'nil'; exit; end;
+ end;
+ Result := tbtstring(Instance.ClassName);
+end;
+
+function ClassVariantInfo(const pvar: TPSVariantIFC; const PropertyName: tbtString): tbtString;
+begin
+ if pvar.aType.BaseType = btClass then
+ begin
+ if TObject(pvar.Dta^) = nil then
+ Result := 'nil'
+ else
+ Result := PropertyToString(TObject(pvar.Dta^), PropertyName);
+ end else if pvar.atype.basetype = btInterface then
+ Result := 'Interface'
+ else Result := tbtstring(RPS_InvalidType);
+end;
+
+function PSVariantToString(const p: TPSVariantIFC; const ClassProperties: tbtString): tbtString;
+var
+ i, n: Longint;
+begin
+ if p.Dta = nil then
+ begin
+ Result := 'nil';
+ exit;
+ end;
+ if (p.aType.BaseType = btVariant) then
+ begin
+ try
+ if TVarData(p.Dta^).VType = varDispatch then
+ Result := 'Variant(IDispatch)'
+ else if TVarData(p.Dta^).VType = varNull then
+ REsult := 'Null'
+ else if (TVarData(p.Dta^).VType = varOleStr) then
+ {$IFDEF PS_NOWIDESTRING}
+ Result := MakeString(Variant(p.Dta^))
+ {$ELSE}
+ Result := MakeWString(variant(p.dta^))
+ {$ENDIF}
+ else if TVarData(p.Dta^).VType = varString then
+ Result := MakeString(tbtstring(variant(p.Dta^)))
+ else
+ Result := tbtstring(Variant(p.Dta^));
+ except
+ on e: Exception do
+ Result := tbtstring(Format (RPS_Exception, [e.Message]));
+ end;
+ exit;
+ end;
+ case p.aType.BaseType of
+ btProcptr: begin Result := 'Proc: '+inttostr(tbtu32(p.Dta^)); end;
+ btU8: str(tbtu8(p.dta^), Result);
+ btS8: str(tbts8(p.dta^), Result);
+ btU16: str(tbtu16(p.dta^), Result);
+ btS16: str(tbts16(p.dta^), Result);
+ btU32: str(tbtu32(p.dta^), Result);
+ btS32: str(tbts32(p.dta^), Result);
+ btSingle: str(tbtsingle(p.dta^), Result);
+ btDouble: str(tbtdouble(p.dta^), Result);
+ btExtended: str(tbtextended(p.dta^), Result);
+ btString: Result := makestring(tbtString(p.dta^));
+ btPChar:
+ begin
+ if PansiChar(p.dta^) = nil then
+ Result := 'nil'
+ else
+ Result := MakeString(PAnsiChar(p.dta^));
+ end;
+ btchar: Result := MakeString(tbtchar(p.dta^));
+ {$IFNDEF PS_NOWIDESTRING}
+ btwidechar: Result := MakeWString(tbtwidechar(p.dta^));
+ btWideString: Result := MakeWString(tbtwidestring(p.dta^));
+ btUnicodeString: Result := MakeWString(tbtUnicodeString(p.dta^));
+ {$ENDIF}
+ {$IFNDEF PS_NOINT64}btS64: str(tbts64(p.dta^), Result);{$ENDIF}
+ btStaticArray, btArray:
+ begin
+ Result := '';
+ if p.aType.BaseType = btStaticArray then
+ n := TPSTypeRec_StaticArray(p.aType).Size
+ else
+ n := PSDynArrayGetLength(Pointer(p.dta^), p.aType);
+ for i := 0 to n-1 do begin
+ if Result <> '' then
+ Result := Result + ', ';
+ Result := Result + PSVariantToString(PSGetArrayField(p, i), '');
+ end;
+ Result := '[' + Result + ']';
+ end;
+ btRecord:
+ begin
+ Result := '';
+ n := TPSTypeRec_Record(p.aType).FFieldTypes.Count;
+ for i := 0 to n-1 do begin
+ if Result <> '' then
+ Result := Result + ', ';
+ Result := Result + PSVariantToString(PSGetRecField(p, i), '');
+ end;
+ Result := '(' + Result + ')';
+ end;
+ btPointer: Result := 'Nil';
+ btClass, btInterface:
+ begin
+ Result := ClassVariantInfo(p, ClassProperties)
+ end;
+ else
+ Result := tbtString(RPS_Invalid);
+ end;
+end;
+
+
+
+function TIFErrorToString(x: TPSError; const Param: tbtString): tbtString;
+begin
+ Result := PSErrorToString(x,param);
+end;
+
+function PSErrorToString(x: TPSError; const Param: tbtString): tbtString;
+begin
+ case x of
+ ErNoError: Result := tbtString(RPS_NoError);
+ erCannotImport: Result := tbtString(Format (RPS_CannotImport, [Safestr(Param)]));
+ erInvalidType: Result := tbtString(RPS_InvalidType);
+ ErInternalError: Result := tbtString(RPS_InternalError);
+ erInvalidHeader: Result := tbtString(RPS_InvalidHeader);
+ erInvalidOpcode: Result := tbtString(RPS_InvalidOpcode);
+ erInvalidOpcodeParameter: Result := tbtString(RPS_InvalidOpcodeParameter);
+ erNoMainProc: Result := tbtString(RPS_NoMainProc);
+ erOutOfGlobalVarsRange: Result := tbtString(RPS_OutOfGlobalVarsRange);
+ erOutOfProcRange: Result := tbtString(RPS_OutOfProcRange);
+ ErOutOfRange: Result := tbtString(RPS_OutOfRange);
+ erOutOfStackRange: Result := tbtString(RPS_OutOfStackRange);
+ ErTypeMismatch: Result := tbtString(RPS_TypeMismatch);
+ erUnexpectedEof: Result := tbtString(RPS_UnexpectedEof);
+ erVersionError: Result := tbtString(RPS_VersionError);
+ ErDivideByZero: Result := tbtString(RPS_DivideByZero);
+ erMathError: Result := tbtString(RPS_MathError);
+ erCouldNotCallProc: begin Result := tbtString(RPS_CouldNotCallProc); if (Param <> '') then Result := result +' ('+Param+')'; end;
+ erOutofRecordRange: Result := tbtString(RPS_OutofRecordRange);
+ erNullPointerException: Result := tbtString(RPS_NullPointerException);
+ erNullVariantError: Result := tbtString(RPS_NullVariantError);
+ erOutOfMemory: Result := tbtString(RPS_OutOfMemory);
+ erException: Result := tbtString(Format (RPS_Exception, [Param]));
+ erInterfaceNotSupported: Result := tbtString(RPS_InterfaceNotSupported);
+ erCustomError: Result := Param;
+ else
+ Result := tbtString(RPS_UnknownError);
+ end;
+ //
+end;
+
+
+procedure TPSTypeRec.CalcSize;
+begin
+ case BaseType of
+ btVariant: FRealSize := sizeof(Variant);
+ btChar, bts8, btU8: FrealSize := 1 ;
+ {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}bts16, btU16: FrealSize := 2;
+ {$IFNDEF PS_NOWIDESTRING}btWideString,
+ btUnicodeString,
+ {$ENDIF}{$IFNDEF PS_NOINTERFACES}btInterface, {$ENDIF}btSingle, bts32, btU32,
+ btclass, btPChar, btString: FrealSize := PointerSize;
+ btProcPtr: FRealSize := 2 * sizeof(Pointer) + sizeof(Cardinal);
+ btCurrency: FrealSize := Sizeof(Currency);
+ btPointer: FRealSize := 2 * sizeof(Pointer) + sizeof(LongBool); // ptr, type, freewhendone
+ btDouble{$IFNDEF PS_NOINT64}, bts64{$ENDIF}: FrealSize := 8;
+ btExtended: FrealSize := SizeOf(Extended);
+ btReturnAddress: FrealSize := Sizeof(TBTReturnAddress);
+ else
+ FrealSize := 0;
+ end;
+end;
+
+constructor TPSTypeRec.Create(Owner: TPSExec);
+begin
+ inherited Create;
+ FAttributes := TPSRuntimeAttributes.Create(Owner);
+end;
+
+destructor TPSTypeRec.Destroy;
+begin
+ FAttributes.Free;
+ inherited destroy;
+end;
+
+{ TPSTypeRec_Record }
+
+procedure TPSTypeRec_Record.CalcSize;
+begin
+ inherited;
+ FrealSize := TPSTypeRec(FFieldTypes[FFieldTypes.Count-1]).RealSize +
+ IPointer(RealFieldOffsets[RealFieldOffsets.Count -1]);
+end;
+
+constructor TPSTypeRec_Record.Create(Owner: TPSExec);
+begin
+ inherited Create(Owner);
+ FRealFieldOffsets := TPSList.Create;
+ FFieldTypes := TPSList.Create;
+end;
+
+destructor TPSTypeRec_Record.Destroy;
+begin
+ FFieldTypes.Free;
+ FRealFieldOffsets.Free;
+ inherited Destroy;
+end;
+
+
+const
+ RTTISize = sizeof(TPSVariant);
+
+procedure InitializeVariant(p: Pointer; aType: TPSTypeRec);
+var
+ t: TPSTypeRec;
+ i: Longint;
+begin
+ case aType.BaseType of
+ btChar, bts8, btU8: tbtu8(p^) := 0;
+ {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}bts16, btU16: tbtu16(p^) := 0;
+ btSingle, bts32, btU32,
+ btPChar, btString, {$IFNDEF PS_NOWIDESTRING}btUnicodeString, btWideString, {$ENDIF}btClass,
+ btInterface, btArray: Pointer(P^) := nil;
+ btPointer:
+ begin
+ Pointer(p^) := nil;
+ Pointer(Pointer(IPointer(p)+PointerSize)^) := nil;
+ Pointer(Pointer(IPointer(p)+(2*PointerSize))^) := nil;
+ end;
+ btProcPtr:
+ begin
+ Longint(p^) := 0;
+ Pointer(Pointer(IPointer(p)+PointerSize)^) := nil;
+ Pointer(Pointer(IPointer(p)+(2*PointerSize))^) := nil;
+ end;
+ btCurrency: tbtCurrency(P^) := 0;
+ btDouble{$IFNDEF PS_NOINT64}, bts64{$ENDIF}: {$IFNDEF PS_NOINT64}tbtS64(P^) := 0{$ELSE}tbtdouble(p^) := 0 {$ENDIF};
+ btExtended: tbtExtended(p^) := 0;
+ btVariant: Initialize(Variant(p^));
+ btReturnAddress:; // there is no point in initializing a return address
+ btRecord:
+ begin
+ for i := 0 to TPSTypeRec_Record(aType).FFieldTypes.Count -1 do
+ begin
+ t := TPSTypeRec_Record(aType).FieldTypes[i];
+ InitializeVariant(P, t);
+ p := Pointer(IPointer(p) + t.FrealSize);
+ end;
+ end;
+ btStaticArray:
+ begin
+ t := TPSTypeRec_Array(aType).ArrayType;
+ for i := 0 to TPSTypeRec_StaticArray(aType).Size -1 do
+ begin
+ InitializeVariant(p, t);
+ p := Pointer(IPointer(p) + t.RealSize);
+ end;
+ end;
+ btSet:
+ begin
+ FillChar(p^, TPSTypeRec_Set(aType).RealSize, 0);
+ end;
+ end;
+end;
+
+procedure DestroyHeapVariant2(v: Pointer; aType: TPSTypeRec); forward;
+
+const
+ NeedFinalization = [btStaticArray, btRecord, btArray, btPointer, btVariant {$IFNDEF PS_NOINTERFACES}, btInterface{$ENDIF}, btString {$IFNDEF PS_NOWIDESTRING}, btUnicodestring,btWideString{$ENDIF}];
+
+procedure FinalizeVariant(p: Pointer; aType: TPSTypeRec);
+var
+ t: TPSTypeRec;
+ elsize: Cardinal;
+ i, l: Longint;
+ darr: Pointer;
+begin
+ case aType.BaseType of
+ btString: tbtString(p^) := '';
+ {$IFNDEF PS_NOWIDESTRING}
+ btWideString: tbtwidestring(p^) := '';
+ btUnicodeString: tbtunicodestring(p^) := '';
+ {$ENDIF}
+ {$IFNDEF PS_NOINTERFACES}btInterface:
+ begin
+ {$IFNDEF DELPHI3UP}
+ if IUnknown(p^) <> nil then
+ IUnknown(p^).Release;
+ {$ENDIF}
+ IUnknown(p^) := nil;
+ end; {$ENDIF}
+ btVariant:
+ begin
+ try
+ Finalize(Variant(p^));
+ except
+ end;
+ end;
+ btPointer:
+ if Pointer(Pointer(IPointer(p)+PointerSize2)^) <> nil then
+ begin
+ DestroyHeapVariant2(Pointer(p^), Pointer(Pointer(IPointer(p)+PointerSize)^));
+ Pointer(p^) := nil;
+ end;
+ btArray:
+ begin
+ if IPointer(P^) = 0 then exit;
+ darr := Pointer(IPointer(p^) - PointerSize2);
+ if Longint(darr^) < 0 then exit;// refcount < 0 means don't free
+ Dec(Longint(darr^));
+ if Longint(darr^) <> 0 then exit;
+ t := TPSTypeRec_Array(aType).ArrayType;
+ elsize := t.RealSize;
+ darr := Pointer(IPointer(darr) + PointerSize);
+ l := Longint(darr^);
+ darr := Pointer(IPointer(darr) + PointerSize);
+ case t.BaseType of
+ btString, {$IFNDEF PS_NOWIDESTRING}
+ btUnicodeString, btWideString, {$ENDIF}{$IFNDEF PS_NOINTERFACES}btInterface, {$ENDIF}btArray, btStaticArray,
+ btRecord, btPointer, btVariant:
+ begin
+ for i := 0 to l -1 do
+ begin
+ FinalizeVariant(darr, t);
+ darr := Pointer(IPointer(darr) + elsize);
+ end;
+ end;
+ end;
+ FreeMem(Pointer(IPointer(p^) - IPointer(PointerSize2)), IPointer(Cardinal(l) * elsize) + IPointer(PointerSize2));
+ Pointer(P^) := nil;
+ end;
+ btRecord:
+ begin
+ for i := 0 to TPSTypeRec_Record(aType).FFieldTypes.Count -1 do
+ begin
+ t := TPSTypeRec_Record(aType).FieldTypes[i];
+ case t.BaseType of
+ btString, {$IFNDEF PS_NOWIDESTRING}btUnicodeString, btWideString, {$ENDIF}{$IFNDEF PS_NOINTERFACES}btInterface, {$ENDIF}btArray, btStaticArray,
+ btRecord: FinalizeVariant(p, t);
+ end;
+ p := Pointer(IPointer(p) + t.FrealSize);
+ end;
+ end;
+ btStaticArray:
+ begin
+ t := TPSTypeRec_Array(aType).ArrayType;
+ case t.BaseType of
+ btString, {$IFNDEF PS_NOWIDESTRING}btUnicodeString, btWideString, {$ENDIF}{$IFNDEF PS_NOINTERFACES}btInterface, {$ENDIF}btArray, btStaticArray,
+ btRecord: ;
+ else Exit;
+ end;
+ for i := 0 to TPSTypeRec_StaticArray(aType).Size -1 do
+ begin
+ FinalizeVariant(p, t);
+ p := Pointer(IPointer(p) + t.RealSize);
+ end;
+ end;
+ end;
+end;
+
+function CreateHeapVariant2(aType: TPSTypeRec): Pointer;
+begin
+ GetMem(Result, aType.RealSize);
+ InitializeVariant(Result, aType);
+end;
+
+procedure DestroyHeapVariant2(v: Pointer; aType: TPSTypeRec);
+begin
+ if v = nil then exit;
+ if atype.BaseType in NeedFinalization then
+ FinalizeVariant(v, aType);
+ FreeMem(v, aType.RealSize);
+end;
+
+
+function CreateHeapVariant(aType: TPSTypeRec): PPSVariant;
+var
+ aSize: Longint;
+begin
+ aSize := aType.RealSize + RTTISize;
+ GetMem(Result, aSize);
+ Result.FType := aType;
+ InitializeVariant(Pointer(IPointer(Result)+PointerSize), aType);
+end;
+
+procedure DestroyHeapVariant(v: PPSVariant);
+begin
+ if v = nil then exit;
+ if v.FType.BaseType in NeedFinalization then
+ FinalizeVariant(Pointer(IPointer(v)+PointerSize), v.FType);
+ FreeMem(v, v.FType.RealSize + RTTISize);
+end;
+
+procedure FreePSVariantList(l: TPSList);
+var
+ i: Longint;
+begin
+ for i:= l.count -1 downto 0 do
+ DestroyHeapVariant(l[i]);
+ l.free;
+end;
+
+procedure FreePIFVariantList(l: TPSList);
+begin
+ FreePsVariantList(l);
+end;
+
+{ TPSExec }
+
+procedure TPSExec.ClearFunctionList;
+var
+ x: PProcRec;
+ l: Longint;
+begin
+ for l := FAttributeTypes.Count -1 downto 0 do
+ begin
+ TPSAttributeType(FAttributeTypes.Data^[l]).Free;
+ end;
+ FAttributeTypes.Clear;
+
+ for l := 0 to FRegProcs.Count - 1 do
+ begin
+ x := FRegProcs.Data^[l];
+ if @x^.FreeProc <> nil then x^.FreeProc(Self, x);
+ Dispose(x);
+ end;
+ FRegProcs.Clear;
+ RegisterStandardProcs;
+end;
+
+class function TPSExec.About: tbtString;
+begin
+ Result := 'RemObjects Pascal Script. Copyright (c) 2004-2009 by RemObjects Software';
+end;
+
+procedure TPSExec.Cleanup;
+var
+ I: Longint;
+ p: Pointer;
+begin
+ if FStatus <> isLoaded then
+ exit;
+ FStack.Clear;
+ FTempVars.Clear;
+ for I := Longint(FGlobalVars.Count) - 1 downto 0 do
+ begin
+ p := FGlobalVars.Items[i];
+ if PIFTypeRec(P^).BaseType in NeedFinalization then
+ FinalizeVariant(Pointer(IPointer(p)+PointerSize), Pointer(P^));
+ InitializeVariant(Pointer(IPointer(p)+PointerSize), Pointer(P^));
+ end;
+end;
+
+procedure TPSExec.Clear;
+var
+ I: Longint;
+ temp: PPSResource;
+ Proc: TPSResourceFreeProc;
+ pp: TPSExceptionHandler;
+begin
+ for i := Longint(FExceptionStack.Count) -1 downto 0 do
+ begin
+ pp := FExceptionStack.Data^[i];
+ pp.Free;
+ end;
+ for i := Longint(FResources.Count) -1 downto 0 do
+ begin
+ Temp := FResources.Data^[i];
+ Proc := Temp^.Proc;
+ Proc(Self, Temp^.P);
+ Dispose(Temp);
+ end;
+ for i := Longint(FExportedVars.Count) -1 downto 0 do
+ Dispose(PPSExportedVar(FExportedVars.Data^[I]));
+ for I := Longint(FProcs.Count) - 1downto 0 do
+ TPSProcRec(FProcs.Data^[i]).Destroy;
+ FProcs.Clear;
+ FGlobalVars.Clear;
+ FStack.Clear;
+ for I := Longint(FTypes.Count) - 1downto 0 do
+ TPSTypeRec(FTypes.Data^[i]).Free;
+ FTypes.Clear;
+ FStatus := isNotLoaded;
+ FResources.Clear;
+ FExportedVars.Clear;
+ FExceptionStack.Clear;
+ FCurrStackBase := InvalidVal;
+end;
+
+constructor TPSExec.Create;
+begin
+ inherited Create;
+ FAttributeTypes := TPSList.Create;
+ FExceptionStack := TPSList.Create;
+ FCallCleanup := False;
+ FResources := TPSList.Create;
+ FTypes := TPSList.Create;
+ FProcs := TPSList.Create;
+ FGlobalVars := TPSStack.Create;
+ FTempVars := TPSStack.Create;
+ FMainProc := 0;
+ FStatus := isNotLoaded;
+ FRegProcs := TPSList.Create;
+ FExportedVars := TPSList.create;
+ FSpecialProcList := TPSList.Create;
+ RegisterStandardProcs;
+ FReturnAddressType := TPSTypeRec.Create(self);
+ FReturnAddressType.BaseType := btReturnAddress;
+ FReturnAddressType.CalcSize;
+ FVariantType := TPSTypeRec.Create(self);
+ FVariantType.BaseType := btVariant;
+ FVariantType.CalcSize;
+ FVariantArrayType := TPSTypeRec_Array.Create(self);
+ FVariantArrayType.BaseType := btArray;
+ FVariantArrayType.CalcSize;
+ TPSTypeRec_Array(FVariantArrayType).ArrayType := FVariantType;
+ FStack := TPSStack.Create;
+end;
+
+destructor TPSExec.Destroy;
+var
+ I: Longint;
+ x: PProcRec;
+ P: PSpecialProc;
+begin
+ Clear;
+ FReturnAddressType.Free;
+ FVariantType.Free;
+ FVariantArrayType.Free;
+
+ if ExObject <> nil then ExObject.Free;
+ for I := FSpecialProcList.Count -1 downto 0 do
+ begin
+ P := FSpecialProcList.Data^[I];
+ Dispose(p);
+ end;
+ FResources.Free;
+ FExportedVars.Free;
+ FTempVars.Free;
+ FStack.Free;
+ FGlobalVars.Free;
+ FProcs.Free;
+ FTypes.Free;
+ FSpecialProcList.Free;
+ for i := FRegProcs.Count - 1 downto 0 do
+ begin
+ x := FRegProcs.Data^[i];
+ if @x^.FreeProc <> nil then x^.FreeProc(Self, x);
+ Dispose(x);
+ end;
+ FRegProcs.Free;
+ FExceptionStack.Free;
+ for i := FAttributeTypes.Count -1 downto 0 do
+ begin
+ TPSAttributeType(FAttributeTypes[i]).Free;
+ end;
+ FAttributeTypes.Free;
+ inherited Destroy;
+end;
+
+procedure TPSExec.ExceptionProc(proc, Position: Cardinal; Ex: TPSError; const s: tbtString; NewObject: TObject);
+var
+ d, l: Longint;
+ pp: TPSExceptionHandler;
+begin
+ ExProc := proc;
+ ExPos := Position;
+ ExEx := Ex;
+ ExParam := s;
+ if ExObject <> nil then
+ ExObject.Free;
+ ExObject := NewObject;
+ if Ex = eNoError then Exit;
+ for d := FExceptionStack.Count -1 downto 0 do
+ begin
+ pp := FExceptionStack[d];
+ if Cardinal(FStack.Count) > pp.StackSize then
+ begin
+ for l := Longint(FStack.count) -1 downto Longint(pp.StackSize) do
+ FStack.Pop;
+ end;
+ if pp.CurrProc = nil then // no point in continuing
+ begin
+ pp.Free;
+ FExceptionStack.DeleteLast;
+
+ FCurrStackBase := InvalidVal;
+ FStatus := isPaused;
+ exit;
+ end;
+ FCurrProc := pp.CurrProc;
+ FData := FCurrProc.Data;
+ FDataLength := FCurrProc.Length;
+
+ FCurrStackBase := pp.BasePtr;
+ if pp.FinallyOffset <> InvalidVal then
+ begin
+ FCurrentPosition := pp.FinallyOffset;
+ pp.FinallyOffset := InvalidVal;
+ Exit;
+ end else if (pp.ExceptOffset <> InvalidVal) and (pp.ExceptOffset <> Cardinal(InvalidVal -1)) then
+ begin
+ FCurrentPosition := pp.ExceptOffset;
+ pp.ExceptOffset := Cardinal(InvalidVal -1);
+ pp.ExceptionObject := ExObject;
+ pp.ExceptionData := ExEx;
+ pp.ExceptionParam := ExParam;
+ ExObject := nil;
+ ExEx := ENoError;
+ Exit;
+ end else if pp.Finally2Offset <> InvalidVal then
+ begin
+ FCurrentPosition := pp.Finally2Offset;
+ pp.Finally2Offset := InvalidVal;
+ Exit;
+ end;
+ pp.Free;
+ FExceptionStack.DeleteLast;
+ end;
+ if FStatus <> isNotLoaded then
+ FStatus := isPaused;
+end;
+
+function LookupProc(List: TPSList; const Name: ShortString): PProcRec;
+var
+ h, l: Longint;
+ p: PProcRec;
+begin
+ h := MakeHash(Name);
+ for l := List.Count - 1 downto 0 do
+ begin
+ p := List.Data^[l];
+ if (p^.Hash = h) and (p^.Name = Name) then
+ begin
+ Result := List[l];
+ exit;
+ end;
+ end;
+ Result := nil;
+end;
+
+function TPSExec.ImportProc(const Name: ShortString; proc: TPSExternalProcRec): Boolean;
+var
+ u: PProcRec;
+ fname: tbtString;
+ I, fnh: Longint;
+ P: PSpecialProc;
+
+begin
+ if name = '' then
+ begin
+ fname := proc.Decl;
+ fname := copy(fname, 1, pos(tbtchar(':'), fname)-1);
+ fnh := MakeHash(fname);
+ for I := FSpecialProcList.Count -1 downto 0 do
+ begin
+ p := FSpecialProcList[I];
+ IF (p^.name = '') or ((p^.namehash = fnh) and (p^.name = fname)) then
+ begin
+ if p^.P(Self, Proc, p^.tag) then
+ begin
+ Result := True;
+ exit;
+ end;
+ end;
+ end;
+ Result := FAlse;
+ exit;
+ end;
+ u := LookupProc(FRegProcs, Name);
+ if u = nil then begin
+ Result := False;
+ exit;
+ end;
+ proc.ProcPtr := u^.ProcPtr;
+ proc.Ext1 := u^.Ext1;
+ proc.Ext2 := u^.Ext2;
+ Result := True;
+end;
+
+function TPSExec.RegisterFunctionName(const Name: tbtString; ProcPtr: TPSProcPtr; Ext1, Ext2: Pointer): PProcRec;
+var
+ p: PProcRec;
+ s: tbtString;
+begin
+ s := FastUppercase(Name);
+ New(p);
+ p^.Name := s;
+ p^.Hash := MakeHash(s);
+ p^.ProcPtr := ProcPtr;
+ p^.FreeProc := nil;
+ p.Ext1 := Ext1;
+ p^.Ext2 := Ext2;
+ FRegProcs.Add(p);
+ Result := P;
+end;
+
+function TPSExec.LoadData(const s: tbtString): Boolean;
+var
+ HDR: TPSHeader;
+ Pos: Cardinal;
+
+ function read(var Data; Len: Cardinal): Boolean;
+ begin
+ if Longint(Pos + Len) <= Length(s) then begin
+ Move(s[Pos + 1], Data, Len);
+ Pos := Pos + Len;
+ read := True;
+ end
+ else
+ read := False;
+ end;
+ function ReadAttributes(Dest: TPSRuntimeAttributes): Boolean;
+ var
+ Count: Cardinal;
+ i: Integer;
+
+ function ReadAttrib: Boolean;
+ var
+ NameLen: Longint;
+ Name: tbtString;
+ TypeNo: Cardinal;
+ i, h, FieldCount: Longint;
+ att: TPSRuntimeAttribute;
+ varp: PIFVariant;
+
+ begin
+ if (not Read(NameLen, 4)) or (NameLen > Length(s) - Longint(Pos)) then
+ begin
+ CMD_Err(ErOutOfRange);
+ Result := false;
+ exit;
+ end;
+ SetLength(Name, NameLen);
+ if not Read(Name[1], NameLen) then
+ begin
+ CMD_Err(ErOutOfRange);
+ Result := false;
+ exit;
+ end;
+ if not Read(FieldCount, 4) then
+ begin
+ CMD_Err(ErOutOfRange);
+ Result := false;
+ exit;
+ end;
+ att := Dest.Add;
+ att.AttribType := Name;
+ att.AttribTypeHash := MakeHash(att.AttribType);
+ for i := 0 to FieldCount -1 do
+ begin
+ if (not Read(TypeNo, 4)) or (TypeNo >= Cardinal(FTypes.Count)) then
+ begin
+ CMD_Err(ErOutOfRange);
+ Result := false;
+ exit;
+ end;
+
+ varp := att.AddValue(FTypes[TypeNo]);
+ case VarP^.FType.BaseType of
+ btSet:
+ begin
+ if not read(PPSVariantSet(varp).Data, TPSTypeRec_Set(varp.FType).aByteSize) then
+ begin
+ CMD_Err(erOutOfRange);
+
+ DestroyHeapVariant(VarP);
+ Result := False;
+ exit;
+ end;
+ end;
+ bts8, btchar, btU8: if not read(PPSVariantU8(VarP)^.data, 1) then
+ begin
+ CMD_Err(erOutOfRange);
+ DestroyHeapVariant(VarP);
+ Result := False;
+ exit;
+ end;
+ bts16, {$IFNDEF PS_NOWIDESTRING}btwidechar,{$ENDIF} btU16: if not read(PPSVariantU16(Varp)^.Data, SizeOf(TbtU16)) then begin
+ CMD_Err(ErOutOfRange);
+ DestroyHeapVariant(VarP);
+ Result := False;
+ exit;
+ end;
+ bts32, btU32:
+ begin
+ if FCurrentPosition + 3 >= FDataLength then
+ begin
+ Cmd_Err(erOutOfRange);
+ DestroyHeapVariant(VarP);
+ Result := False;
+ exit;;
+ end;
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ PPSVariantU32(varp)^.Data := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+ {$else}
+ PPSVariantU32(varp)^.Data := Cardinal((@FData^[FCurrentPosition])^);
+ {$endif}
+ Inc(FCurrentPosition, 4);
+ end;
+ btProcPtr:
+ begin
+ if FCurrentPosition + 3 >= FDataLength then
+ begin
+ Cmd_Err(erOutOfRange);
+ DestroyHeapVariant(VarP);
+ Result := False;
+ exit;;
+ end;
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ PPSVariantU32(varp)^.Data := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+ {$else}
+ PPSVariantU32(varp)^.Data := Cardinal((@FData^[FCurrentPosition])^);
+ {$endif}
+ if PPSVariantU32(varp)^.Data = 0 then
+ begin
+ PPSVariantProcPtr(varp)^.Ptr := nil;
+ PPSVariantProcPtr(varp)^.Self := nil;
+ end;
+ Inc(FCurrentPosition, 4);
+ end;
+ {$IFNDEF PS_NOINT64}
+ bts64: if not read(PPSVariantS64(VarP)^.Data, sizeof(tbts64)) then
+ begin
+ CMD_Err(erOutOfRange);
+ DestroyHeapVariant(VarP);
+ Result := False;
+ exit;
+ end;
+ {$ENDIF}
+ btSingle: if not read(PPSVariantSingle(VarP)^.Data, SizeOf(TbtSingle))
+ then begin
+ CMD_Err(erOutOfRange);
+ DestroyHeapVariant(VarP);
+ Result := False;
+ exit;
+ end;
+ btDouble: if not read(PPSVariantDouble(varp)^.Data, SizeOf(TbtDouble))
+ then begin
+ CMD_Err(erOutOfRange);
+ DestroyHeapVariant(VarP);
+ Result := False;
+ exit;
+ end;
+ btExtended: if not read(PPSVariantExtended(varp)^.Data, SizeOf(TbtExtended))
+ then begin
+ CMD_Err(erOutOfRange);
+ DestroyHeapVariant(VarP);
+ Result := False;
+ exit;
+ end;
+ btCurrency: if not read(PPSVariantExtended(varp)^.Data, SizeOf(tbtCurrency))
+ then begin
+ CMD_Err(erOutOfRange);
+ DestroyHeapVariant(VarP);
+ Result := False;
+ exit;
+ end;
+ btPchar, btString:
+ begin
+ if not read(NameLen, 4) then
+ begin
+ Cmd_Err(erOutOfRange);
+ DestroyHeapVariant(VarP);
+ Result := False;
+ exit;
+ end;
+ Inc(FCurrentPosition, 4);
+ SetLength(PPSVariantAString(varp)^.Data, NameLen);
+ if not read(PPSVariantAString(varp)^.Data[1], NameLen) then begin
+ CMD_Err(erOutOfRange);
+ DestroyHeapVariant(VarP);
+ Result := False;
+ exit;
+ end;
+ end;
+ {$IFNDEF PS_NOWIDESTRING}
+ btWidestring:
+ begin
+ if not read(NameLen, 4) then
+ begin
+ Cmd_Err(erOutOfRange);
+ DestroyHeapVariant(VarP);
+ Result := False;
+ exit;
+ end;
+ Inc(FCurrentPosition, 4);
+ SetLength(PPSVariantWString(varp).Data, NameLen);
+ if not read(PPSVariantWString(varp).Data[1], NameLen*2) then begin
+ CMD_Err(erOutOfRange);
+ DestroyHeapVariant(VarP);
+ Result := False;
+ exit;
+ end;
+ end;
+ btUnicodeString:
+ begin
+ if not read(NameLen, 4) then
+ begin
+ Cmd_Err(erOutOfRange);
+ DestroyHeapVariant(VarP);
+ Result := False;
+ exit;
+ end;
+ Inc(FCurrentPosition, 4);
+ SetLength(PPSVariantUString(varp).Data, NameLen);
+ if not read(PPSVariantUString(varp).Data[1], NameLen*2) then begin
+ CMD_Err(erOutOfRange);
+ DestroyHeapVariant(VarP);
+ Result := False;
+ exit;
+ end;
+ end;
+ {$ENDIF}
+ else begin
+ CMD_Err(erInvalidType);
+ DestroyHeapVariant(VarP);
+ Result := False;
+ exit;
+ end;
+ end;
+ end;
+ h := MakeHash(att.AttribType);
+ for i := FAttributeTypes.Count -1 downto 0 do
+ begin
+ if (TPSAttributeType(FAttributeTypes.Data^[i]).TypeNameHash = h) and
+ (TPSAttributeType(FAttributeTypes.Data^[i]).TypeName = att.AttribType) then
+ begin
+ if not TPSAttributeType(FAttributeTypes.Data^[i]).UseProc(Self, att.AttribType, Att) then
+ begin
+ Result := False;
+ exit;
+ end;
+ end;
+ end;
+ Result := True;
+ end;
+
+
+ begin
+ if not Read(Count, 4) then
+ begin
+ CMD_Err(erOutofRange);
+ Result := false;
+ exit;
+ end;
+ for i := 0 to Count -1 do
+ begin
+ if not ReadAttrib then
+ begin
+ Result := false;
+ exit;
+ end;
+ end;
+ Result := True;
+ end;
+
+{$WARNINGS OFF}
+
+ function LoadTypes: Boolean;
+ var
+ currf: TPSType;
+ Curr: PIFTypeRec;
+ fe: Boolean;
+ l2, l: Longint;
+ d: Cardinal;
+
+ function resolve(Dta: TPSTypeRec_Record): Boolean;
+ var
+ offs, l: Longint;
+ begin
+ offs := 0;
+ for l := 0 to Dta.FieldTypes.Count -1 do
+ begin
+ Dta.RealFieldOffsets.Add(Pointer(offs));
+ offs := offs + TPSTypeRec(Dta.FieldTypes[l]).RealSize;
+ end;
+ Result := True;
+ end;
+ begin
+ LoadTypes := True;
+ for l := 0 to HDR.TypeCount - 1 do begin
+ if not read(currf, SizeOf(currf)) then begin
+ cmd_err(erUnexpectedEof);
+ LoadTypes := False;
+ exit;
+ end;
+ if (currf.BaseType and 128) <> 0 then begin
+ fe := True;
+ currf.BaseType := currf.BaseType - 128;
+ end else
+ fe := False;
+ case currf.BaseType of
+ {$IFNDEF PS_NOINT64}bts64, {$ENDIF}
+ btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btCurrency,
+ btExtended, btString, btPointer, btPChar,
+ btVariant, btChar{$IFNDEF PS_NOWIDESTRING}, btUnicodeString, btWideString, btWideChar{$ENDIF}: begin
+ curr := TPSTypeRec.Create(self);
+ Curr.BaseType := currf.BaseType;
+ FTypes.Add(Curr);
+ end;
+ btClass:
+ begin
+ Curr := TPSTypeRec_Class.Create(self);
+ if (not Read(d, 4)) or (d > 255) then
+ begin
+ curr.Free;
+ cmd_err(erUnexpectedEof);
+ LoadTypes := False;
+ exit;
+ end;
+ setlength(TPSTypeRec_Class(Curr).FCN, d);
+ if not Read(TPSTypeRec_Class(Curr).FCN[1], d) then
+ begin
+ curr.Free;
+ cmd_err(erUnexpectedEof);
+ LoadTypes := False;
+ exit;
+ end;
+ Curr.BaseType := currf.BaseType;
+ FTypes.Add(Curr);
+ end;
+ btProcPtr:
+ begin
+ Curr := TPSTypeRec_ProcPtr.Create(self);
+ if (not Read(d, 4)) or (d > 255) then
+ begin
+ curr.Free;
+ cmd_err(erUnexpectedEof);
+ LoadTypes := False;
+ exit;
+ end;
+ setlength(TPSTypeRec_ProcPtr(Curr).FParamInfo, d);
+ if not Read(TPSTypeRec_ProcPtr(Curr).FParamInfo[1], d) then
+ begin
+ curr.Free;
+ cmd_err(erUnexpectedEof);
+ LoadTypes := False;
+ exit;
+ end;
+ Curr.BaseType := currf.BaseType;
+ FTypes.Add(Curr);
+ end;
+{$IFNDEF PS_NOINTERFACES}
+ btInterface:
+ begin
+ Curr := TPSTypeRec_Interface.Create(self);
+ if not Read(TPSTypeRec_Interface(Curr).FGUID, Sizeof(TGuid)) then
+ begin
+ curr.Free;
+ cmd_err(erUnexpectedEof);
+ LoadTypes := False;
+ exit;
+ end;
+ Curr.BaseType := currf.BaseType;
+ FTypes.Add(Curr);
+ end;
+{$ENDIF}
+ btSet:
+ begin
+ Curr := TPSTypeRec_Set.Create(self);
+ if not Read(d, 4) then
+ begin
+ curr.Free;
+ cmd_err(erUnexpectedEof);
+ LoadTypes := False;
+ exit;
+ end;
+ if (d > 256) then
+ begin
+ curr.Free;
+ cmd_err(erTypeMismatch);
+ LoadTypes := False;
+ exit;
+ end;
+
+ TPSTypeRec_Set(curr).aBitSize := d;
+ TPSTypeRec_Set(curr).aByteSize := TPSTypeRec_Set(curr).aBitSize shr 3;
+ if (TPSTypeRec_Set(curr).aBitSize and 7) <> 0 then inc(TPSTypeRec_Set(curr).fbytesize);
+ Curr.BaseType := currf.BaseType;
+ FTypes.Add(Curr);
+ end;
+ btStaticArray:
+ begin
+ curr := TPSTypeRec_StaticArray.Create(self);
+ if not Read(d, 4) then
+ begin
+ curr.Free;
+ cmd_err(erUnexpectedEof);
+ LoadTypes := False;
+ exit;
+ end;
+ if (d >= FTypes.Count) then
+ begin
+ curr.Free;
+ cmd_err(erTypeMismatch);
+ LoadTypes := False;
+ exit;
+ end;
+ TPSTypeRec_StaticArray(curr).ArrayType := FTypes[d];
+ if not Read(d, 4) then
+ begin
+ curr.Free;
+ cmd_err(erUnexpectedEof);
+ LoadTypes := False;
+ exit;
+ end;
+ if d > (MaxInt div 4) then
+ begin
+ curr.Free;
+ cmd_err(erUnexpectedEof);
+ LoadTypes := False;
+ exit;
+ end;
+ TPSTypeRec_StaticArray(curr).Size := d;
+ if not Read(d,4) then //<-additional StartOffset
+ begin
+ curr.Free;
+ cmd_err(erUnexpectedEof);
+ LoadTypes:=false;
+ Exit;
+ end;
+ TPSTypeRec_StaticArray(curr).StartOffset:=d;
+
+ Curr.BaseType := currf.BaseType;
+ FTypes.Add(Curr);
+ end;
+ btArray: begin
+ Curr := TPSTypeRec_Array.Create(self);
+ if not read(d, 4) then
+ begin // Read type
+ curr.Free;
+ cmd_err(erUnexpectedEof);
+ LoadTypes := False;
+ exit;
+ end;
+ if (d >= FTypes.Count) then
+ begin
+ curr.Free;
+ cmd_err(erTypeMismatch);
+ LoadTypes := False;
+ exit;
+ end;
+ Curr.BaseType := currf.BaseType;
+ TPSTypeRec_Array(curr).ArrayType := FTypes[d];
+ FTypes.Add(Curr);
+ end;
+ btRecord:
+ begin
+ curr := TPSTypeRec_Record.Create(self);
+ if not read(d, 4) or (d = 0) then
+ begin
+ curr.Free;
+ cmd_err(erUnexpectedEof);
+ LoadTypes := false;
+ exit;
+ end;
+ while d > 0 do
+ begin
+ if not Read(l2, 4) then
+ begin
+ curr.Free;
+ cmd_err(erUnexpectedEof);
+ LoadTypes := false;
+ exit;
+ end;
+ if Cardinal(l2) >= FTypes.Count then
+ begin
+ curr.Free;
+ cmd_err(ErOutOfRange);
+ LoadTypes := false;
+ exit;
+ end;
+ TPSTypeRec_Record(curR).FFieldTypes.Add(FTypes[l2]);
+ Dec(D);
+ end;
+ if not resolve(TPSTypeRec_Record(curr)) then
+ begin
+ curr.Free;
+ cmd_err(erInvalidType);
+ LoadTypes := False;
+ exit;
+ end;
+ Curr.BaseType := currf.BaseType;
+ FTypes.Add(Curr);
+ end;
+ else begin
+ LoadTypes := False;
+ CMD_Err(erInvalidType);
+ exit;
+ end;
+ end;
+ if fe then begin
+ if not read(d, 4) then begin
+ cmd_err(erUnexpectedEof);
+ LoadTypes := False;
+ exit;
+ end;
+ if d > PSAddrNegativeStackStart then
+ begin
+ cmd_err(erInvalidType);
+ LoadTypes := False;
+ exit;
+ end;
+ SetLength(Curr.FExportName, d);
+ if not read(Curr.fExportName[1], d) then
+ begin
+ cmd_err(erUnexpectedEof);
+ LoadTypes := False;
+ exit;
+ end;
+ Curr.ExportNameHash := MakeHash(Curr.ExportName);
+ end;
+ curr.CalcSize;
+ if HDR.PSBuildNo >= 21 then // since build 21 we support attributes
+ begin
+ if not ReadAttributes(Curr.Attributes) then
+ begin
+ LoadTypes := False;
+ exit;
+ end;
+ end;
+ end;
+ end;
+
+ function LoadProcs: Boolean;
+ var
+ Rec: TPSProc;
+ n: tbtString;
+ b: Byte;
+ l, L2, L3: Longint;
+ Curr: TPSProcRec;
+ begin
+ LoadProcs := True;
+ for l := 0 to HDR.ProcCount - 1 do begin
+ if not read(Rec, SizeOf(Rec)) then begin
+ cmd_err(erUnexpectedEof);
+ LoadProcs := False;
+ exit;
+ end;
+ if (Rec.Flags and 1) <> 0 then
+ begin
+ Curr := TPSExternalProcRec.Create(Self);
+ if not read(b, 1) then begin
+ Curr.Free;
+ cmd_err(erUnexpectedEof);
+ LoadProcs := False;
+ exit;
+ end;
+ SetLength(n, b);
+ if not read(n[1], b) then begin
+ Curr.Free;
+ cmd_err(erUnexpectedEof);
+ LoadProcs := False;
+ exit;
+ end;
+ TPSExternalProcRec(Curr).Name := n;
+ if (Rec.Flags and 3 = 3) then
+ begin
+ if (not Read(L2, 4)) or (L2 > Length(s) - Pos) then
+ begin
+ Curr.Free;
+ cmd_err(erUnexpectedEof);
+ LoadProcs := False;
+ exit;
+ end;
+ SetLength(n, L2);
+ Read(n[1], L2); // no check is needed
+ TPSExternalProcRec(Curr).FDecl := n;
+ end;
+ if not ImportProc(TPSExternalProcRec(Curr).Name, TPSExternalProcRec(Curr)) then begin
+ if TPSExternalProcRec(Curr).Name <> '' then
+ CMD_Err2(erCannotImport, TPSExternalProcRec(Curr).Name)
+ else
+ CMD_Err2(erCannotImport, TPSExternalProcRec(curr).Decl);
+ Curr.Free;
+ LoadProcs := False;
+ exit;
+ end;
+ end else begin
+ Curr := TPSInternalProcRec.Create(Self);
+ if not read(L2, 4) then begin
+ Curr.Free;
+ cmd_err(erUnexpectedEof);
+ LoadProcs := False;
+ exit;
+ end;
+ if not read(L3, 4) then begin
+ Curr.Free;
+ cmd_err(erUnexpectedEof);
+ LoadProcs := False;
+ exit;
+ end;
+ if (L2 < 0) or (L2 >= Length(s)) or (L2 + L3 > Length(s)) or (L3 = 0) then begin
+ Curr.Free;
+ cmd_err(erUnexpectedEof);
+ LoadProcs := False;
+ exit;
+ end;
+
+ GetMem(TPSInternalProcRec(Curr).FData, L3);
+ Move(s[L2 + 1], TPSInternalProcRec(Curr).FData^, L3);
+ TPSInternalProcRec(Curr).FLength := L3;
+ if (Rec.Flags and 2) <> 0 then begin // exported
+ if not read(L3, 4) then begin
+ Curr.Free;
+ cmd_err(erUnexpectedEof);
+ LoadProcs := False;
+ exit;
+ end;
+ if L3 > PSAddrNegativeStackStart then begin
+ Curr.Free;
+ cmd_err(erUnexpectedEof);
+ LoadProcs := False;
+ exit;
+ end;
+ SetLength(TPSInternalProcRec(Curr).FExportName, L3);
+ if not read(TPSInternalProcRec(Curr).FExportName[1], L3) then begin
+ Curr.Free;
+ cmd_err(erUnexpectedEof);
+ LoadProcs := False;
+ exit;
+ end;
+ if not read(L3, 4) then begin
+ Curr.Free;
+ cmd_err(erUnexpectedEof);
+ LoadProcs := False;
+ exit;
+ end;
+ if L3 > PSAddrNegativeStackStart then begin
+ Curr.Free;
+ cmd_err(erUnexpectedEof);
+ LoadProcs := False;
+ exit;
+ end;
+ SetLength(TPSInternalProcRec(Curr).FExportDecl, L3);
+ if not read(TPSInternalProcRec(Curr).FExportDecl[1], L3) then begin
+ Curr.Free;
+ cmd_err(erUnexpectedEof);
+ LoadProcs := False;
+ exit;
+ end;
+ TPSInternalProcRec(Curr).FExportNameHash := MakeHash(TPSInternalProcRec(Curr).ExportName);
+ end;
+ end;
+ if (Rec.Flags and 4) <> 0 then
+ begin
+ if not ReadAttributes(Curr.Attributes) then
+ begin
+ Curr.Free;
+ LoadProcs := False;
+ exit;
+ end;
+ end;
+ FProcs.Add(Curr);
+ end;
+ end;
+{$WARNINGS ON}
+
+ function LoadVars: Boolean;
+ var
+ l, n: Longint;
+ e: PPSExportedVar;
+ Rec: TPSVar;
+ Curr: PIfVariant;
+ begin
+ LoadVars := True;
+ for l := 0 to HDR.VarCount - 1 do begin
+ if not read(Rec, SizeOf(Rec)) then begin
+ cmd_err(erUnexpectedEof);
+ LoadVars := False;
+ exit;
+ end;
+ if Rec.TypeNo >= HDR.TypeCount then begin
+ cmd_err(erInvalidType);
+ LoadVars := False;
+ exit;
+ end;
+ Curr := FGlobalVars.PushType(FTypes.Data^[Rec.TypeNo]);
+ if Curr = nil then begin
+ cmd_err(erInvalidType);
+ LoadVars := False;
+ exit;
+ end;
+ if (Rec.Flags and 1) <> 0 then
+ begin
+ if not read(n, 4) then begin
+ cmd_err(erUnexpectedEof);
+ LoadVars := False;
+ exit;
+ end;
+ new(e);
+ try
+ SetLength(e^.FName, n);
+ if not Read(e^.FName[1], n) then
+ begin
+ dispose(e);
+ cmd_err(erUnexpectedEof);
+ LoadVars := False;
+ exit;
+ end;
+ e^.FNameHash := MakeHash(e^.FName);
+ e^.FVarNo := FGlobalVars.Count;
+ FExportedVars.Add(E);
+ except
+ dispose(e);
+ cmd_err(erInvalidType);
+ LoadVars := False;
+ exit;
+ end;
+ end;
+ end;
+ end;
+
+begin
+ Clear;
+ Pos := 0;
+ LoadData := False;
+ if not read(HDR, SizeOf(HDR)) then
+ begin
+ CMD_Err(erInvalidHeader);
+ exit;
+ end;
+ if HDR.HDR <> PSValidHeader then
+ begin
+ CMD_Err(erInvalidHeader);
+ exit;
+ end;
+ if (HDR.PSBuildNo > PSCurrentBuildNo) or (HDR.PSBuildNo < PSLowBuildSupport) then begin
+ CMD_Err(erInvalidHeader);
+ exit;
+ end;
+ if not LoadTypes then
+ begin
+ Clear;
+ exit;
+ end;
+ if not LoadProcs then
+ begin
+ Clear;
+ exit;
+ end;
+ if not LoadVars then
+ begin
+ Clear;
+ exit;
+ end;
+ if (HDR.MainProcNo >= FProcs.Count) and (HDR.MainProcNo <> InvalidVal)then begin
+ CMD_Err(erNoMainProc);
+ Clear;
+ exit;
+ end;
+ // Load Import Table
+ FMainProc := HDR.MainProcNo;
+ FStatus := isLoaded;
+ Result := True;
+end;
+
+
+procedure TPSExec.Pause;
+begin
+ if FStatus = isRunning then
+ FStatus := isPaused;
+end;
+
+function TPSExec.ReadData(var Data; Len: Cardinal): Boolean;
+begin
+ if FCurrentPosition + Len <= FDataLength then begin
+ Move(FData^[FCurrentPosition], Data, Len);
+ FCurrentPosition := FCurrentPosition + Len;
+ Result := True;
+ end
+ else
+ Result := False;
+end;
+
+procedure TPSExec.CMD_Err(EC: TPSError); // Error
+begin
+ CMD_Err3(ec, '', nil);
+end;
+
+procedure VNSetPointerTo(const Src: TPSVariantIFC; Data: Pointer; aType: TPSTypeRec);
+begin
+ if Src.aType.BaseType = btPointer then
+ begin
+ if atype.BaseType in NeedFinalization then
+ FinalizeVariant(src.Dta, Src.aType);
+ Pointer(Src.Dta^) := Data;
+ Pointer(Pointer(IPointer(Src.Dta)+PointerSize)^) := aType;
+ Pointer(Pointer(IPointer(Src.Dta)+(2*PointerSize))^) := nil;
+ end;
+end;
+
+function VNGetUInt(const Src: TPSVariantIFC): Cardinal;
+begin
+ Result := PSGetUInt(Src.Dta, Src.aType);
+end;
+
+{$IFNDEF PS_NOINT64}
+function VNGetInt64(const Src: TPSVariantIFC): Int64;
+begin
+ Result := PSGetInt64(Src.Dta, Src.aType);
+end;
+{$ENDIF}
+
+function VNGetReal(const Src: TPSVariantIFC): Extended;
+begin
+ Result := PSGetReal(Src.Dta, Src.aType);
+end;
+
+function VNGetCurrency(const Src: TPSVariantIFC): Currency;
+begin
+ Result := PSGetCurrency(Src.Dta, Src.aType);
+end;
+
+function VNGetInt(const Src: TPSVariantIFC): Longint;
+begin
+ Result := PSGetInt(Src.Dta, Src.aType);
+end;
+
+function VNGetAnsiString(const Src: TPSVariantIFC): tbtString;
+begin
+ Result := PSGetAnsiString(Src.Dta, Src.aType);
+end;
+
+{$IFNDEF PS_NOWIDESTRING}
+function VNGetWideString(const Src: TPSVariantIFC): tbtWideString;
+begin
+ Result := PSGetWideString(Src.Dta, Src.aType);
+end;
+
+function VNGetUnicodeString(const Src: TPSVariantIFC): tbtunicodestring;
+begin
+ Result := PSGetUnicodeString(Src.Dta, Src.aType);
+end;
+{$ENDIF}
+
+procedure VNSetUInt(const Src: TPSVariantIFC; const Val: Cardinal);
+var
+ Dummy: Boolean;
+begin
+ PSSetUInt(Src.Dta, Src.aType, Dummy, Val);
+end;
+
+{$IFNDEF PS_NOINT64}
+procedure VNSetInt64(const Src: TPSVariantIFC; const Val: Int64);
+var
+ Dummy: Boolean;
+begin
+ PSSetInt64(Src.Dta, Src.aType, Dummy, Val);
+end;
+{$ENDIF}
+
+procedure VNSetReal(const Src: TPSVariantIFC; const Val: Extended);
+var
+ Dummy: Boolean;
+begin
+ PSSetReal(Src.Dta, Src.aType, Dummy, Val);
+end;
+
+procedure VNSetCurrency(const Src: TPSVariantIFC; const Val: Currency);
+var
+ Dummy: Boolean;
+begin
+ PSSetCurrency(Src.Dta, Src.aType, Dummy, Val);
+end;
+
+procedure VNSetInt(const Src: TPSVariantIFC; const Val: Longint);
+var
+ Dummy: Boolean;
+begin
+ PSSetInt(Src.Dta, Src.aType, Dummy, Val);
+end;
+
+procedure VNSetAnsiString(const Src: TPSVariantIFC; const Val: tbtString);
+var
+ Dummy: Boolean;
+begin
+ PSSetAnsiString(Src.Dta, Src.aType, Dummy, Val);
+end;
+
+function VNGetString(const Src: TPSVariantIFC): String;
+begin
+ {$IFDEF DELPHI2009UP}
+ Result := VNGetUnicodeString(Src);
+ {$ELSE}
+ Result := VNGetAnsiString(Src);
+ {$ENDIF}
+end;
+
+procedure VNSetString(const Src: TPSVariantIFC; const Val: String);
+begin
+ {$IFDEF DELPHI2009UP}
+ VNSetUnicodeString(Src, Val);
+ {$ELSE}
+ VNSetAnsiString(Src, Val);
+ {$ENDIF}
+end;
+
+{$IFNDEF PS_NOWIDESTRING}
+procedure VNSetWideString(const Src: TPSVariantIFC; const Val: tbtWideString);
+var
+ Dummy: Boolean;
+begin
+ PSSetWideString(Src.Dta, Src.aType, Dummy, Val);
+end;
+
+procedure VNSetUnicodeString(const Src: TPSVariantIFC; const Val: tbtunicodestring);
+var
+ Dummy: Boolean;
+begin
+ PSSetUnicodeString(Src.Dta, Src.aType, Dummy, Val);
+end;
+
+{$ENDIF}
+
+function VGetUInt(const Src: PIFVariant): Cardinal;
+begin
+ Result := PSGetUInt(@PPSVariantData(src).Data, src.FType);
+end;
+
+{$IFNDEF PS_NOINT64}
+function VGetInt64(const Src: PIFVariant): Int64;
+begin
+ Result := PSGetInt64(@PPSVariantData(src).Data, src.FType);
+end;
+{$ENDIF}
+
+function VGetReal(const Src: PIFVariant): Extended;
+begin
+ Result := PSGetReal(@PPSVariantData(src).Data, src.FType);
+end;
+
+function VGetCurrency(const Src: PIFVariant): Currency;
+begin
+ Result := PSGetCurrency(@PPSVariantData(src).Data, src.FType);
+end;
+
+function VGetInt(const Src: PIFVariant): Longint;
+begin
+ Result := PSGetInt(@PPSVariantData(src).Data, src.FType);
+end;
+
+function VGetAnsiString(const Src: PIFVariant): tbtString;
+begin
+ Result := PSGetAnsiString(@PPSVariantData(src).Data, src.FType);
+end;
+
+{$IFNDEF PS_NOWIDESTRING}
+function VGetWideString(const Src: PIFVariant): tbtWideString;
+begin
+ Result := PSGetWideString(@PPSVariantData(src).Data, src.FType);
+end;
+
+function VGetUnicodeString(const Src: PIFVariant): tbtunicodestring;
+begin
+ Result := PSGetUnicodeString(@PPSVariantData(src).Data, src.FType);
+end;
+
+{$ENDIF}
+
+
+procedure VSetPointerTo(const Src: PIFVariant; Data: Pointer; aType: TPSTypeRec);
+var
+ temp: TPSVariantIFC;
+begin
+ if (Atype = nil) or (Data = nil) or (Src = nil) then raise Exception.Create(RPS_InvalidVariable);
+ temp.Dta := @PPSVariantData(Src).Data;
+ temp.aType := Src.FType;
+ temp.VarParam := false;
+ VNSetPointerTo(temp, Data, AType);
+end;
+
+procedure VSetUInt(const Src: PIFVariant; const Val: Cardinal);
+var
+ Dummy: Boolean;
+begin
+ PSSetUInt(@PPSVariantData(src).Data, src.FType, Dummy, Val);
+end;
+
+{$IFNDEF PS_NOINT64}
+procedure VSetInt64(const Src: PIFVariant; const Val: Int64);
+var
+ Dummy: Boolean;
+begin
+ PSSetInt64(@PPSVariantData(src).Data, src.FType, Dummy, Val);
+end;
+{$ENDIF}
+
+procedure VSetReal(const Src: PIFVariant; const Val: Extended);
+var
+ Dummy: Boolean;
+begin
+ PSSetReal(@PPSVariantData(src).Data, src.FType, Dummy, Val);
+end;
+
+procedure VSetCurrency(const Src: PIFVariant; const Val: Currency);
+var
+ Dummy: Boolean;
+begin
+ PSSetCurrency(@PPSVariantData(src).Data, src.FType, Dummy, Val);
+end;
+
+procedure VSetInt(const Src: PIFVariant; const Val: Longint);
+var
+ Dummy: Boolean;
+begin
+ PSSetInt(@PPSVariantData(src).Data, src.FType, Dummy, Val);
+end;
+
+procedure VSetAnsiString(const Src: PIFVariant; const Val: tbtString);
+var
+ Dummy: Boolean;
+begin
+ PSSetAnsiString(@PPSVariantData(src).Data, src.FType, Dummy, Val);
+end;
+
+function VGetString(const Src: PIFVariant): String;
+begin
+ {$IFDEF DELPHI2009UP}
+ Result := PSGetUnicodeString(@PPSVariantData(src).Data, src.FType);
+ {$ELSE}
+ Result := PSGetAnsiString(@PPSVariantData(src).Data, src.FType);
+ {$ENDIF}
+end;
+
+procedure VSetString(const Src: PIFVariant; const Val: string);
+var
+ Dummy: Boolean;
+begin
+ {$IFDEF DELPHI2009UP}
+ PSSetUnicodeString(@PPSVariantData(src).Data, src.FType, Dummy, Val);
+ {$ELSE}
+ PSSetAnsiString(@PPSVariantData(src).Data, src.FType, Dummy, Val);
+ {$ENDIF}
+end;
+
+
+{$IFNDEF PS_NOWIDESTRING}
+procedure VSetWideString(const Src: PIFVariant; const Val: tbtWideString);
+var
+ Dummy: Boolean;
+begin
+ PSSetWideString(@PPSVariantData(src).Data, src.FType, Dummy, Val);
+end;
+
+procedure VSetUnicodeString(const Src: PIFVariant; const Val: tbtunicodestring);
+var
+ Dummy: Boolean;
+begin
+ PSSetUnicodeString(@PPSVariantData(src).Data, src.FType, Dummy, Val);
+end;
+
+
+{$ENDIF}
+
+{$IFNDEF PS_NOWIDESTRING}
+function VarToWideStr(const Data: Variant): tbtunicodestring;
+begin
+ if not VarIsNull(Data) then
+ Result := Data
+ else
+ Result := '';
+end;
+{$ENDIF}
+
+function PSGetUInt(Src: Pointer; aType: TPSTypeRec): Cardinal;
+begin
+ if aType.BaseType = btPointer then
+ begin
+ atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
+ Src := Pointer(Src^);
+ if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case aType.BaseType of
+ btU8: Result := tbtu8(src^);
+ btS8: Result := tbts8(src^);
+ btU16: Result := tbtu16(src^);
+ btS16: Result := tbts16(src^);
+ btU32: Result := tbtu32(src^);
+ btS32: Result := tbts32(src^);
+{$IFNDEF PS_NOINT64} btS64: Result := tbts64(src^);
+{$ENDIF}
+ btChar: Result := Ord(tbtchar(Src^));
+{$IFNDEF PS_NOWIDESTRING} btWideChar: Result := Ord(tbtwidechar(Src^));{$ENDIF}
+ btVariant:
+ case VarType(Variant(Src^)) of
+ varString:
+ if Length(VarToStr(Variant(Src^))) = 1 then
+ Result := Ord(VarToStr(Variant(Src^))[1])
+ else
+ raise Exception.Create(RPS_TypeMismatch);
+{$IFNDEF PS_NOWIDESTRING}
+ varOleStr:
+ if Length(VarToWideStr(Variant(Src^))) = 1 then
+ Result := Ord(VarToWideStr(Variant(Src^))[1])
+ else
+ raise Exception.Create(RPS_TypeMismatch);
+{$ENDIF}
+ else
+ Result := Variant(src^);
+ end;
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+end;
+
+function PSGetObject(Src: Pointer; aType: TPSTypeRec): TObject;
+begin
+ if aType.BaseType = btPointer then
+ begin
+ atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
+ Src := Pointer(Src^);
+ if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case aType.BaseType of
+ btClass: Result := TObject(Src^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+end;
+
+procedure PSSetObject(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; Const val: TObject);
+begin
+ if aType.BaseType = btPointer then
+ begin
+ atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
+ Src := Pointer(Src^);
+ if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case aType.BaseType of
+ btClass: TObject(Src^) := Val;
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+end;
+
+
+{$IFNDEF PS_NOINT64}
+function PSGetInt64(Src: Pointer; aType: TPSTypeRec): Int64;
+begin
+ if aType.BaseType = btPointer then
+ begin
+ atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
+ Src := Pointer(Src^);
+ if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case aType.BaseType of
+ btU8: Result := tbtu8(src^);
+ btS8: Result := tbts8(src^);
+ btU16: Result := tbtu16(src^);
+ btS16: Result := tbts16(src^);
+ btU32: Result := tbtu32(src^);
+ btS32: Result := tbts32(src^);
+ btS64: Result := tbts64(src^);
+ btChar: Result := Ord(tbtchar(Src^));
+{$IFNDEF PS_NOWIDESTRING}
+ btWideChar: Result := Ord(tbtwidechar(Src^));
+{$ENDIF}
+{$IFDEF DELPHI6UP}
+ btVariant: Result := Variant(src^);
+{$ENDIF}
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+end;
+{$ENDIF}
+
+function PSGetReal(Src: Pointer; aType: TPSTypeRec): Extended;
+begin
+ if aType.BaseType = btPointer then
+ begin
+ atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
+ Src := Pointer(Src^);
+ if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case aType.BaseType of
+ btU8: Result := tbtu8(src^);
+ btS8: Result := tbts8(src^);
+ btU16: Result := tbtu16(src^);
+ btS16: Result := tbts16(src^);
+ btU32: Result := tbtu32(src^);
+ btS32: Result := tbts32(src^);
+{$IFNDEF PS_NOINT64} btS64: Result := tbts64(src^);{$ENDIF}
+ btSingle: Result := tbtsingle(Src^);
+ btDouble: Result := tbtdouble(Src^);
+ btExtended: Result := tbtextended(Src^);
+ btCurrency: Result := tbtcurrency(Src^);
+ btVariant: Result := Variant(src^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+end;
+
+function PSGetCurrency(Src: Pointer; aType: TPSTypeRec): Currency;
+begin
+ if aType.BaseType = btPointer then
+ begin
+ atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
+ Src := Pointer(Src^);
+ if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case aType.BaseType of
+ btU8: Result := tbtu8(src^);
+ btS8: Result := tbts8(src^);
+ btU16: Result := tbtu16(src^);
+ btS16: Result := tbts16(src^);
+ btU32: Result := tbtu32(src^);
+ btS32: Result := tbts32(src^);
+{$IFNDEF PS_NOINT64} btS64: Result := tbts64(src^);{$ENDIF}
+ btSingle: Result := tbtsingle(Src^);
+ btDouble: Result := tbtdouble(Src^);
+ btExtended: Result := tbtextended(Src^);
+ btCurrency: Result := tbtcurrency(Src^);
+ btVariant: Result := Variant(src^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+end;
+
+
+function PSGetInt(Src: Pointer; aType: TPSTypeRec): Longint;
+begin
+ if aType.BaseType = btPointer then
+ begin
+ atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
+ Src := Pointer(Src^);
+ if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case aType.BaseType of
+ btU8: Result := tbtu8(src^);
+ btS8: Result := tbts8(src^);
+ btU16: Result := tbtu16(src^);
+ btS16: Result := tbts16(src^);
+ btU32: Result := tbtu32(src^);
+ btS32: Result := tbts32(src^);
+{$IFNDEF PS_NOINT64} btS64: Result := tbts64(src^);{$ENDIF}
+ btChar: Result := Ord(tbtchar(Src^));
+{$IFNDEF PS_NOWIDESTRING} btWideChar: Result := Ord(tbtwidechar(Src^));{$ENDIF}
+ btVariant: Result := Variant(src^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+end;
+
+
+function PSGetAnsiString(Src: Pointer; aType: TPSTypeRec): tbtString;
+begin
+ if aType.BaseType = btPointer then
+ begin
+ atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
+ Src := Pointer(Src^);
+ if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case aType.BaseType of
+ btU8: Result := tbtchar(tbtu8(src^));
+ btChar: Result := tbtchar(Src^);
+ btPchar: Result := pansichar(src^);
+{$IFNDEF PS_NOWIDESTRING} btWideChar: Result := tbtString(tbtwidechar(Src^));{$ENDIF}
+ btString: Result := tbtstring(src^);
+{$IFNDEF PS_NOWIDESTRING}
+ btUnicodeString: result := tbtString(tbtUnicodestring(src^));
+ btWideString: Result := tbtString(tbtwidestring(src^));{$ENDIF}
+ btVariant: Result := tbtString(Variant(src^));
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+end;
+{$IFNDEF PS_NOWIDESTRING}
+function PSGetWideString(Src: Pointer; aType: TPSTypeRec): tbtWideString;
+begin
+ if aType.BaseType = btPointer then
+ begin
+ atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
+ Src := Pointer(Src^);
+ if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case aType.BaseType of
+ btU8: Result := chr(tbtu8(src^));
+ btU16: Result := widechar(src^);
+ btChar: Result := tbtwidestring(tbtchar(Src^));
+ btPchar: Result := tbtwidestring(pansichar(src^));
+ btWideChar: Result := tbtwidechar(Src^);
+ btString: Result := tbtwidestring(tbtstring(src^));
+ btWideString: Result := tbtwidestring(src^);
+ btVariant: Result := Variant(src^);
+ btUnicodeString: result := tbtUnicodeString(src^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+end;
+
+function PSGetUnicodeString(Src: Pointer; aType: TPSTypeRec): tbtunicodestring;
+begin
+ if aType.BaseType = btPointer then
+ begin
+ atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
+ Src := Pointer(Src^);
+ if (src = nil) or (aType = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case aType.BaseType of
+ btU8: Result := chr(tbtu8(src^));
+ btU16: Result := widechar(src^);
+ btChar: Result := tbtwidestring(tbtchar(Src^));
+ btPchar: Result := tbtwidestring(pansichar(src^));
+ btWideChar: Result := tbtwidechar(Src^);
+ btString: Result := tbtwidestring(tbtstring(src^));
+ btWideString: Result := tbtwidestring(src^);
+ btVariant: Result := Variant(src^);
+ btUnicodeString: result := tbtUnicodeString(src^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+end;
+{$ENDIF}
+
+procedure PSSetUInt(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Cardinal);
+begin
+ if (Src = nil) or (aType = nil) then begin Ok := false; exit; end;
+ if aType.BaseType = btPointer then
+ begin
+ atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
+ Src := Pointer(Src^);
+ if (src = nil) or (aType = nil) then begin Ok := false; exit; end;
+ end;
+ case aType.BaseType of
+ btU8: tbtu8(src^) := Val;
+ btS8: tbts8(src^) := Val;
+ btU16: tbtu16(src^) := Val;
+ btS16: tbts16(src^) := Val;
+ btProcPtr:
+ begin
+ tbtu32(src^) := Val;
+ Pointer(Pointer(IPointer(Src)+PointerSize)^) := nil;
+ Pointer(Pointer(IPointer(Src)+PointerSize2)^) := nil;
+ end;
+ btU32: tbtu32(src^) := Val;
+ btS32: tbts32(src^) := Val;
+{$IFNDEF PS_NOINT64} btS64: tbts64(src^) := Val;{$ENDIF}
+ btChar: tbtchar(Src^) := tbtChar(Val);
+{$IFNDEF PS_NOWIDESTRING} btWideChar: tbtwidechar(Src^) := tbtwidechar(Val);{$ENDIF}
+ btSingle: tbtSingle(src^) := Val;
+ btDouble: tbtDouble(src^) := Val;
+ btCurrency: tbtCurrency(src^) := Val;
+ btExtended: tbtExtended(src^) := Val;
+ btVariant:
+ begin
+ try
+ Variant(src^) := {$IFDEF DELPHI6UP}val{$ELSE}tbts32(val){$ENDIF};
+ except
+ Ok := false;
+ end;
+ end;
+ else ok := false;
+ end;
+end;
+
+{$IFNDEF PS_NOINT64}
+procedure PSSetInt64(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Int64);
+begin
+ if (Src = nil) or (aType = nil) then begin Ok := false; exit; end;
+ if aType.BaseType = btPointer then
+ begin
+ atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
+ Src := Pointer(Src^);
+ if (src = nil) or (aType = nil) then begin Ok := false; exit; end;
+ end;
+ case aType.BaseType of
+ btU8: tbtu8(src^) := Val;
+ btS8: tbts8(src^) := Val;
+ btU16: tbtu16(src^) := Val;
+ btS16: tbts16(src^) := Val;
+ btU32: tbtu32(src^) := Val;
+ btS32: tbts32(src^) := Val;
+ btS64: tbts64(src^) := Val;
+ btChar: tbtchar(Src^) := tbtChar(Val);
+{$IFNDEF PS_NOWIDESTRING}
+ btWideChar: tbtwidechar(Src^) := tbtwidechar(Val);
+{$ENDIF}
+ btSingle: tbtSingle(src^) := Val;
+ btDouble: tbtDouble(src^) := Val;
+ btCurrency: tbtCurrency(src^) := Val;
+ btExtended: tbtExtended(src^) := Val;
+{$IFDEF DELPHI6UP}
+ btVariant:
+ begin
+ try
+ Variant(src^) := Val;
+ except
+ Ok := false;
+ end;
+ end;
+{$ENDIF}
+ else ok := false;
+ end;
+end;
+{$ENDIF}
+
+procedure PSSetReal(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Extended);
+begin
+ if (Src = nil) or (aType = nil) then begin Ok := false; exit; end;
+ if aType.BaseType = btPointer then
+ begin
+ atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
+ Src := Pointer(Src^);
+ if (src = nil) or (aType = nil) then begin Ok := false; exit; end;
+ end;
+ case aType.BaseType of
+ btSingle: tbtSingle(src^) := Val;
+ btDouble: tbtDouble(src^) := Val;
+ btCurrency: tbtCurrency(src^) := Val;
+ btExtended: tbtExtended(src^) := Val;
+ btVariant:
+ begin
+ try
+ Variant(src^) := Val;
+ except
+ Ok := false;
+ end;
+ end;
+ else ok := false;
+ end;
+end;
+
+procedure PSSetCurrency(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Currency);
+begin
+ if (Src = nil) or (aType = nil) then begin Ok := false; exit; end;
+ if aType.BaseType = btPointer then
+ begin
+ atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
+ Src := Pointer(Src^);
+ if (src = nil) or (aType = nil) then begin Ok := false; exit; end;
+ end;
+ case aType.BaseType of
+ btSingle: tbtSingle(src^) := Val;
+ btDouble: tbtDouble(src^) := Val;
+ btCurrency: tbtCurrency(src^) := Val;
+ btExtended: tbtExtended(src^) := Val;
+ btVariant:
+ begin
+ try
+ Variant(src^) := Val;
+ except
+ Ok := false;
+ end;
+ end;
+ else ok := false;
+ end;
+end;
+
+procedure PSSetInt(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: Longint);
+begin
+ if (Src = nil) or (aType = nil) then begin Ok := false; exit; end;
+ if aType.BaseType = btPointer then
+ begin
+ atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
+ Src := Pointer(Src^);
+ if (src = nil) or (aType = nil) then begin Ok := false; exit; end;
+ end;
+ case aType.BaseType of
+ btU8: tbtu8(src^) := Val;
+ btS8: tbts8(src^) := Val;
+ btU16: tbtu16(src^) := Val;
+ btS16: tbts16(src^) := Val;
+ btProcPtr:
+ begin
+ tbtu32(src^) := Val;
+ Pointer(Pointer(IPointer(Src)+PointerSize)^) := nil;
+ Pointer(Pointer(IPointer(Src)+PointerSize2)^) := nil;
+ end;
+ btU32: tbtu32(src^) := Val;
+ btS32: tbts32(src^) := Val;
+{$IFNDEF PS_NOINT64} btS64: tbts64(src^) := Val;{$ENDIF}
+ btChar: tbtchar(Src^) := tbtChar(Val);
+{$IFNDEF PS_NOWIDESTRING} btWideChar: tbtwidechar(Src^) := tbtwidechar(Val);{$ENDIF}
+ btSingle: tbtSingle(src^) := Val;
+ btDouble: tbtDouble(src^) := Val;
+ btCurrency: tbtCurrency(src^) := Val;
+ btExtended: tbtExtended(src^) := Val;
+ btVariant:
+ begin
+ try
+ Variant(src^) := Val;
+ except
+ Ok := false;
+ end;
+ end;
+ else ok := false;
+ end;
+end;
+
+procedure PSSetAnsiString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: tbtString);
+begin
+ if (Src = nil) or (aType = nil) then begin Ok := false; exit; end;
+ if aType.BaseType = btPointer then
+ begin
+ atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
+ Src := Pointer(Src^);
+ if (src = nil) or (aType = nil) then begin Ok := false; exit; end;
+ end;
+ case aType.BaseType of
+ btString: tbtstring(src^) := val;
+{$IFNDEF PS_NOWIDESTRING}
+ btUnicodeString: tbtunicodestring(src^) := tbtUnicodeString(AnsiString(val));
+ btWideString: tbtwidestring(src^) := tbtwidestring(AnsiString(val));{$ENDIF}
+ btVariant:
+ begin
+ try
+ Variant(src^) := Val;
+ except
+ Ok := false;
+ end;
+ end;
+ else ok := false;
+ end;
+end;
+{$IFNDEF PS_NOWIDESTRING}
+procedure PSSetWideString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: tbtWideString);
+begin
+ if (Src = nil) or (aType = nil) then begin Ok := false; exit; end;
+ if aType.BaseType = btPointer then
+ begin
+ atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
+ Src := Pointer(Src^);
+ if (src = nil) or (aType = nil) then begin Ok := false; exit; end;
+ end;
+ case aType.BaseType of
+ btString: tbtstring(src^) := tbtString(val);
+ btWideString: tbtwidestring(src^) := val;
+ btUnicodeString: tbtunicodestring(src^) := val;
+ btVariant:
+ begin
+ try
+ Variant(src^) := Val;
+ except
+ Ok := false;
+ end;
+ end;
+ else ok := false;
+ end;
+end;
+procedure PSSetUnicodeString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: tbtunicodestring);
+begin
+ if (Src = nil) or (aType = nil) then begin Ok := false; exit; end;
+ if aType.BaseType = btPointer then
+ begin
+ atype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
+ Src := Pointer(Src^);
+ if (src = nil) or (aType = nil) then begin Ok := false; exit; end;
+ end;
+ case aType.BaseType of
+ btString: tbtstring(src^) := tbtString(val);
+ btWideString: tbtwidestring(src^) := val;
+ btUnicodeString: tbtunicodestring(src^) := val;
+ btVariant:
+ begin
+ try
+ Variant(src^) := Val;
+ except
+ Ok := false;
+ end;
+ end;
+ else ok := false;
+ end;
+end;
+{$ENDIF}
+
+function PSGetString(Src: Pointer; aType: TPSTypeRec): string;
+begin
+ {$IFDEF DELPHI2009UP}
+ result := PSGetUnicodeString(Src, aType);
+ {$ELSE}
+ result := PSGetAnsiString(Src, aType);
+ {$ENDIF}
+end;
+
+procedure PSSetString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: String);
+begin
+ {$IFDEF DELPHI2009UP}
+ PSSetUnicodeString(Src, aType, Ok, Val);
+ {$ELSE}
+ PSSetAnsiString(Src, aType, Ok, Val);
+ {$ENDIF}
+end;
+
+
+function CopyArrayContents(dest, src: Pointer; Len: Longint; aType: TPSTypeRec): Boolean; forward;
+
+function CopyRecordContents(dest, src: Pointer; aType: TPSTypeRec_Record): Boolean;
+var
+ o, i: Longint;
+begin
+ for i := 0 to aType.FieldTypes.Count -1 do
+ begin
+ o := Longint(atype.RealFieldOffsets[i]);
+ CopyArrayContents(Pointer(IPointer(Dest)+Cardinal(o)), Pointer(IPointer(Src)+Cardinal(o)), 1, aType.FieldTypes[i]);
+ end;
+ Result := true;
+end;
+
+function CreateArrayFromVariant(Exec: TPSExec; dest: Pointer; src: Variant; DestType: TPSTypeRec): Boolean;
+var
+ i: Integer;
+ r: Pointer;
+ lVarType: TPSTypeRec;
+ v: variant;
+begin
+ lVarType := Exec.FindType2(btVariant);
+ if lVarType = nil then begin result := false; exit; end;
+ PSDynArraySetLength(Pointer(dest^), desttype, VarArrayHighBound(src, 1) - VarArrayLowBound(src, 1) + 1);
+ r := Pointer(Dest^);
+ DestType := TPSTypeRec_Array(DestType).ArrayType;
+ for i := 0 to VarArrayHighBound(src, 1) - VarArrayLowBound(src, 1) do begin
+ v := src[i + VarArrayLowBound(src, 1)];
+ if not Exec.SetVariantValue(r, @v, desttype, lVarType) then begin result := false; exit; end;
+ r := Pointer(IPointer(r) + Longint(DestType.RealSize));
+ end;
+ Result := true;
+end;
+
+function CopyArrayContents(dest, src: Pointer; Len: Longint; aType: TPSTypeRec): Boolean;
+var
+ elsize: Cardinal;
+ i: Longint;
+begin
+ try
+ case aType.BaseType of
+ btU8, btS8, btChar:
+ for i := 0 to Len -1 do
+ begin
+ tbtU8(Dest^) := tbtU8(Src^);
+ Dest := Pointer(IPointer(Dest) + 1);
+ Src := Pointer(IPointer(Src) + 1);
+ end;
+ btU16, btS16{$IFNDEF PS_NOWIDESTRING}, btWideChar{$ENDIF}:
+ for i := 0 to Len -1 do
+ begin
+ tbtU16(Dest^) := tbtU16(Src^);
+ Dest := Pointer(IPointer(Dest) + 2);
+ Src := Pointer(IPointer(Src) + 2);
+ end;
+ btProcPtr:
+ for i := 0 to Len -1 do
+ begin
+ tbtU32(Dest^) := tbtU32(Src^);
+ Dest := Pointer(IPointer(Dest) + 4);
+ Src := Pointer(IPointer(Src) + 4);
+ Pointer(Dest^) := Pointer(Src^);
+ Dest := Pointer(IPointer(Dest) + PointerSize);
+ Src := Pointer(IPointer(Src) + PointerSize);
+ Pointer(Dest^) := Pointer(Src^);
+ Dest := Pointer(IPointer(Dest) + PointerSize);
+ Src := Pointer(IPointer(Src) + PointerSize);
+ end;
+ btClass, btpchar:
+ for i := 0 to Len -1 do
+ begin
+ Pointer(Dest^) := Pointer(Src^);
+ Dest := Pointer(IPointer(Dest) + PointerSize);
+ Src := Pointer(IPointer(Src) + PointerSize);
+ end;
+ btU32, btS32, btSingle:
+ for i := 0 to Len -1 do
+ begin
+ tbtU32(Dest^) := tbtU32(Src^);
+ Dest := Pointer(IPointer(Dest) + 4);
+ Src := Pointer(IPointer(Src) + 4);
+ end;
+ btDouble:
+ for i := 0 to Len -1 do
+ begin
+ tbtDouble(Dest^) := tbtDouble(Src^);
+ Dest := Pointer(IPointer(Dest) + 8);
+ Src := Pointer(IPointer(Src) + 8);
+ end;
+ {$IFNDEF PS_NOINT64}bts64:
+ for i := 0 to Len -1 do
+ begin
+ tbts64(Dest^) := tbts64(Src^);
+ Dest := Pointer(IPointer(Dest) + 8);
+ Src := Pointer(IPointer(Src) + 8);
+ end;{$ENDIF}
+ btExtended:
+ for i := 0 to Len -1 do
+ begin
+ tbtExtended(Dest^) := tbtExtended(Src^);
+ Dest := Pointer(IPointer(Dest) + SizeOf(Extended));
+ Src := Pointer(IPointer(Src) + SizeOf(Extended));
+ end;
+ btCurrency:
+ for i := 0 to Len -1 do
+ begin
+ tbtCurrency(Dest^) := tbtCurrency(Src^);
+ Dest := Pointer(IPointer(Dest) + SizeOf(Currency));
+ Src := Pointer(IPointer(Src) + SizeOf(Currency));
+ end;
+ btVariant:
+ for i := 0 to Len -1 do
+ begin
+ variant(Dest^) := variant(Src^);
+ Dest := Pointer(IPointer(Dest) + Sizeof(Variant));
+ Src := Pointer(IPointer(Src) + Sizeof(Variant));
+ end;
+ btString:
+ for i := 0 to Len -1 do
+ begin
+ tbtString(Dest^) := tbtString(Src^);
+ Dest := Pointer(IPointer(Dest) + PointerSize);
+ Src := Pointer(IPointer(Src) + PointerSize);
+ end;
+ {$IFNDEF PS_NOWIDESTRING}
+ btUnicodeString:
+ for i := 0 to Len -1 do
+ begin
+ tbtunicodestring(Dest^) := tbtunicodestring(Src^);
+ Dest := Pointer(IPointer(Dest) + PointerSize);
+ Src := Pointer(IPointer(Src) + PointerSize);
+ end;
+ btWideString:
+ for i := 0 to Len -1 do
+ begin
+ tbtWideString(Dest^) := tbtWideString(Src^);
+ Dest := Pointer(IPointer(Dest) + PointerSize);
+ Src := Pointer(IPointer(Src) + PointerSize);
+ end;
+ {$ENDIF}
+ btStaticArray:
+ begin
+ elSize := aType.RealSize;
+ for i := 0 to Len -1 do
+ begin
+ if not CopyArrayContents(Dest, Src, TPSTypeRec_StaticArray(aType).Size, TPSTypeRec_StaticArray(aType).ArrayType) then
+ begin
+ result := false;
+ exit;
+ end;
+ Dest := Pointer(IPointer(Dest) + elsize);
+ Src := Pointer(IPointer(Src) + elsize);
+ end;
+ end;
+ btArray:
+ begin
+ for i := 0 to Len -1 do
+ begin
+ Pointer(Dest^) := Pointer(Src^);
+ if Pointer(Dest^) <> nil then
+ begin
+ Inc(Longint(Pointer(IPointer(Dest^)-(2*PointerSize))^)); // RefCount
+ end;
+ Dest := Pointer(IPointer(Dest) + PointerSize);
+ Src := Pointer(IPointer(Src) + PointerSize);
+ end;
+ end;
+ btRecord:
+ begin
+ elSize := aType.RealSize;
+ for i := 0 to Len -1 do
+ begin
+ if not CopyRecordContents(Dest, Src, TPSTypeRec_Record(aType)) then
+ begin
+ result := false;
+ exit;
+ end;
+ Dest := Pointer(IPointer(Dest) + elsize);
+ Src := Pointer(IPointer(Src) + elsize);
+ end;
+ end;
+ btSet:
+ begin
+ elSize := aType.RealSize;
+ for i := 0 to Len -1 do
+ begin
+ Move(Src^, Dest^, elSize);
+ Dest := Pointer(IPointer(Dest) + elsize);
+ Src := Pointer(IPointer(Src) + elsize);
+ end;
+ end;
+{$IFNDEF PS_NOINTERFACES}
+ btInterface:
+ begin
+ for i := 0 to Len -1 do
+ begin
+ {$IFNDEF DELPHI3UP}
+ if IUnknown(Dest^) <> nil then
+ begin
+ IUnknown(Dest^).Release;
+ IUnknown(Dest^) := nil;
+ end;
+ {$ENDIF}
+ IUnknown(Dest^) := IUnknown(Src^);
+ {$IFNDEF DELPHI3UP}
+ if IUnknown(Dest^) <> nil then
+ IUnknown(Dest^).AddRef;
+ {$ENDIF}
+ Dest := Pointer(IPointer(Dest) + PointerSize);
+ Src := Pointer(IPointer(Src) + PointerSize);
+ end;
+ end;
+{$ENDIF}
+ btPointer:
+ begin
+ if (Pointer(Pointer(IPointer(Dest)+PointerSize2)^) = nil) and (Pointer(Pointer(IPointer(Src)+PointerSize2)^) = nil) then
+ begin
+ for i := 0 to Len -1 do
+ begin
+ Pointer(Dest^) := Pointer(Src^);
+ Dest := Pointer(IPointer(Dest) + PointerSize);
+ Src := Pointer(IPointer(Src) + PointerSize);
+ Pointer(Dest^) := Pointer(Src^);
+ Dest := Pointer(IPointer(Dest) + PointerSize);
+ Src := Pointer(IPointer(Src) + PointerSize);
+ LongBool(Dest^) := false;
+ Dest := Pointer(IPointer(Dest) + sizeof(LongBool));
+ Src := Pointer(IPointer(Src) + sizeof(LongBool));
+ end;
+ end else begin
+ for i := 0 to Len -1 do
+ begin
+ if Pointer(Pointer(IPointer(Dest)+PointerSize2)^) <> nil then
+ DestroyHeapVariant2(Pointer(Dest^), Pointer(Pointer(IPointer(Dest)+PointerSize)^));
+ if Pointer(Src^) <> nil then
+ begin
+ if not LongBool(Pointer(IPointer(Src) + PointerSize2)^) then
+ begin
+ Pointer(Dest^) := Pointer(Src^);
+ Pointer(Pointer(IPointer(Dest) + PointerSize)^) := Pointer(Pointer(IPointer(Src) + PointerSize)^);
+ Pointer(Pointer(IPointer(Dest) + PointerSize2)^) := Pointer(Pointer(IPointer(Src) + PointerSize2)^);
+ end else
+ begin
+ Pointer(Dest^) := CreateHeapVariant2(Pointer(Pointer(IPointer(Src) + PointerSize)^));
+ Pointer(Pointer(IPointer(Dest) + PointerSize)^) := Pointer(Pointer(IPointer(Src) + PointerSize)^);
+ LongBool(Pointer(IPointer(Dest) + PointerSize2)^) := true;
+ if not CopyArrayContents(Pointer(Dest^), Pointer(Src^), 1, Pointer(Pointer(IPointer(Dest) + PointerSize)^)) then
+ begin
+ Result := false;
+ exit;
+ end;
+ end;
+ end else
+ begin
+ Pointer(Dest^) := nil;
+ Pointer(Pointer(IPointer(Dest) + PointerSize)^) := nil;
+ Pointer(Pointer(IPointer(Dest) + PointerSize2)^) := nil;
+ end;
+ Dest := Pointer(IPointer(Dest) + PointerSize*2+sizeof(LongBool));
+ Src := Pointer(IPointer(Src) + PointerSize*2+sizeof(LongBool));
+ end;
+ end;
+ end;
+// btResourcePointer = 15;
+// btVariant = 16;
+ else
+ Result := False;
+ exit;
+ end;
+ except
+ Result := False;
+ exit;
+ end;
+ Result := true;
+end;
+
+function GetPSArrayLength(Arr: PIFVariant): Longint;
+begin
+ result := PSDynArrayGetLength(PPSVariantDynamicArray(arr).Data, arr.FType);
+end;
+
+procedure SetPSArrayLength(Arr: PIFVariant; NewLength: Longint);
+begin
+ PSDynArraySetLength(PPSVariantDynamicArray(arr).Data, arr.FType, NewLength);
+end;
+
+
+function PSDynArrayGetLength(arr: Pointer; aType: TPSTypeRec): Longint;
+begin
+ if aType.BaseType <> btArray then raise Exception.Create(RPS_InvalidArray);
+ if arr = nil then Result := 0 else Result := Longint(Pointer(IPointer(arr)-PointerSize)^) + 1;
+end;
+
+procedure PSDynArraySetLength(var arr: Pointer; aType: TPSTypeRec; NewLength: Longint);
+var
+ elSize, i, OldLen: Longint;
+ p: Pointer;
+begin
+ if aType.BaseType <> btArray then raise Exception.Create(RPS_InvalidArray);
+ OldLen := PSDynArrayGetLength(arr, aType);
+ elSize := TPSTypeRec_Array(aType).ArrayType.RealSize;
+ if (OldLen = 0) and (NewLength = 0) then exit; // already are both 0
+ if (OldLen <> 0) and (Longint(Pointer(IPointer(Arr)-PointerSize2)^) = 1) then // unique copy of this dynamic array
+ begin
+ for i := NewLength to OldLen -1 do
+ begin
+ if TPSTypeRec_Array(aType).ArrayType.BaseType in NeedFinalization then
+ FinalizeVariant(Pointer(IPointer(arr) + Cardinal(elsize * i)), TPSTypeRec_Array(aType).ArrayType);
+ end;
+ arr := Pointer(IPointer(Arr)-PointerSize2);
+ if NewLength <= 0 then
+ begin
+ FreeMem(arr, NewLength * elsize + PointerSize2);
+ arr := nil;
+ exit;
+ end;
+ ReallocMem(arr, NewLength * elSize + PointerSize2);
+ arr := Pointer(IPointer(Arr)+PointerSize);
+ Longint(Arr^) := NewLength - 1;
+ arr := Pointer(IPointer(Arr)+PointerSize);
+ for i := OldLen to NewLength -1 do
+ begin
+ InitializeVariant(Pointer(IPointer(arr) + Cardinal(elsize * i)), TPSTypeRec_Array(aType).ArrayType);
+ end;
+ end else
+ begin
+ if NewLength = 0 then
+ begin
+ if Longint(Pointer(IPointer(Arr)-PointerSize2)^) = 1 then
+ FreeMem(Pointer(IPointer(Arr)-PointerSize2), OldLen * elSize + PointerSize2)
+ else if Longint(Pointer(IPointer(Arr)-PointerSize2)^) > 0 then
+ Dec(Longint(Pointer(IPointer(Arr)-PointerSize2)^));
+ arr := nil;
+ exit;
+ end;
+ GetMem(p, NewLength * elSize + PointerSize2);
+ Longint(p^) := 1;
+ p:= Pointer(IPointer(p)+PointerSize);
+ Longint(p^) := NewLength - 1;
+ p := Pointer(IPointer(p)+PointerSize);
+ if OldLen <> 0 then
+ begin
+ if OldLen > NewLength then
+ CopyArrayContents(p, arr, NewLength, TPSTypeRec_Array(aType).ArrayType)
+ else
+ CopyArrayContents(p, arr, OldLen, TPSTypeRec_Array(aType).ArrayType);
+ FinalizeVariant(@arr, aType);
+ end;
+ arr := p;
+ for i := OldLen to NewLength -1 do
+ begin
+ InitializeVariant(Pointer(IPointer(arr) + Cardinal(elsize * i)), TPSTypeRec_Array(aType).ArrayType);
+ end;
+ end;
+end;
+
+
+
+{$IFDEF FPC}
+function OleErrorMessage(ErrorCode: HResult): tbtString;
+begin
+ Result := SysErrorMessage(ErrorCode);
+ if Result = '' then
+ Result := Format(RPS_OLEError, [ErrorCode]);
+end;
+
+procedure OleError(ErrorCode: HResult);
+begin
+ raise Exception.Create(OleErrorMessage(ErrorCode));
+end;
+
+procedure OleCheck(Result: HResult);
+begin
+ if Result < 0 then OleError(Result);
+end;
+{$ENDIF}
+
+
+{$IFNDEF DELPHI3UP}
+function OleErrorMessage(ErrorCode: HResult): tbtString;
+begin
+ Result := SysErrorMessage(ErrorCode);
+ if Result = '' then
+ Result := Format(RPS_OLEError, [ErrorCode]);
+end;
+
+procedure OleError(ErrorCode: HResult);
+begin
+ raise Exception.Create(OleErrorMessage(ErrorCode));
+end;
+
+procedure OleCheck(Result: HResult);
+begin
+ if Result < 0 then OleError(Result);
+end;
+
+procedure AssignInterface(var Dest: IUnknown; const Src: IUnknown);
+var
+ OldDest: IUnknown;
+begin
+ { Like Delphi 3+'s _IntfCopy, reference source before releasing old dest.
+ so that self assignment (I := I) works right }
+ OldDest := Dest;
+ Dest := Src;
+ if Src <> nil then
+ Src.AddRef;
+ if OldDest <> nil then
+ OldDest.Release;
+end;
+
+procedure AssignVariantFromIDispatch(var Dest: Variant; const Src: IDispatch);
+begin
+ VarClear(Dest);
+ TVarData(Dest).VDispatch := Src;
+ TVarData(Dest).VType := varDispatch;
+ if Src <> nil then
+ Src.AddRef;
+end;
+
+procedure AssignIDispatchFromVariant(var Dest: IDispatch; const Src: Variant);
+const
+ RPS_InvalidVariantRef = 'Invalid variant ref';
+var
+ NewDest: IDispatch;
+begin
+ case TVarData(Src).VType of
+ varEmpty: NewDest := nil;
+ varDispatch: NewDest := TVarData(Src).VDispatch;
+ varDispatch or varByRef: NewDest := Pointer(TVarData(Src).VPointer^);
+ else
+ raise Exception.Create(RPS_InvalidVariantRef);
+ end;
+ AssignInterface(IUnknown(Dest), NewDest);
+end;
+{$ENDIF}
+
+function TPSExec.SetVariantValue(dest, Src: Pointer; desttype, srctype: TPSTypeRec): Boolean;
+var
+ Tmp: TObject;
+ tt: TPSVariantPointer;
+begin
+ Result := True;
+ try
+ case desttype.BaseType of
+ btSet:
+ begin
+ if desttype = srctype then
+ Move(Src^, Dest^, TPSTypeRec_Set(desttype).aByteSize)
+ else
+ Result := False;
+ end;
+ btU8: tbtu8(Dest^) := PSGetUInt(Src, srctype);
+ btS8: tbts8(Dest^) := PSGetInt(Src, srctype);
+ btU16: tbtu16(Dest^) := PSGetUInt(Src, srctype);
+ btS16: tbts16(Dest^) := PSGetInt(Src, srctype);
+ btProcPtr:
+ begin
+ if srctype.BaseType = btPointer then
+ begin
+ srctype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
+ Src := Pointer(Src^);
+ if (src = nil) or (srctype = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case srctype.BaseType of
+ btu32:
+ begin
+ Pointer(Dest^) := Pointer(Src^);
+ end;
+ btProcPtr:
+ begin
+ Pointer(Dest^) := Pointer(Src^);
+ Pointer(Pointer(IPointer(Dest)+PointerSize)^) := Pointer(Pointer(IPointer(Src)+PointerSize)^);
+ Pointer(Pointer(IPointer(Dest)+PointerSize2)^) := Pointer(Pointer(IPointer(Src)+PointerSize2)^);
+ end;
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ btU32:
+ begin
+ if srctype.BaseType = btPointer then
+ begin
+ srctype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
+ Src := Pointer(Src^);
+ if (src = nil) or (srctype = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case srctype.BaseType of
+ btU8: tbtu32(Dest^) := tbtu8(src^);
+ btS8: tbtu32(Dest^) := tbts8(src^);
+ btU16: tbtu32(Dest^) := tbtu16(src^);
+ btS16: tbtu32(Dest^) := tbts16(src^);
+ btU32: tbtu32(Dest^) := tbtu32(src^);
+ btS32: tbtu32(Dest^) := tbts32(src^);
+ {$IFNDEF PS_NOINT64} btS64: tbtu32(Dest^) := tbts64(src^);{$ENDIF}
+ btChar: tbtu32(Dest^) := Ord(tbtchar(Src^));
+ {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtu32(Dest^) := Ord(tbtwidechar(Src^));{$ENDIF}
+ btVariant: tbtu32(Dest^) := Variant(src^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ btS32:
+ begin
+ if srctype.BaseType = btPointer then
+ begin
+ srctype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
+ Src := Pointer(Src^);
+ if (src = nil) or (srctype = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case srctype.BaseType of
+ btU8: tbts32(Dest^) := tbtu8(src^);
+ btS8: tbts32(Dest^) := tbts8(src^);
+ btU16: tbts32(Dest^) := tbtu16(src^);
+ btS16: tbts32(Dest^) := tbts16(src^);
+ btU32: tbts32(Dest^) := tbtu32(src^);
+ btS32: tbts32(Dest^) := tbts32(src^);
+ {$IFNDEF PS_NOINT64} btS64: tbts32(Dest^) := tbts64(src^);{$ENDIF}
+ btChar: tbts32(Dest^) := Ord(tbtchar(Src^));
+ {$IFNDEF PS_NOWIDESTRING} btWideChar: tbts32(Dest^) := Ord(tbtwidechar(Src^));{$ENDIF}
+ btVariant: tbts32(Dest^) := Variant(src^);
+ // nx change start - allow assignment of class
+ btClass: tbtu32(Dest^) := tbtu32(src^);
+ // nx change start
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ {$IFNDEF PS_NOINT64}
+ btS64: tbts64(Dest^) := PSGetInt64(Src, srctype);
+ {$ENDIF}
+ btSingle:
+ begin
+ if srctype.BaseType = btPointer then
+ begin
+ srctype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
+ Src := Pointer(Src^);
+ if (src = nil) or (srctype = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case srctype.BaseType of
+ btU8: tbtsingle(Dest^) := tbtu8(src^);
+ btS8: tbtsingle(Dest^) := tbts8(src^);
+ btU16: tbtsingle(Dest^) := tbtu16(src^);
+ btS16: tbtsingle(Dest^) := tbts16(src^);
+ btU32: tbtsingle(Dest^) := tbtu32(src^);
+ btS32: tbtsingle(Dest^) := tbts32(src^);
+ {$IFNDEF PS_NOINT64} btS64: tbtsingle(Dest^) := tbts64(src^);{$ENDIF}
+ btSingle: tbtsingle(Dest^) := tbtsingle(Src^);
+ btDouble: tbtsingle(Dest^) := tbtdouble(Src^);
+ btExtended: tbtsingle(Dest^) := tbtextended(Src^);
+ btCurrency: tbtsingle(Dest^) := tbtcurrency(Src^);
+ btVariant: tbtsingle(Dest^) := Variant(src^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ btDouble:
+ begin
+ if srctype.BaseType = btPointer then
+ begin
+ srctype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
+ Src := Pointer(Src^);
+ if (src = nil) or (srctype = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case srctype.BaseType of
+ btU8: tbtdouble(Dest^) := tbtu8(src^);
+ btS8: tbtdouble(Dest^) := tbts8(src^);
+ btU16: tbtdouble(Dest^) := tbtu16(src^);
+ btS16: tbtdouble(Dest^) := tbts16(src^);
+ btU32: tbtdouble(Dest^) := tbtu32(src^);
+ btS32: tbtdouble(Dest^) := tbts32(src^);
+ {$IFNDEF PS_NOINT64} btS64: tbtdouble(Dest^) := tbts64(src^);{$ENDIF}
+ btSingle: tbtdouble(Dest^) := tbtsingle(Src^);
+ btDouble: tbtdouble(Dest^) := tbtdouble(Src^);
+ btExtended: tbtdouble(Dest^) := tbtextended(Src^);
+ btCurrency: tbtdouble(Dest^) := tbtcurrency(Src^);
+ btVariant: tbtdouble(Dest^) := Variant(src^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+
+ end;
+ btExtended:
+ begin
+ if srctype.BaseType = btPointer then
+ begin
+ srctype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^);
+ Src := Pointer(Src^);
+ if (src = nil) or (srctype = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case srctype.BaseType of
+ btU8: tbtextended(Dest^) := tbtu8(src^);
+ btS8: tbtextended(Dest^) := tbts8(src^);
+ btU16: tbtextended(Dest^) := tbtu16(src^);
+ btS16: tbtextended(Dest^) := tbts16(src^);
+ btU32: tbtextended(Dest^) := tbtu32(src^);
+ btS32: tbtextended(Dest^) := tbts32(src^);
+ {$IFNDEF PS_NOINT64} btS64: tbtextended(Dest^) := tbts64(src^);{$ENDIF}
+ btSingle: tbtextended(Dest^) := tbtsingle(Src^);
+ btDouble: tbtextended(Dest^) := tbtdouble(Src^);
+ btExtended: tbtextended(Dest^) := tbtextended(Src^);
+ btCurrency: tbtextended(Dest^) := tbtcurrency(Src^);
+ btVariant: tbtextended(Dest^) := Variant(src^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ btCurrency: tbtcurrency(Dest^) := PSGetCurrency(Src, srctype);
+ btPChar: pansichar(dest^) := pansichar(PSGetAnsiString(Src, srctype));
+ btString:
+ tbtstring(dest^) := PSGetAnsiString(Src, srctype);
+ btChar: tbtchar(dest^) := tbtchar(PSGetUInt(Src, srctype));
+ {$IFNDEF PS_NOWIDESTRING}
+ btWideString: tbtwidestring(dest^) := PSGetWideString(Src, srctype);
+ btUnicodeString: tbtUnicodeString(dest^) := PSGetUnicodeString(Src, srctype);
+ btWideChar: tbtwidechar(dest^) := widechar(PSGetUInt(Src, srctype));
+ {$ENDIF}
+ btStaticArray:
+ begin
+ if desttype <> srctype then
+ Result := False
+ else
+ CopyArrayContents(dest, Src, TPSTypeRec_StaticArray(desttype).Size, TPSTypeRec_StaticArray(desttype).ArrayType);
+ end;
+ btArray:
+ begin
+ if (srctype.BaseType = btStaticArray) and (TPSTypeRec_Array(desttype).ArrayType = TPSTypeRec_Array(srctype).ArrayType) then
+ begin
+ PSDynArraySetLength(Pointer(Dest^), desttype, TPSTypeRec_StaticArray(srctype).Size);
+ CopyArrayContents(Pointer(dest^), Src, TPSTypeRec_StaticArray(srctype).Size, TPSTypeRec_StaticArray(srctype).ArrayType);
+ end else if (srctype.BaseType = btvariant) and VarIsArray(Variant(src^)) then
+ Result := CreateArrayFromVariant(Self, dest, Variant(src^), desttype)
+ else if (desttype <> srctype) and not ((desttype.BaseType = btarray) and (srctype.BaseType = btArray)
+ and (TPSTypeRec_Array(desttype).ArrayType = TPSTypeRec_Array(srctype).ArrayType)) then
+ Result := False
+ else
+ CopyArrayContents(dest, src, 1, desttype);
+ end;
+ btRecord:
+ begin
+ if desttype <> srctype then
+ Result := False
+ else
+ CopyArrayContents(dest, Src, 1, desttype);
+ end;
+ btVariant:
+ begin
+{$IFNDEF PS_NOINTERFACES}
+ if srctype.ExportName = 'IDISPATCH' then
+ begin
+ {$IFDEF DELPHI3UP}
+ Variant(Dest^) := IDispatch(Src^);
+ {$ELSE}
+ AssignVariantFromIDispatch(Variant(Dest^), IDispatch(Src^));
+ {$ENDIF}
+ end else
+{$ENDIF}
+ if srctype.BaseType = btVariant then
+ variant(Dest^) := variant(src^)
+ else
+ begin
+ tt.VI.FType := FindType2(btPointer);
+ tt.DestType := srctype;
+ tt.DataDest := src;
+ tt.FreeIt := False;
+ Result := PIFVariantToVariant(@tt, variant(dest^));
+ end;
+ end;
+ btClass:
+ begin
+ if srctype.BaseType = btClass then
+ TObject(Dest^) := TObject(Src^)
+ else
+ // nx change start
+ if (srctype.BaseType in [btS32, btU32]) then
+ TbtU32(Dest^) := TbtU32(Src^)
+ else
+ // nx change end
+ Result := False;
+ end;
+{$IFNDEF PS_NOINTERFACES}
+ btInterface:
+ begin
+ if Srctype.BaseType = btVariant then
+ begin
+ if desttype.ExportName = 'IDISPATCH' then
+ begin
+ {$IFDEF Delphi3UP}
+ IDispatch(Dest^) := IDispatch(Variant(Src^));
+ {$ELSE}
+ AssignIDispatchFromVariant(IDispatch(Dest^), Variant(Src^));
+ {$ENDIF}
+ end else
+ Result := False;
+{$IFDEF Delphi3UP}
+ end else
+ if srctype.BaseType = btClass then
+ begin
+ if (TObject(Src^) = nil) or not TObject(Src^).GetInterface(TPSTypeRec_Interface(desttype).Guid, IUnknown(Dest^)) then
+ begin
+ Result := false;
+ Cmd_Err(erInterfaceNotSupported);
+ exit;
+ end;
+{$ENDIF}
+ end else if srctype.BaseType = btInterface then
+ begin
+ {$IFNDEF Delphi3UP}
+ if IUnknown(Dest^) <> nil then
+ begin
+ IUnknown(Dest^).Release;
+ IUnknown(Dest^) := nil;
+ end;
+ {$ENDIF}
+ IUnknown(Dest^) := IUnknown(Src^);
+ {$IFNDEF Delphi3UP}
+ if IUnknown(Dest^) <> nil then
+ IUnknown(Dest^).AddRef;
+ {$ENDIF}
+ end else
+ Result := False;
+ end;
+{$ENDIF}
+ else begin
+ Result := False;
+ end;
+ end;
+ if Result = False then
+ CMD_Err(ErTypeMismatch);
+ except
+ {$IFDEF DELPHI6UP}
+ Tmp := AcquireExceptionObject;
+ {$ELSE}
+ if RaiseList <> nil then
+ begin
+ Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject);
+ PRaiseFrame(RaiseList)^.ExceptObject := nil;
+ end else
+ Tmp := nil;
+ {$ENDIF}
+ if Tmp <> nil then
+ begin
+ if Tmp is EPSException then
+ begin
+ Result := False;
+ ExceptionProc(EPSException(tmp).ProcNo, EPSException(tmp).ProcPos, erCustomError, tbtString(EPSException(tmp).Message), nil);
+ exit;
+ end else
+ if Tmp is EDivByZero then
+ begin
+ Result := False;
+ CMD_Err3(erDivideByZero, '', Tmp);
+ Exit;
+ end;
+ if Tmp is EZeroDivide then
+ begin
+ Result := False;
+ CMD_Err3(erDivideByZero, '', Tmp);
+ Exit;
+ end;
+ if Tmp is EMathError then
+ begin
+ Result := False;
+ CMD_Err3(erMathError, '', Tmp);
+ Exit;
+ end;
+ end;
+ if (tmp <> nil) and (Tmp is Exception) then
+ CMD_Err3(erException, tbtString(Exception(Tmp).Message), Tmp)
+ else
+ CMD_Err3(erException, '', Tmp);
+ Result := False;
+ end;
+end;
+
+function SpecImport(Sender: TPSExec; p: TPSExternalProcRec; Tag: Pointer): Boolean; forward;
+
+
+function Class_IS(Self: TPSExec; Obj: TObject; var2type: TPSTypeRec): Boolean;
+var
+ R: TPSRuntimeClassImporter;
+ cc: TPSRuntimeClass;
+begin
+ if Obj = nil then
+ begin
+ Result := false;
+ exit;
+ end;
+ r := Self.FindSpecialProcImport(SpecImport);
+ if R = nil then
+ begin
+ Result := false;
+ exit;
+ end;
+ cc := r.FindClass(var2type.ExportName);
+ if cc = nil then
+ begin
+ result := false;
+ exit;
+ end;
+ try
+ Result := Obj is cc.FClass;
+ except
+ Result := false;
+ end;
+end;
+
+type
+ TVariantArray = array of Variant;
+ PVariantArray = ^TVariantArray;
+function VariantInArray(var1: Pointer; var1Type: TPSTypeRec; var2: PVariantArray): Boolean;
+var
+ lDest: Variant;
+ i: Integer;
+begin
+ IntPIFVariantToVariant(var1, var1Type, lDest);
+ result := false;
+ for i := 0 to Length(var2^) -1 do begin
+ if var2^[i] = lDest then begin
+ result := true;
+ break;
+ end;
+ end;
+end;
+
+
+function TPSExec.DoBooleanCalc(var1, Var2, into: Pointer; var1Type, var2type, intotype: TPSTypeRec; Cmd: Cardinal): Boolean;
+var
+ b: Boolean;
+ Tmp: TObject;
+ tvar: Variant;
+
+
+ procedure SetBoolean(b: Boolean; var Ok: Boolean);
+ begin
+ Ok := True;
+ case IntoType.BaseType of
+ btU8: tbtu8(Into^):= Cardinal(b);
+ btS8: tbts8(Into^) := Longint(b);
+ btU16: tbtu16(Into^) := Cardinal(b);
+ btS16: tbts16(Into^) := Longint(b);
+ btU32: tbtu32(Into^) := Cardinal(b);
+ btS32: tbts32(Into^) := Longint(b);
+ btVariant: Variant(Into^) := b;
+ else begin
+ CMD_Err(ErTypeMismatch);
+ Ok := False;
+ end;
+ end;
+ end;
+begin
+ Result := true;
+ try
+ case Cmd of
+ 0: begin { >= }
+ case var1Type.BaseType of
+ btU8:
+ if (var2Type.BaseType = btString) or (Var2Type.BaseType = btPChar) then
+ b := tbtchar(tbtu8(var1^)) >= PSGetAnsiString(Var2, var2type)
+ else
+ b := tbtu8(var1^) >= PSGetUInt(Var2, var2type);
+ btS8: b := tbts8(var1^) >= PSGetInt(Var2, var2type);
+ btU16: b := tbtu16(var1^) >= PSGetUInt(Var2, var2type);
+ btS16: b := tbts16(var1^) >= PSGetInt(Var2, var2type);
+ btU32: b := tbtu32(var1^) >= PSGetUInt(Var2, var2type);
+ btS32:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: b := tbts32(var1^) >= tbtu8(Var2^);
+ btS8: b := tbts32(var1^) >= tbts8(Var2^);
+ btU16: b := tbts32(var1^) >= tbtu16(Var2^);
+ btS16: b := tbts32(var1^) >= tbts16(Var2^);
+ btU32: b := tbts32(var1^) >= Longint(tbtu32(Var2^));
+ btS32: b := tbts32(var1^) >= tbts32(Var2^);
+ btDouble: b := PSGetReal(Var1, var1type) >= tbtdouble(var2^);
+ btSingle: B := psGetReal(Var1, var1Type) >= tbtsingle(var2^);
+ btExtended: B := psGetReal(Var1, var1Type) >= tbtExtended(var2^);
+ {$IFNDEF PS_NOINT64} btS64: b := tbts32(var1^) >= tbts64(Var2^);{$ENDIF}
+ btChar: b := tbts32(var1^) >= Ord(tbtchar(Var2^));
+ {$IFNDEF PS_NOWIDESTRING} btWideChar: b := tbts32(var1^) >= Ord(tbtwidechar(Var2^));{$ENDIF}
+ btVariant: b := tbts32(var1^) >= Variant(Var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ btSingle: b := tbtsingle(var1^) >= PSGetReal(Var2, var2type);
+ btDouble: b := tbtdouble(var1^) >= PSGetReal(Var2, var2type);
+ btCurrency: b := tbtcurrency(var1^) >= PSGetCurrency(Var2, var2type);
+ btExtended: b := tbtextended(var1^) >= PSGetReal(Var2, var2type);
+ {$IFNDEF PS_NOINT64}
+ btS64: b := tbts64(var1^) >= PSGetInt64(Var2, var2type);
+ {$ENDIF}
+ btPChar,btString: b := tbtstring(var1^) >= PSGetAnsiString(Var2, var2type);
+ btChar: b := tbtchar(var1^) >= PSGetAnsiString(Var2, var2type);
+ {$IFNDEF PS_NOWIDESTRING}
+ btWideChar: b := tbtwidechar(var1^) >= PSGetWideString(Var2, var2type);
+ btWideString: b := tbtwidestring(var1^) >= PSGetWideString(Var2, var2type);
+ btUnicodeString: b := tbtUnicodestring(var1^) >= PSGetUnicodeString(Var2, var2type);
+ {$ENDIF}
+ btVariant:
+ begin
+ if not IntPIFVariantToVariant(var2, var2type, tvar) then
+ begin
+ Result := false;
+ end else
+ b := Variant(var1^) >= tvar;
+ end;
+ btSet:
+ begin
+ if var1Type = var2Type then
+ begin
+ Set_Subset(var2, var1, TPSTypeRec_Set(var1Type).aByteSize, b);
+ end else result := False;
+ end;
+ else begin
+ CMD_Err(ErTypeMismatch);
+ exit;
+ end;
+ end;
+ if not Result then begin
+ CMD_Err(ErTypeMismatch);
+ exit;
+ end;
+ SetBoolean(b, Result);
+ end;
+ 1: begin { <= }
+ case var1Type.BaseType of
+ btU8:
+ if (var2Type.BaseType = btString) or (Var2Type.BaseType = btPChar) then
+ b := tbtchar(tbtu8(var1^)) <= PSGetAnsiString(Var2, var2type)
+ else
+ b := tbtu8(var1^) <= PSGetUInt(Var2, var2type);
+ btS8: b := tbts8(var1^) <= PSGetInt(Var2, var2type);
+ btU16: b := tbtu16(var1^) <= PSGetUInt(Var2, var2type);
+ btS16: b := tbts16(var1^) <= PSGetInt(Var2, var2type);
+ btU32: b := tbtu32(var1^) <= PSGetUInt(Var2, var2type);
+ btS32:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: b := tbts32(var1^) <= tbtu8(Var2^);
+ btS8: b := tbts32(var1^) <= tbts8(Var2^);
+ btU16: b := tbts32(var1^) <= tbtu16(Var2^);
+ btS16: b := tbts32(var1^) <= tbts16(Var2^);
+ btU32: b := tbts32(var1^) <= Longint(tbtu32(Var2^));
+ btS32: b := tbts32(var1^) <= tbts32(Var2^);
+ btDouble: b := PSGetReal(Var1, var1type) <= tbtdouble(var2^);
+ btSingle: B := psGetReal(Var1, var1Type) <= tbtsingle(var2^);
+ btExtended: B := psGetReal(Var1, var1Type) <= tbtExtended(var2^);
+ {$IFNDEF PS_NOINT64} btS64: b := tbts32(var1^) <= tbts64(Var2^);{$ENDIF}
+ btChar: b := tbts32(var1^) <= Ord(tbtchar(Var2^));
+ {$IFNDEF PS_NOWIDESTRING} btWideChar: b := tbts32(var1^) <= Ord(tbtwidechar(Var2^));{$ENDIF}
+ btVariant: b := tbts32(var1^) <= Variant(Var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end; btSingle: b := tbtsingle(var1^) <= PSGetReal(Var2, var2type);
+ btCurrency: b := tbtcurrency(var1^) <= PSGetCurrency(Var2, var2type);
+ btDouble: b := tbtdouble(var1^) <= PSGetReal(Var2, var2type);
+ btExtended: b := tbtextended(var1^) <= PSGetReal(Var2, var2type);
+ {$IFNDEF PS_NOINT64}
+ btS64: b := tbts64(var1^) <= PSGetInt64(Var2, var2type);
+ {$ENDIF}
+ btPChar,btString: b := tbtstring(var1^) <= PSGetAnsiString(Var2, var2type);
+ btChar: b := tbtchar(var1^) <= PSGetAnsiString(Var2, var2type);
+ {$IFNDEF PS_NOWIDESTRING}
+ btWideChar: b := tbtwidechar(var1^) <= PSGetWideString(Var2, var2type);
+ btWideString: b := tbtwidestring(var1^) <= PSGetWideString(Var2, var2type);
+ btUnicodeString: b := tbtUnicodestring(var1^) <= PSGetUnicodeString(Var2, var2type);
+ {$ENDIF}
+ btVariant:
+ begin
+ if not IntPIFVariantToVariant(var2, var2type, tvar) then
+ begin
+ Result := false;
+ end else
+ b := Variant(var1^) <= tvar;
+ end;
+ btSet:
+ begin
+ if var1Type = var2Type then
+ begin
+ Set_Subset(var1, var2, TPSTypeRec_Set(var1Type).aByteSize, b);
+ end else result := False;
+ end;
+ else begin
+ CMD_Err(ErTypeMismatch);
+ exit;
+ end;
+ end;
+ if not Result then begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ SetBoolean(b, Result);
+ end;
+ 2: begin { > }
+ case var1Type.BaseType of
+ btU8:
+ if (var2Type.BaseType = btString) or (Var2Type.BaseType = btPChar) then
+ b := tbtchar(tbtu8(var1^)) > PSGetAnsiString(Var2, var2type)
+ else
+ b := tbtu8(var1^) > PSGetUInt(Var2, var2type);
+ btS8: b := tbts8(var1^) > PSGetInt(Var2, var2type);
+ btU16: b := tbtu16(var1^) > PSGetUInt(Var2, var2type);
+ btS16: b := tbts16(var1^) > PSGetInt(Var2, var2type);
+ btU32: b := tbtu32(var1^) > PSGetUInt(Var2, var2type);
+ btS32:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: b := tbts32(var1^) > tbtu8(Var2^);
+ btS8: b := tbts32(var1^) > tbts8(Var2^);
+ btU16: b := tbts32(var1^) > tbtu16(Var2^);
+ btS16: b := tbts32(var1^) > tbts16(Var2^);
+ btU32: b := tbts32(var1^) > Longint(tbtu32(Var2^));
+ btS32: b := tbts32(var1^) > tbts32(Var2^);
+ btDouble: b := PSGetReal(Var1, var1type) > tbtdouble(var2^);
+ btSingle: B := psGetReal(Var1, var1Type) > tbtsingle(var2^);
+ btExtended: B := psGetReal(Var1, var1Type) > tbtExtended(var2^);
+ {$IFNDEF PS_NOINT64} btS64: b := tbts32(var1^) > tbts64(Var2^);{$ENDIF}
+ btChar: b := tbts32(var1^) > Ord(tbtchar(Var2^));
+ {$IFNDEF PS_NOWIDESTRING} btWideChar: b := tbts32(var1^) = Ord(tbtwidechar(Var2^));{$ENDIF}
+ btVariant: b := tbts32(var1^) > Variant(Var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end; btSingle: b := tbtsingle(var1^) > PSGetReal(Var2, var2type);
+ btDouble: b := tbtdouble(var1^) > PSGetReal(Var2, var2type);
+ btExtended: b := tbtextended(var1^) > PSGetReal(Var2, var2type);
+ btCurrency: b := tbtcurrency(var1^) > PSGetCurrency(Var2, var2type);
+ {$IFNDEF PS_NOINT64}
+ btS64: b := tbts64(var1^) > PSGetInt64(Var2, var2type);
+ {$ENDIF}
+ btPChar,btString: b := tbtstring(var1^) > PSGetAnsiString(Var2, var2type);
+ btChar: b := tbtchar(var1^) > PSGetAnsiString(Var2, var2type);
+ {$IFNDEF PS_NOWIDESTRING}
+ btWideChar: b := tbtwidechar(var1^) > PSGetWideString(Var2, var2type);
+ btWideString: b := tbtwidestring(var1^) > PSGetWideString(Var2, var2type);
+ btUnicodeString: b := tbtUnicodestring(var1^) > PSGetUnicodeString(Var2, var2type);
+ {$ENDIF}
+ btVariant:
+ begin
+ if not IntPIFVariantToVariant(var2, var2type, tvar) then
+ begin
+ Result := false;
+ end else
+ b := Variant(var1^) > tvar;
+ end;
+ else begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ end;
+ if not Result then begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ SetBoolean(b, Result);
+ end;
+ 3: begin { < }
+ case var1Type.BaseType of
+ btU8:
+ if (var2Type.BaseType = btString) or (Var2Type.BaseType = btPChar) then
+ b := tbtchar(tbtu8(var1^)) < PSGetAnsiString(Var2, var2type)
+ else
+ b := tbtu8(var1^) < PSGetUInt(Var2, var2type);
+ btS8: b := tbts8(var1^) < PSGetInt(Var2, var2type);
+ btU16: b := tbtu16(var1^) < PSGetUInt(Var2, var2type);
+ btS16: b := tbts16(var1^) < PSGetInt(Var2, var2type);
+ btU32: b := tbtu32(var1^) < PSGetUInt(Var2, var2type);
+ btS32:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: b := tbts32(var1^) < tbtu8(Var2^);
+ btS8: b := tbts32(var1^) < tbts8(Var2^);
+ btU16: b := tbts32(var1^) < tbtu16(Var2^);
+ btS16: b := tbts32(var1^) < tbts16(Var2^);
+ btU32: b := tbts32(var1^) < Longint(tbtu32(Var2^));
+ btS32: b := tbts32(var1^) < tbts32(Var2^);
+ btDouble: b := PSGetReal(Var1, var1type) < tbtdouble(var2^);
+ btSingle: B := psGetReal(Var1, var1Type) < tbtsingle(var2^);
+ btExtended: B := psGetReal(Var1, var1Type) < tbtExtended(var2^);
+ {$IFNDEF PS_NOINT64} btS64: b := tbts32(var1^) < tbts64(Var2^);{$ENDIF}
+ btChar: b := tbts32(var1^) < Ord(tbtchar(Var2^));
+ {$IFNDEF PS_NOWIDESTRING} btWideChar: b := tbts32(var1^) < Ord(tbtwidechar(Var2^));{$ENDIF}
+ btVariant: b := tbts32(var1^) < Variant(Var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end; btSingle: b := tbtsingle(var1^) < PSGetReal(Var2, var2type);
+ btDouble: b := tbtdouble(var1^) < PSGetReal(Var2, var2type);
+ btCurrency: b := tbtcurrency(var1^) < PSGetCurrency(Var2, var2type);
+ btExtended: b := tbtextended(var1^) < PSGetReal(Var2, var2type);
+ {$IFNDEF PS_NOINT64}
+ btS64: b := tbts64(var1^) < PSGetInt64(Var2, var2type);
+ {$ENDIF}
+ btPChar,btString: b := tbtstring(var1^) < PSGetAnsiString(Var2, var2type);
+ btChar: b := tbtchar(var1^) < PSGetAnsiString(Var2, var2type);
+ {$IFNDEF PS_NOWIDESTRING}
+ btWideChar: b := tbtwidechar(var1^) < PSGetWideString(Var2, var2type);
+ btWideString: b := tbtwidestring(var1^) < PSGetWideString(Var2, var2type);
+ btUnicodeString: b := tbtUnicodestring(var1^) < PSGetUnicodeString(Var2, var2type);
+ {$ENDIF}
+ btVariant:
+ begin
+ if not IntPIFVariantToVariant(var2, var2type, tvar) then
+ begin
+ Result := false;
+ end else
+ b := Variant(var1^) < tvar;
+ end;
+ else begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ end;
+ if not Result then begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ SetBoolean(b, Result);
+ end;
+ 4: begin { <> }
+ case var1Type.BaseType of
+ btInterface:
+ begin
+ if var2Type.BaseType = btInterface then
+ b := Pointer(var1^) <> Pointer(var2^) // no need to cast it to IUnknown
+ else
+ Result := false;
+ end;
+ btClass:
+ begin
+ if var2Type.BaseType = btclass then
+ b := TObject(var1^) <> TObject(var2^)
+ else
+ Result := false;
+ end;
+ btU8:
+ if (var2Type.BaseType = btString) or (Var2Type.BaseType = btPChar) then
+ b := tbtchar(tbtu8(var1^)) <> PSGetAnsiString(Var2, var2type)
+ else
+ b := tbtu8(var1^) <> PSGetUInt(Var2, var2type);
+ btS8: b := tbts8(var1^) <> PSGetInt(Var2, var2type);
+ btU16: b := tbtu16(var1^) <> PSGetUInt(Var2, var2type);
+ btS16: b := tbts16(var1^) <> PSGetInt(Var2, var2type);
+ btProcPtr:
+ begin
+ if Pointer(Var1^) = Pointer(Var2^) then
+ begin
+ if Longint(Var1^) = 0 then
+ b := ((Pointer(Pointer(IPointer(Var1)+PointerSize2)^) <> Pointer(Pointer(IPointer(Var2)+PointerSize2)^)) or
+ (Pointer(Pointer(IPointer(Var1)+PointerSize2)^) <> Pointer(Pointer(IPointer(Var2)+PointerSize2)^)))
+ else
+ b := False;
+ end else b := True;
+ end;
+ btU32: b := tbtu32(var1^) <> PSGetUInt(Var2, var2type);
+ btS32:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: b := tbts32(var1^) <> tbtu8(Var2^);
+ btS8: b := tbts32(var1^) <> tbts8(Var2^);
+ btU16: b := tbts32(var1^) <> tbtu16(Var2^);
+ btS16: b := tbts32(var1^) <> tbts16(Var2^);
+ btProcPtr, btU32: b := tbts32(var1^)<> Longint(tbtu32(Var2^));
+ btS32: b := tbts32(var1^) <> tbts32(Var2^);
+ btDouble: b := PSGetReal(Var1, var1type) <> tbtdouble(var2^);
+ btSingle: B := psGetReal(Var1, var1Type) <> tbtsingle(var2^);
+ btExtended: B := psGetReal(Var1, var1Type) <> tbtExtended(var2^);
+ {$IFNDEF PS_NOINT64} btS64: b := tbts32(var1^) <> tbts64(Var2^);{$ENDIF}
+ btChar: b := tbts32(var1^) <> Ord(tbtchar(Var2^));
+ {$IFNDEF PS_NOWIDESTRING} btWideChar: b := tbts32(var1^) <> Ord(tbtwidechar(Var2^));{$ENDIF}
+ btVariant: b := tbts32(var1^) <> Variant(Var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end; btSingle: b := tbtsingle(var1^) <> PSGetReal(Var2, var2type);
+ btDouble: b := tbtdouble(var1^) <> PSGetReal(Var2, var2type);
+ btExtended: b := tbtextended(var1^) <> PSGetReal(Var2, var2type);
+ btCurrency: b := tbtcurrency(var1^) <> PSGetCurrency(Var2, var2type);
+ btPChar,btString: b := tbtstring(var1^) <> PSGetAnsiString(Var2, var2type);
+ {$IFNDEF PS_NOINT64}
+ btS64: b := tbts64(var1^) <> PSGetInt64(Var2, var2type);
+ {$ENDIF}
+ btChar: b := tbtchar(var1^) <> PSGetAnsiString(Var2, var2type);
+ {$IFNDEF PS_NOWIDESTRING}
+ btWideChar: b := tbtwidechar(var1^) <> PSGetWideString(Var2, var2type);
+ btWideString: b := tbtwidestring(var1^) <> PSGetWideString(Var2, var2type);
+ btUnicodeString: b := tbtUnicodeString(var1^) <> PSGetUnicodeString(Var2, var2type);
+ {$ENDIF}
+ btVariant:
+ begin
+ if not IntPIFVariantToVariant(var2, var2type, tvar) then
+ begin
+ Result := false;
+ end else
+ b := Variant(var1^) <> tvar;
+ end;
+ btSet:
+ begin
+ if var1Type = var2Type then
+ begin
+ Set_Equal(var1, var2, TPSTypeRec_Set(var1Type).aByteSize, b);
+ b := not b;
+ end else result := False;
+ end;
+ else begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ end;
+ if not Result then begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ SetBoolean(b, Result);
+ end;
+ 5: begin { = }
+ case var1Type.BaseType of
+ btInterface:
+ begin
+ if var2Type.BaseType = btInterface then
+ b := Pointer(var1^) = Pointer(var2^) // no need to cast it to IUnknown
+ else
+ Result := false;
+ end;
+ btClass:
+ begin
+ if var2Type.BaseType = btclass then
+ b := TObject(var1^) = TObject(var2^)
+ else
+ Result := false;
+ end;
+ btU8:
+ if (var2Type.BaseType = btString) or (Var2Type.BaseType = btPChar) then
+ b := tbtchar(tbtu8(var1^)) = PSGetAnsiString(Var2, var2type)
+ else
+ b := tbtu8(var1^) = PSGetUInt(Var2, var2type);
+ btS8: b := tbts8(var1^) = PSGetInt(Var2, var2type);
+ btU16: b := tbtu16(var1^) = PSGetUInt(Var2, var2type);
+ btS16: b := tbts16(var1^) = PSGetInt(Var2, var2type);
+ btU32: b := tbtu32(var1^) = PSGetUInt(Var2, var2type);
+ btProcPtr:
+ begin
+ if Pointer(Var1^) = Pointer(Var2^) then
+ begin
+ if Longint(Var1^) = 0 then
+ b := ((Pointer(Pointer(IPointer(Var1)+PointerSize2)^) = Pointer(Pointer(IPointer(Var2)+PointerSize2)^)) and
+ (Pointer(Pointer(IPointer(Var1)+PointerSize2)^) = Pointer(Pointer(IPointer(Var2)+PointerSize2)^)))
+ else
+ b := True;
+ end else b := False;
+ end;
+ btS32:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: b := tbts32(var1^) = tbtu8(Var2^);
+ btS8: b := tbts32(var1^) = tbts8(Var2^);
+ btU16: b := tbts32(var1^) = tbtu16(Var2^);
+ btS16: b := tbts32(var1^) = tbts16(Var2^);
+ btProcPtr, btU32: b := tbts32(var1^) = Longint(tbtu32(Var2^));
+ btS32: b := tbts32(var1^) = tbts32(Var2^);
+ btDouble: b := PSGetReal(Var1, var1type) = tbtdouble(var2^);
+ btSingle: B := psGetReal(Var1, var1Type) = tbtsingle(var2^);
+ btExtended: B := psGetReal(Var1, var1Type) = tbtExtended(var2^);
+ {$IFNDEF PS_NOINT64} btS64: b := tbts32(var1^) = tbts64(Var2^);{$ENDIF}
+ btChar: b := tbts32(var1^) = Ord(tbtchar(Var2^));
+ {$IFNDEF PS_NOWIDESTRING} btWideChar: b := tbts32(var1^) = Ord(tbtwidechar(Var2^));{$ENDIF}
+ btVariant: b := tbts32(var1^) = Variant(Var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end; btSingle: b := tbtsingle(var1^) = PSGetReal(Var2, var2type);
+ btDouble: b := tbtdouble(var1^) = PSGetReal(Var2, var2type);
+ btExtended: b := tbtextended(var1^) = PSGetReal(Var2, var2type);
+ btCurrency: b := tbtcurrency(var1^) = PSGetCurrency(Var2, var2type);
+ btPchar, btString: b := tbtstring(var1^) = PSGetAnsiString(Var2, var2type);
+ {$IFNDEF PS_NOINT64}
+ btS64: b := tbts64(var1^) = PSGetInt64(Var2, var2type);
+ {$ENDIF}
+ btChar: b := tbtchar(var1^) = PSGetAnsiString(Var2, var2type);
+ {$IFNDEF PS_NOWIDESTRING}
+ btWideChar: b := tbtwidechar(var1^) = PSGetWideString(Var2, var2type);
+ btWideString: b := tbtwidestring(var1^) = PSGetWideString(Var2, var2type);
+ btUnicodeString: b := tbtUnicodestring(var1^) = PSGetUnicodeString(Var2, var2type);
+ {$ENDIF}
+ btVariant:
+ begin
+ if not IntPIFVariantToVariant(var2, var2type, tvar) then
+ begin
+ Result := false;
+ end else
+ b := Variant(var1^) = tvar;
+ end;
+ btSet:
+ begin
+ if var1Type = var2Type then
+ begin
+ Set_Equal(var1, var2, TPSTypeRec_Set(var1Type).aByteSize, b);
+ end else result := False;
+ end;
+ else begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ end;
+ if not Result then begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ SetBoolean(b, Result);
+ end;
+ 6: begin { in }
+ if (var2Type.BaseType = btArray) and (TPSTypeRec_Array(var2type).ArrayType.BaseType = btVariant) then
+ begin
+ b := VariantInArray(var1, var1Type, var2);
+ SetBoolean(b, Result);
+ end else
+ if var2Type.BaseType = btSet then
+ begin
+ Cmd := PSGetUInt(var1, var1type);
+ if not Result then
+ begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ if Cmd >= Cardinal(TPSTypeRec_Set(var2Type).aBitSize) then
+ begin
+ cmd_Err(erOutofRecordRange);
+ Result := False;
+ Exit;
+ end;
+ Set_membership(Cmd, var2, b);
+ SetBoolean(b, Result);
+ end else
+ begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ end;
+ 7:
+ begin // is
+ case var1Type.BaseType of
+ btClass:
+ begin
+ if var2type.BaseType <> btU32 then
+ Result := False
+ else
+ begin
+ var2type := FTypes[tbtu32(var2^)];
+ if (var2type = nil) or (var2type.BaseType <> btClass) then
+ Result := false
+ else
+ begin
+ Setboolean(Class_IS(Self, TObject(var1^), var2type), Result);
+ end;
+ end;
+ end;
+ else begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ end;
+ if not Result then begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ end;
+ else begin
+ Result := False;
+ CMD_Err(erInvalidOpcodeParameter);
+ exit;
+ end;
+ end;
+ except
+ {$IFDEF DELPHI6UP}
+ Tmp := AcquireExceptionObject;
+ {$ELSE}
+ if RaiseList <> nil then
+ begin
+ Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject);
+ PRaiseFrame(RaiseList)^.ExceptObject := nil;
+ end else
+ Tmp := nil;
+ {$ENDIF}
+ if Tmp <> nil then
+ begin
+ if Tmp is EPSException then
+ begin
+ Result := False;
+ ExceptionProc(EPSException(tmp).ProcNo, EPSException(tmp).ProcPos, erCustomError, tbtString(EPSException(tmp).Message), nil);
+ exit;
+ end else
+ if Tmp is EDivByZero then
+ begin
+ Result := False;
+ CMD_Err3(erDivideByZero, '', Tmp);
+ Exit;
+ end;
+ if Tmp is EZeroDivide then
+ begin
+ Result := False;
+ CMD_Err3(erDivideByZero, '', Tmp);
+ Exit;
+ end;
+ if Tmp is EMathError then
+ begin
+ Result := False;
+ CMD_Err3(erMathError, '', Tmp);
+ Exit;
+ end;
+ end;
+ if (tmp <> nil) and (Tmp is Exception) then
+ CMD_Err3(erException, tbtString(Exception(Tmp).Message), Tmp)
+ else
+ CMD_Err3(erException, '', Tmp);
+ Result := False;
+ end;
+end;
+
+function VarIsFloat(const V: Variant): Boolean;
+begin
+ Result := VarType(V) in [varSingle, varDouble, varCurrency];
+end;
+
+function TPSExec.DoCalc(var1, Var2: Pointer; var1Type, var2type: TPSTypeRec; CalcType: Cardinal): Boolean;
+ { var1=dest, var2=src }
+var
+ Tmp: TObject;
+ tvar: Variant;
+begin
+ try
+ Result := True;
+ case CalcType of
+ 0: begin { + }
+ case var1Type.BaseType of
+ btU8: tbtU8(var1^) := tbtU8(var1^) + PSGetUInt(Var2, var2type);
+ btS8: tbts8(var1^) := tbts8(var1^) + PSGetInt(Var2, var2type);
+ btU16: tbtU16(var1^) := tbtU16(var1^) + PSGetUInt(Var2, var2type);
+ btS16: tbts16(var1^) := tbts16(var1^) + PSGetInt(Var2, var2type);
+ btU32:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: tbtU32(var1^) := tbtU32(var1^) + tbtu8(var2^);
+ btS8: tbtU32(var1^) := tbtU32(var1^) + cardinal(longint(tbts8(var2^)));
+ btU16: tbtU32(var1^) := tbtU32(var1^) + tbtu16(var2^);
+ btS16: tbtU32(var1^) := tbtU32(var1^) + cardinal(longint(tbts16(var2^)));
+ btU32: tbtU32(var1^) := tbtU32(var1^) + tbtu32(var2^);
+ btS32: tbtU32(var1^) := tbtU32(var1^) + cardinal(tbts32(var2^));
+ {$IFNDEF PS_NOINT64} btS64: tbtU32(var1^) := tbtU32(var1^) + tbts64(var2^);{$ENDIF}
+ btChar: tbtU32(var1^) := tbtU32(var1^) + Ord(tbtchar(var2^));
+ {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtU32(var1^) := tbtU32(var1^) + Ord(tbtwidechar(var2^));{$ENDIF}
+ btVariant: tbtU32(var1^) := tbtU32(var1^) + Variant(var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ btS32:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: tbts32(var1^) := tbts32(var1^) + tbtu8(var2^);
+ btS8: tbts32(var1^) := tbts32(var1^) + tbts8(var2^);
+ btU16: tbts32(var1^) := tbts32(var1^) + tbtu16(var2^);
+ btS16: tbts32(var1^) := tbts32(var1^) + tbts16(var2^);
+ btU32: tbts32(var1^) := tbts32(var1^) + Longint(tbtu32(var2^));
+ btS32: tbts32(var1^) := tbts32(var1^) + tbts32(var2^);
+ {$IFNDEF PS_NOINT64} btS64: tbts32(var1^) := tbts32(var1^) + tbts64(var2^);{$ENDIF}
+ btChar: tbts32(var1^) := tbts32(var1^) + Ord(tbtchar(var2^));
+ {$IFNDEF PS_NOWIDESTRING} btWideChar: tbts32(var1^) := tbts32(var1^) + Ord(tbtwidechar(var2^));{$ENDIF}
+ btVariant: tbts32(var1^) := tbts32(var1^) + Variant(var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ {$IFNDEF PS_NOINT64}
+ btS64: tbts64(var1^) := tbts64(var1^) + PSGetInt64(var2, var2type);
+ {$ENDIF}
+ btSingle:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: tbtsingle(var1^) := tbtsingle(var1^) + tbtu8(var2^);
+ btS8: tbtsingle(var1^) := tbtsingle(var1^) + tbts8(var2^);
+ btU16: tbtsingle(var1^) := tbtsingle(var1^) + tbtu16(var2^);
+ btS16: tbtsingle(var1^) := tbtsingle(var1^) + tbts16(var2^);
+ btU32: tbtsingle(var1^) := tbtsingle(var1^) + tbtu32(var2^);
+ btS32: tbtsingle(var1^) := tbtsingle(var1^) + tbts32(var2^);
+ {$IFNDEF PS_NOINT64} btS64: tbtsingle(var1^) := tbtsingle(var1^) + tbts64(var2^);{$ENDIF}
+ btSingle: tbtsingle(var1^) := tbtsingle(var1^) + tbtsingle(var2^);
+ btDouble: tbtsingle(var1^) := tbtsingle(var1^) + tbtdouble(var2^);
+ btExtended: tbtsingle(var1^) := tbtsingle(var1^) + tbtextended(var2^);
+ btCurrency: tbtsingle(var1^) := tbtsingle(var1^) + tbtcurrency(var2^);
+ btVariant: tbtsingle(var1^) := tbtsingle(var1^) + Variant(var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ btDouble:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: tbtdouble(var1^) := tbtdouble(var1^) + tbtu8(var2^);
+ btS8: tbtdouble(var1^) := tbtdouble(var1^) + tbts8(var2^);
+ btU16: tbtdouble(var1^) := tbtdouble(var1^) + tbtu16(var2^);
+ btS16: tbtdouble(var1^) := tbtdouble(var1^) + tbts16(var2^);
+ btU32: tbtdouble(var1^) := tbtdouble(var1^) + tbtu32(var2^);
+ btS32: tbtdouble(var1^) := tbtdouble(var1^) + tbts32(var2^);
+ {$IFNDEF PS_NOINT64} btS64: tbtdouble(var1^) := tbtdouble(var1^) + tbts64(var2^);{$ENDIF}
+ btSingle: tbtdouble(var1^) := tbtdouble(var1^) + tbtsingle(var2^);
+ btDouble: tbtdouble(var1^) := tbtdouble(var1^) + tbtdouble(var2^);
+ btExtended: tbtdouble(var1^) := tbtdouble(var1^) + tbtextended(var2^);
+ btCurrency: tbtdouble(var1^) := tbtdouble(var1^) + tbtcurrency(var2^);
+ btVariant: tbtdouble(var1^) := tbtdouble(var1^) + Variant(var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ btCurrency:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: tbtcurrency(var1^) := tbtcurrency(var1^) + tbtu8(var2^);
+ btS8: tbtcurrency(var1^) := tbtcurrency(var1^) + tbts8(var2^);
+ btU16: tbtcurrency(var1^) := tbtcurrency(var1^) + tbtu16(var2^);
+ btS16: tbtcurrency(var1^) := tbtcurrency(var1^) + tbts16(var2^);
+ btU32: tbtcurrency(var1^) := tbtdouble(var1^) + tbtu32(var2^);
+ btS32: tbtcurrency(var1^) := tbtcurrency(var1^) + tbts32(var2^);
+ {$IFNDEF PS_NOINT64} btS64: tbtcurrency(var1^) := tbtdouble(var1^) + tbts64(var2^);{$ENDIF}
+ btSingle: tbtcurrency(var1^) := tbtcurrency(var1^) + tbtsingle(var2^);
+ btDouble: tbtcurrency(var1^) := tbtcurrency(var1^) + tbtdouble(var2^);
+ btExtended: tbtcurrency(var1^) := tbtcurrency(var1^) + tbtextended(var2^);
+ btCurrency: tbtcurrency(var1^) := tbtcurrency(var1^) + tbtcurrency(var2^);
+ btVariant: tbtcurrency(var1^) := tbtcurrency(var1^) + Variant(var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ btExtended:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: tbtextended(var1^) := tbtextended(var1^) + tbtu8(var2^);
+ btS8: tbtextended(var1^) := tbtextended(var1^) + tbts8(var2^);
+ btU16: tbtextended(var1^) := tbtextended(var1^) + tbtu16(var2^);
+ btS16: tbtextended(var1^) := tbtextended(var1^) + tbts16(var2^);
+ btU32: tbtextended(var1^) := tbtextended(var1^) + tbtu32(var2^);
+ btS32: tbtextended(var1^) := tbtextended(var1^) + tbts32(var2^);
+ {$IFNDEF PS_NOINT64} btS64: tbtextended(var1^) := tbtextended(var1^) + tbts64(var2^);{$ENDIF}
+ btSingle: tbtextended(var1^) := tbtextended(var1^) + tbtsingle(var2^);
+ btDouble: tbtextended(var1^) := tbtextended(var1^) + tbtdouble(var2^);
+ btExtended: tbtextended(var1^) := tbtextended(var1^) + tbtextended(var2^);
+ btCurrency: tbtextended(var1^) := tbtextended(var1^) + tbtcurrency(var2^);
+ btVariant: tbtextended(var1^) := tbtextended(var1^) + Variant(var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ btPchar, btString: tbtstring(var1^) := tbtstring(var1^) + PSGetAnsiString(Var2, var2type);
+ btChar: tbtchar(var1^) := tbtchar(ord(tbtchar(var1^)) + PSGetUInt(Var2, var2type));
+ {$IFNDEF PS_NOWIDESTRING}
+ btWideChar: tbtwidechar(var1^) := widechar(ord(tbtwidechar(var1^)) + PSGetUInt(Var2, var2type));
+ btWideString: tbtwidestring(var1^) := tbtwidestring(var1^) + PSGetWideString(Var2, var2type);
+ btUnicodeString: tbtUnicodestring(var1^) := tbtUnicodestring(var1^) + PSGetUnicodeString(Var2, var2type);
+ {$ENDIF}
+ btVariant:
+ begin
+ tvar := null;
+ if not IntPIFVariantToVariant(var2, var2type, tvar) then
+ begin
+ Result := false;
+ end else
+ Variant(var1^) := Variant(var1^) + tvar;
+ end;
+ btSet:
+ begin
+ if var1Type = var2Type then
+ begin
+ Set_Union(var1, var2, TPSTypeRec_Set(var1Type).aByteSize);
+ end else result := False;
+ end;
+
+ else begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ end;
+ if not Result then begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ end;
+ 1: begin { - }
+ case var1Type.BaseType of
+ btU8: tbtU8(var1^) := tbtU8(var1^) - PSGetUInt(Var2, var2type);
+ btS8: tbts8(var1^) := tbts8(var1^) - PSGetInt(Var2, var2type);
+ btU16: tbtU16(var1^) := tbtU16(var1^) - PSGetUInt(Var2, var2type);
+ btS16: tbts16(var1^) := tbts16(var1^) - PSGetInt(Var2, var2type);
+ btU32:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: tbtU32(var1^) := tbtU32(var1^) - tbtu8(var2^);
+ btS8: tbtU32(var1^) := tbtU32(var1^) - cardinal(longint(tbts8(var2^)));
+ btU16: tbtU32(var1^) := tbtU32(var1^) - tbtu16(var2^);
+ btS16: tbtU32(var1^) := tbtU32(var1^) - cardinal(longint(tbts16(var2^)));
+ btU32: tbtU32(var1^) := tbtU32(var1^) - tbtu32(var2^);
+ btS32: tbtU32(var1^) := tbtU32(var1^) - cardinal(tbts32(var2^));
+ {$IFNDEF PS_NOINT64} btS64: tbtU32(var1^) := tbtU32(var1^) - tbts64(var2^);{$ENDIF}
+ btChar: tbtU32(var1^) := tbtU32(var1^) - Ord(tbtchar(var2^));
+ {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtU32(var1^) := tbtU32(var1^) - Ord(tbtwidechar(var2^));{$ENDIF}
+ btVariant: tbtU32(var1^) := tbtU32(var1^) - Variant(var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ btS32:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: tbts32(var1^) := tbts32(var1^) - tbtu8(var2^);
+ btS8: tbts32(var1^) := tbts32(var1^) - tbts8(var2^);
+ btU16: tbts32(var1^) := tbts32(var1^) - tbtu16(var2^);
+ btS16: tbts32(var1^) := tbts32(var1^) - tbts16(var2^);
+ btU32: tbts32(var1^) := tbts32(var1^) - Longint(tbtu32(var2^));
+ btS32: tbts32(var1^) := tbts32(var1^) - tbts32(var2^);
+ {$IFNDEF PS_NOINT64} btS64: tbts32(var1^) := tbts32(var1^) - tbts64(var2^);{$ENDIF}
+ btChar: tbts32(var1^) := tbts32(var1^) - Ord(tbtchar(var2^));
+ {$IFNDEF PS_NOWIDESTRING} btWideChar: tbts32(var1^) := tbts32(var1^) - Ord(tbtwidechar(var2^));{$ENDIF}
+ btVariant: tbts32(var1^) := tbts32(var1^) - Variant(var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ {$IFNDEF PS_NOINT64}
+ btS64: tbts64(var1^) := tbts64(var1^) - PSGetInt64(var2, var2type);
+ {$ENDIF}
+ btSingle:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: tbtsingle(var1^) := tbtsingle(var1^) - tbtu8(var2^);
+ btS8: tbtsingle(var1^) := tbtsingle(var1^) - tbts8(var2^);
+ btU16: tbtsingle(var1^) := tbtsingle(var1^) - tbtu16(var2^);
+ btS16: tbtsingle(var1^) := tbtsingle(var1^) - tbts16(var2^);
+ btU32: tbtsingle(var1^) := tbtsingle(var1^) - tbtu32(var2^);
+ btS32: tbtsingle(var1^) := tbtsingle(var1^) - tbts32(var2^);
+ {$IFNDEF PS_NOINT64} btS64: tbtsingle(var1^) := tbtsingle(var1^) - tbts64(var2^);{$ENDIF}
+ btSingle: tbtsingle(var1^) := tbtsingle(var1^) - tbtsingle(var2^);
+ btDouble: tbtsingle(var1^) := tbtsingle(var1^) - tbtdouble(var2^);
+ btExtended: tbtsingle(var1^) := tbtsingle(var1^) - tbtextended(var2^);
+ btCurrency: tbtsingle(var1^) := tbtsingle(var1^) - tbtcurrency(var2^);
+ btVariant: tbtsingle(var1^) := tbtsingle(var1^) - Variant(var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ btCurrency:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: tbtcurrency(var1^) := tbtcurrency(var1^) - tbtu8(var2^);
+ btS8: tbtcurrency(var1^) := tbtcurrency(var1^) - tbts8(var2^);
+ btU16: tbtcurrency(var1^) := tbtcurrency(var1^) - tbtu16(var2^);
+ btS16: tbtcurrency(var1^) := tbtcurrency(var1^) - tbts16(var2^);
+ btU32: tbtcurrency(var1^) := tbtdouble(var1^) - tbtu32(var2^);
+ btS32: tbtcurrency(var1^) := tbtcurrency(var1^) - tbts32(var2^);
+ {$IFNDEF PS_NOINT64} btS64: tbtcurrency(var1^) := tbtdouble(var1^) - tbts64(var2^);{$ENDIF}
+ btSingle: tbtcurrency(var1^) := tbtcurrency(var1^) - tbtsingle(var2^);
+ btDouble: tbtcurrency(var1^) := tbtcurrency(var1^) - tbtdouble(var2^);
+ btExtended: tbtcurrency(var1^) := tbtcurrency(var1^) - tbtextended(var2^);
+ btCurrency: tbtcurrency(var1^) := tbtcurrency(var1^) - tbtcurrency(var2^);
+ btVariant: tbtcurrency(var1^) := tbtcurrency(var1^) - Variant(var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ btDouble:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: tbtdouble(var1^) := tbtdouble(var1^) - tbtu8(var2^);
+ btS8: tbtdouble(var1^) := tbtdouble(var1^) - tbts8(var2^);
+ btU16: tbtdouble(var1^) := tbtdouble(var1^) - tbtu16(var2^);
+ btS16: tbtdouble(var1^) := tbtdouble(var1^) - tbts16(var2^);
+ btU32: tbtdouble(var1^) := tbtdouble(var1^) - tbtu32(var2^);
+ btS32: tbtdouble(var1^) := tbtdouble(var1^) - tbts32(var2^);
+ {$IFNDEF PS_NOINT64} btS64: tbtdouble(var1^) := tbtdouble(var1^) - tbts64(var2^);{$ENDIF}
+ btSingle: tbtdouble(var1^) := tbtdouble(var1^) - tbtsingle(var2^);
+ btDouble: tbtdouble(var1^) := tbtdouble(var1^) - tbtdouble(var2^);
+ btExtended: tbtdouble(var1^) := tbtdouble(var1^) - tbtextended(var2^);
+ btCurrency: tbtdouble(var1^) := tbtdouble(var1^) - tbtcurrency(var2^);
+ btVariant: tbtdouble(var1^) := tbtdouble(var1^) - Variant(var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ btExtended:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: tbtextended(var1^) := tbtextended(var1^) - tbtu8(var2^);
+ btS8: tbtextended(var1^) := tbtextended(var1^) - tbts8(var2^);
+ btU16: tbtextended(var1^) := tbtextended(var1^) - tbtu16(var2^);
+ btS16: tbtextended(var1^) := tbtextended(var1^) - tbts16(var2^);
+ btU32: tbtextended(var1^) := tbtextended(var1^) - tbtu32(var2^);
+ btS32: tbtextended(var1^) := tbtextended(var1^) - tbts32(var2^);
+ {$IFNDEF PS_NOINT64} btS64: tbtextended(var1^) := tbtextended(var1^) -+tbts64(var2^);{$ENDIF}
+ btSingle: tbtextended(var1^) := tbtextended(var1^) - tbtsingle(var2^);
+ btDouble: tbtextended(var1^) := tbtextended(var1^) - tbtdouble(var2^);
+ btExtended: tbtextended(var1^) := tbtextended(var1^) - tbtextended(var2^);
+ btCurrency: tbtextended(var1^) := tbtextended(var1^) - tbtcurrency(var2^);
+ btVariant: tbtextended(var1^) := tbtextended(var1^) - Variant(var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ btChar: tbtchar(var1^):= tbtchar(ord(tbtchar(var1^)) - PSGetUInt(Var2, var2type));
+ {$IFNDEF PS_NOWIDESTRING}
+ btWideChar: tbtwidechar(var1^) := widechar(ord(tbtwidechar(var1^)) - PSGetUInt(Var2, var2type));
+ {$ENDIF}
+ btVariant:
+ begin
+ if not IntPIFVariantToVariant(var2, var2type, tvar) then
+ begin
+ Result := false;
+ end else
+ Variant(var1^) := Variant(var1^) - tvar;
+ end;
+ btSet:
+ begin
+ if var1Type = var2Type then
+ begin
+ Set_Diff(var1, var2, TPSTypeRec_Set(var1Type).aByteSize);
+ end else result := False;
+ end;
+ else begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ end;
+ if not Result then begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ end;
+ 2: begin { * }
+ case var1Type.BaseType of
+ btU8: tbtU8(var1^) := tbtU8(var1^) * PSGetUInt(Var2, var2type);
+ btS8: tbts8(var1^) := tbts8(var1^) * PSGetInt(Var2, var2type);
+ btU16: tbtU16(var1^) := tbtU16(var1^) * PSGetUInt(Var2, var2type);
+ btS16: tbts16(var1^) := tbts16(var1^) * PSGetInt(Var2, var2type);
+ btU32:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: tbtU32(var1^) := tbtU32(var1^) * tbtu8(var2^);
+ btS8: tbtU32(var1^) := tbtU32(var1^) * cardinal(longint(tbts8(var2^)));
+ btU16: tbtU32(var1^) := tbtU32(var1^) * tbtu16(var2^);
+ btS16: tbtU32(var1^) := tbtU32(var1^) * cardinal(longint(tbts16(var2^)));
+ btU32: tbtU32(var1^) := tbtU32(var1^) * tbtu32(var2^);
+ btS32: tbtU32(var1^) := tbtU32(var1^) * cardinal(tbts32(var2^));
+ {$IFNDEF PS_NOINT64} btS64: tbtU32(var1^) := tbtU32(var1^) * tbts64(var2^);{$ENDIF}
+ btChar: tbtU32(var1^) := tbtU32(var1^) * Ord(tbtchar(var2^));
+ {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtU32(var1^) := tbtU32(var1^) * Ord(tbtwidechar(var2^));{$ENDIF}
+ btVariant: tbtU32(var1^) := tbtU32(var1^) * Variant(var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ btS32:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: tbts32(var1^) := tbts32(var1^) * tbtu8(var2^);
+ btS8: tbts32(var1^) := tbts32(var1^) * tbts8(var2^);
+ btU16: tbts32(var1^) := tbts32(var1^) * tbtu16(var2^);
+ btS16: tbts32(var1^) := tbts32(var1^) * tbts16(var2^);
+ btU32: tbts32(var1^) := tbts32(var1^) * Longint(tbtu32(var2^));
+ btS32: tbts32(var1^) := tbts32(var1^) * tbts32(var2^);
+ {$IFNDEF PS_NOINT64} btS64: tbts32(var1^) := tbts32(var1^) * tbts64(var2^);{$ENDIF}
+ btChar: tbts32(var1^) := tbts32(var1^) * Ord(tbtchar(var2^));
+ {$IFNDEF PS_NOWIDESTRING} btWideChar: tbts32(var1^) := tbts32(var1^) * Ord(tbtwidechar(var2^));{$ENDIF}
+ btVariant: tbts32(var1^) := tbts32(var1^) * Variant(var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ {$IFNDEF PS_NOINT64}
+ btS64: tbts64(var1^) := tbts64(var1^) * PSGetInt64(var2, var2type);
+ {$ENDIF}
+ btCurrency:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: tbtcurrency(var1^) := tbtcurrency(var1^) * tbtu8(var2^);
+ btS8: tbtcurrency(var1^) := tbtcurrency(var1^) * tbts8(var2^);
+ btU16: tbtcurrency(var1^) := tbtcurrency(var1^) * tbtu16(var2^);
+ btS16: tbtcurrency(var1^) := tbtcurrency(var1^) * tbts16(var2^);
+ btU32: tbtcurrency(var1^) := tbtdouble(var1^) * tbtu32(var2^);
+ btS32: tbtcurrency(var1^) := tbtcurrency(var1^) * tbts32(var2^);
+ {$IFNDEF PS_NOINT64} btS64: tbtcurrency(var1^) := tbtdouble(var1^) * tbts64(var2^);{$ENDIF}
+ btSingle: tbtcurrency(var1^) := tbtcurrency(var1^) * tbtsingle(var2^);
+ btDouble: tbtcurrency(var1^) := tbtcurrency(var1^) * tbtdouble(var2^);
+ btExtended: tbtcurrency(var1^) := tbtcurrency(var1^) * tbtextended(var2^);
+ btCurrency: tbtcurrency(var1^) := tbtcurrency(var1^) * tbtcurrency(var2^);
+ btVariant: tbtcurrency(var1^) := tbtcurrency(var1^) * Variant(var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ btSingle:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: tbtsingle(var1^) := tbtsingle(var1^) *tbtu8(var2^);
+ btS8: tbtsingle(var1^) := tbtsingle(var1^) *tbts8(var2^);
+ btU16: tbtsingle(var1^) := tbtsingle(var1^) *tbtu16(var2^);
+ btS16: tbtsingle(var1^) := tbtsingle(var1^) *tbts16(var2^);
+ btU32: tbtsingle(var1^) := tbtsingle(var1^) *tbtu32(var2^);
+ btS32: tbtsingle(var1^) := tbtsingle(var1^) *tbts32(var2^);
+ {$IFNDEF PS_NOINT64} btS64: tbtsingle(var1^) := tbtsingle(var1^) *tbts64(var2^);{$ENDIF}
+ btSingle: tbtsingle(var1^) := tbtsingle(var1^) *tbtsingle(var2^);
+ btDouble: tbtsingle(var1^) := tbtsingle(var1^) *tbtdouble(var2^);
+ btExtended: tbtsingle(var1^) := tbtsingle(var1^) *tbtextended(var2^);
+ btCurrency: tbtsingle(var1^) := tbtsingle(var1^) *tbtcurrency(var2^);
+ btVariant: tbtsingle(var1^) := tbtsingle(var1^) * Variant(var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ btDouble:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: tbtdouble(var1^) := tbtdouble(var1^) *tbtu8(var2^);
+ btS8: tbtdouble(var1^) := tbtdouble(var1^) *tbts8(var2^);
+ btU16: tbtdouble(var1^) := tbtdouble(var1^) *tbtu16(var2^);
+ btS16: tbtdouble(var1^) := tbtdouble(var1^) *tbts16(var2^);
+ btU32: tbtdouble(var1^) := tbtdouble(var1^) *tbtu32(var2^);
+ btS32: tbtdouble(var1^) := tbtdouble(var1^) *tbts32(var2^);
+ {$IFNDEF PS_NOINT64} btS64: tbtdouble(var1^) := tbtdouble(var1^) *tbts64(var2^);{$ENDIF}
+ btSingle: tbtdouble(var1^) := tbtdouble(var1^) *tbtsingle(var2^);
+ btDouble: tbtdouble(var1^) := tbtdouble(var1^) *tbtdouble(var2^);
+ btExtended: tbtdouble(var1^) := tbtdouble(var1^) *tbtextended(var2^);
+ btCurrency: tbtdouble(var1^) := tbtdouble(var1^) *tbtcurrency(var2^);
+ btVariant: tbtdouble(var1^) := tbtdouble(var1^) * Variant(var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ btExtended:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: tbtextended(var1^) := tbtextended(var1^) *tbtu8(var2^);
+ btS8: tbtextended(var1^) := tbtextended(var1^) *tbts8(var2^);
+ btU16: tbtextended(var1^) := tbtextended(var1^) *tbtu16(var2^);
+ btS16: tbtextended(var1^) := tbtextended(var1^) *tbts16(var2^);
+ btU32: tbtextended(var1^) := tbtextended(var1^) *tbtu32(var2^);
+ btS32: tbtextended(var1^) := tbtextended(var1^) *tbts32(var2^);
+ {$IFNDEF PS_NOINT64} btS64: tbtextended(var1^) := tbtextended(var1^) *tbts64(var2^);{$ENDIF}
+ btSingle: tbtextended(var1^) := tbtextended(var1^) *tbtsingle(var2^);
+ btDouble: tbtextended(var1^) := tbtextended(var1^) *tbtdouble(var2^);
+ btExtended: tbtextended(var1^) := tbtextended(var1^) *tbtextended(var2^);
+ btCurrency: tbtextended(var1^) := tbtextended(var1^) *tbtcurrency(var2^);
+ btVariant: tbtextended(var1^) := tbtextended(var1^) * Variant(var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ btVariant:
+ begin
+ if not IntPIFVariantToVariant(var2, var2type, tvar) then
+ begin
+ Result := false;
+ end else
+ Variant(var1^) := Variant(var1^) * tvar;
+ end;
+ btSet:
+ begin
+ if var1Type = var2Type then
+ begin
+ Set_Intersect(var1, var2, TPSTypeRec_Set(var1Type).aByteSize);
+ end else result := False;
+ end;
+ else begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ end;
+ if not Result then begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ end;
+ 3: begin { / }
+ case var1Type.BaseType of
+ btU8: tbtU8(var1^) := tbtU8(var1^) div PSGetUInt(Var2, var2type);
+ btS8: tbts8(var1^) := tbts8(var1^) div PSGetInt(Var2, var2type);
+ btU16: tbtU16(var1^) := tbtU16(var1^) div PSGetUInt(Var2, var2type);
+ btS16: tbts16(var1^) := tbts16(var1^) div PSGetInt(Var2, var2type);
+ btU32:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: tbtU32(var1^) := tbtU32(var1^) div tbtu8(var2^);
+ btS8: tbtU32(var1^) := tbtU32(var1^) div cardinal(longint(tbts8(var2^)));
+ btU16: tbtU32(var1^) := tbtU32(var1^) div tbtu16(var2^);
+ btS16: tbtU32(var1^) := tbtU32(var1^) div cardinal(longint(tbts16(var2^)));
+ btU32: tbtU32(var1^) := tbtU32(var1^) div tbtu32(var2^);
+ btS32: tbtU32(var1^) := tbtU32(var1^) div cardinal(tbts32(var2^));
+ {$IFNDEF PS_NOINT64} btS64: tbtU32(var1^) := tbtU32(var1^) div tbts64(var2^);{$ENDIF}
+ btChar: tbtU32(var1^) := tbtU32(var1^) div Ord(tbtchar(var2^));
+ {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtU32(var1^) := tbtU32(var1^) div Ord(tbtwidechar(var2^));{$ENDIF}
+ btVariant: tbtU32(var1^) := tbtU32(var1^) div Variant(var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ btS32:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: tbts32(var1^) := tbts32(var1^) div tbtu8(var2^);
+ btS8: tbts32(var1^) := tbts32(var1^) div tbts8(var2^);
+ btU16: tbts32(var1^) := tbts32(var1^) div tbtu16(var2^);
+ btS16: tbts32(var1^) := tbts32(var1^) div tbts16(var2^);
+ btU32: tbts32(var1^) := tbts32(var1^) div Longint(tbtu32(var2^));
+ btS32: tbts32(var1^) := tbts32(var1^) div tbts32(var2^);
+ {$IFNDEF PS_NOINT64} btS64: tbts32(var1^) := tbts32(var1^) div tbts64(var2^);{$ENDIF}
+ btChar: tbts32(var1^) := tbts32(var1^) div Ord(tbtchar(var2^));
+ {$IFNDEF PS_NOWIDESTRING} btWideChar: tbts32(var1^) := tbts32(var1^) div Ord(tbtwidechar(var2^));{$ENDIF}
+ btVariant: tbts32(var1^) := tbts32(var1^) div Variant(var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ {$IFNDEF PS_NOINT64}
+ btS64: tbts64(var1^) := tbts64(var1^) div PSGetInt64(var2, var2type);
+ {$ENDIF}
+ btSingle:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: tbtsingle(var1^) := tbtsingle(var1^) / tbtu8(var2^);
+ btS8: tbtsingle(var1^) := tbtsingle(var1^) / tbts8(var2^);
+ btU16: tbtsingle(var1^) := tbtsingle(var1^) / tbtu16(var2^);
+ btS16: tbtsingle(var1^) := tbtsingle(var1^) / tbts16(var2^);
+ btU32: tbtsingle(var1^) := tbtsingle(var1^) / tbtu32(var2^);
+ btS32: tbtsingle(var1^) := tbtsingle(var1^) / tbts32(var2^);
+ {$IFNDEF PS_NOINT64} btS64: tbtsingle(var1^) := tbtsingle(var1^) / tbts64(var2^);{$ENDIF}
+ btSingle: tbtsingle(var1^) := tbtsingle(var1^) / tbtsingle(var2^);
+ btDouble: tbtsingle(var1^) := tbtsingle(var1^) / tbtdouble(var2^);
+ btExtended: tbtsingle(var1^) := tbtsingle(var1^) / tbtextended(var2^);
+ btCurrency: tbtsingle(var1^) := tbtsingle(var1^) / tbtcurrency(var2^);
+ btVariant: tbtsingle(var1^) := tbtsingle(var1^) / Variant(var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ btCurrency:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: tbtcurrency(var1^) := tbtcurrency(var1^) / tbtu8(var2^);
+ btS8: tbtcurrency(var1^) := tbtcurrency(var1^) / tbts8(var2^);
+ btU16: tbtcurrency(var1^) := tbtcurrency(var1^) / tbtu16(var2^);
+ btS16: tbtcurrency(var1^) := tbtcurrency(var1^) / tbts16(var2^);
+ btU32: tbtcurrency(var1^) := tbtdouble(var1^) / tbtu32(var2^);
+ btS32: tbtcurrency(var1^) := tbtcurrency(var1^) / tbts32(var2^);
+ {$IFNDEF PS_NOINT64} btS64: tbtcurrency(var1^) := tbtdouble(var1^) / tbts64(var2^);{$ENDIF}
+ btSingle: tbtcurrency(var1^) := tbtcurrency(var1^) / tbtsingle(var2^);
+ btDouble: tbtcurrency(var1^) := tbtcurrency(var1^) / tbtdouble(var2^);
+ btExtended: tbtcurrency(var1^) := tbtcurrency(var1^) / tbtextended(var2^);
+ btCurrency: tbtcurrency(var1^) := tbtcurrency(var1^) / tbtcurrency(var2^);
+ btVariant: tbtcurrency(var1^) := tbtcurrency(var1^) / Variant(var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ btDouble:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: tbtdouble(var1^) := tbtdouble(var1^) / tbtu8(var2^);
+ btS8: tbtdouble(var1^) := tbtdouble(var1^) / tbts8(var2^);
+ btU16: tbtdouble(var1^) := tbtdouble(var1^) / tbtu16(var2^);
+ btS16: tbtdouble(var1^) := tbtdouble(var1^) / tbts16(var2^);
+ btU32: tbtdouble(var1^) := tbtdouble(var1^) / tbtu32(var2^);
+ btS32: tbtdouble(var1^) := tbtdouble(var1^) / tbts32(var2^);
+ {$IFNDEF PS_NOINT64} btS64: tbtdouble(var1^) := tbtdouble(var1^) / tbts64(var2^);{$ENDIF}
+ btSingle: tbtdouble(var1^) := tbtdouble(var1^) / tbtsingle(var2^);
+ btDouble: tbtdouble(var1^) := tbtdouble(var1^) / tbtdouble(var2^);
+ btExtended: tbtdouble(var1^) := tbtdouble(var1^) / tbtextended(var2^);
+ btCurrency: tbtdouble(var1^) := tbtdouble(var1^) / tbtcurrency(var2^);
+ btVariant: tbtdouble(var1^) := tbtdouble(var1^) / Variant(var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ btExtended:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: tbtextended(var1^) := tbtextended(var1^) / tbtu8(var2^);
+ btS8: tbtextended(var1^) := tbtextended(var1^) / tbts8(var2^);
+ btU16: tbtextended(var1^) := tbtextended(var1^) / tbtu16(var2^);
+ btS16: tbtextended(var1^) := tbtextended(var1^) / tbts16(var2^);
+ btU32: tbtextended(var1^) := tbtextended(var1^) / tbtu32(var2^);
+ btS32: tbtextended(var1^) := tbtextended(var1^) / tbts32(var2^);
+ {$IFNDEF PS_NOINT64} btS64: tbtextended(var1^) := tbtextended(var1^) / tbts64(var2^);{$ENDIF}
+ btSingle: tbtextended(var1^) := tbtextended(var1^) / tbtsingle(var2^);
+ btDouble: tbtextended(var1^) := tbtextended(var1^) / tbtdouble(var2^);
+ btExtended: tbtextended(var1^) := tbtextended(var1^) / tbtextended(var2^);
+ btCurrency: tbtextended(var1^) := tbtextended(var1^) / tbtcurrency(var2^);
+ btVariant: tbtextended(var1^) := tbtextended(var1^) / Variant(var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ btVariant:
+ begin
+ if not IntPIFVariantToVariant(var2, var2type, tvar) then
+ begin
+ Result := false;
+ end else
+ begin
+ if VarIsFloat(variant(var1^)) then
+ Variant(var1^) := Variant(var1^) / tvar
+ else
+ Variant(var1^) := Variant(var1^) div tvar;
+ end;
+ end;
+ else begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ end;
+ if not Result then begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ end;
+ 4: begin { MOD }
+ case var1Type.BaseType of
+ btU8: tbtU8(var1^) := tbtU8(var1^) mod PSGetUInt(Var2, var2type);
+ btS8: tbts8(var1^) := tbts8(var1^) mod PSGetInt(Var2, var2type);
+ btU16: tbtU16(var1^) := tbtU16(var1^) mod PSGetUInt(Var2, var2type);
+ btS16: tbts16(var1^) := tbts16(var1^) mod PSGetInt(Var2, var2type);
+ btU32:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: tbtU32(var1^) := tbtU32(var1^) mod tbtu8(var2^);
+ btS8: tbtU32(var1^) := tbtU32(var1^) mod cardinal(longint(tbts8(var2^)));
+ btU16: tbtU32(var1^) := tbtU32(var1^) mod tbtu16(var2^);
+ btS16: tbtU32(var1^) := tbtU32(var1^) mod cardinal(longint(tbts16(var2^)));
+ btU32: tbtU32(var1^) := tbtU32(var1^) mod tbtu32(var2^);
+ btS32: tbtU32(var1^) := tbtU32(var1^) mod cardinal(tbts32(var2^));
+ {$IFNDEF PS_NOINT64} btS64: tbtU32(var1^) := tbtU32(var1^) mod tbts64(var2^);{$ENDIF}
+ btChar: tbtU32(var1^) := tbtU32(var1^) mod Ord(tbtchar(var2^));
+ {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtU32(var1^) := tbtU32(var1^) mod Ord(tbtwidechar(var2^));{$ENDIF}
+ btVariant: tbtU32(var1^) := tbtU32(var1^) mod Variant(var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ btS32:
+ begin
+ if var2type.BaseType = btPointer then
+ begin
+ var2type := PIFTypeRec(Pointer(IPointer(var2)+PointerSize)^);
+ var2 := Pointer(var2^);
+ if (var2 = nil) or (var2type = nil) then raise Exception.Create(RPS_TypeMismatch);
+ end;
+ case var2type.BaseType of
+ btU8: tbts32(var1^) := tbts32(var1^) mod tbtu8(var2^);
+ btS8: tbts32(var1^) := tbts32(var1^) mod tbts8(var2^);
+ btU16: tbts32(var1^) := tbts32(var1^) mod tbtu16(var2^);
+ btS16: tbts32(var1^) := tbts32(var1^) mod tbts16(var2^);
+ btU32: tbts32(var1^) := tbts32(var1^) mod Longint(tbtu32(var2^));
+ btS32: tbts32(var1^) := tbts32(var1^) mod tbts32(var2^);
+ {$IFNDEF PS_NOINT64} btS64: tbts32(var1^) := tbts32(var1^) mod tbts64(var2^);{$ENDIF}
+ btChar: tbts32(var1^) := tbts32(var1^) mod Ord(tbtchar(var2^));
+ {$IFNDEF PS_NOWIDESTRING} btWideChar: tbts32(var1^) := tbts32(var1^) mod Ord(tbtwidechar(var2^));{$ENDIF}
+ btVariant: tbts32(var1^) := tbts32(var1^) mod Variant(var2^);
+ else raise Exception.Create(RPS_TypeMismatch);
+ end;
+ end;
+ {$IFNDEF PS_NOINT64}
+ btS64: tbts64(var1^) := tbts64(var1^) mod PSGetInt64(var2, var2type);
+ {$ENDIF}
+ btVariant:
+ begin
+ if not IntPIFVariantToVariant(var2, var2type, tvar) then
+ begin
+ Result := false;
+ end else
+ Variant(var1^) := Variant(var1^) mod tvar;
+ end;
+ else begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ end;
+ if not Result then begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ end;
+ 5: begin { SHL }
+ case var1Type.BaseType of
+ btU8: tbtU8(var1^) := tbtU8(var1^) shl PSGetUInt(Var2, var2type);
+ btS8: tbts8(var1^) := tbts8(var1^) shl PSGetInt(Var2, var2type);
+ btU16: tbtU16(var1^) := tbtU16(var1^) shl PSGetUInt(Var2, var2type);
+ btS16: tbts16(var1^) := tbts16(var1^) shl PSGetInt(Var2, var2type);
+ btU32: tbtU32(var1^) := tbtU32(var1^) shl PSGetUInt(Var2, var2type);
+ btS32: tbts32(var1^) := tbts32(var1^) shl PSGetInt(Var2, var2type);
+ {$IFNDEF PS_NOINT64}
+ btS64: tbts64(var1^) := tbts64(var1^) shl PSGetInt64(var2, var2type);
+ {$ENDIF}
+ btVariant:
+ begin
+ if not IntPIFVariantToVariant(var2, var2type, tvar) then
+ begin
+ Result := false;
+ end else
+ Variant(var1^) := Variant(var1^) shl tvar;
+ end;
+ else begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ end;
+ if not Result then begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ end;
+ 6: begin { SHR }
+ case var1Type.BaseType of
+ btU8: tbtU8(var1^) := tbtU8(var1^) shr PSGetUInt(Var2, var2type);
+ btS8: tbts8(var1^) := tbts8(var1^) shr PSGetInt(Var2, var2type);
+ btU16: tbtU16(var1^) := tbtU16(var1^) shr PSGetUInt(Var2, var2type);
+ btS16: tbts16(var1^) := tbts16(var1^) shr PSGetInt(Var2, var2type);
+ btU32: tbtU32(var1^) := tbtU32(var1^) shr PSGetUInt(Var2, var2type);
+ btS32: tbts32(var1^) := tbts32(var1^) shr PSGetInt(Var2, var2type);
+ {$IFNDEF PS_NOINT64}
+ btS64: tbts64(var1^) := tbts64(var1^) shr PSGetInt64(var2, var2type);
+ {$ENDIF}
+ btVariant:
+ begin
+ if not IntPIFVariantToVariant(var2, var2type, tvar) then
+ begin
+ Result := false;
+ end else
+ Variant(var1^) := Variant(var1^) shr tvar;
+ end;
+ else begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ end;
+ if not Result then begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ end;
+ 7: begin { AND }
+ case var1Type.BaseType of
+ btU8: tbtU8(var1^) := tbtU8(var1^) and PSGetUInt(Var2, var2type);
+ btS8: tbts8(var1^) := tbts8(var1^) and PSGetInt(Var2, var2type);
+ btU16: tbtU16(var1^) := tbtU16(var1^) and PSGetUInt(Var2, var2type);
+ btS16: tbts16(var1^) := tbts16(var1^) and PSGetInt(Var2, var2type);
+ btU32: tbtU32(var1^) := tbtU32(var1^) and PSGetUInt(Var2, var2type);
+ btS32: tbts32(var1^) := tbts32(var1^) and PSGetInt(Var2, var2type);
+ {$IFNDEF PS_NOINT64}
+ btS64: tbts64(var1^) := tbts64(var1^) and PSGetInt64(var2, var2type);
+ {$ENDIF}
+ btVariant:
+ begin
+ if not IntPIFVariantToVariant(var2, var2type, tvar) then
+ begin
+ Result := false;
+ end else
+ Variant(var1^) := Variant(var1^) and tvar;
+ end;
+ else begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ end;
+ if not Result then begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ end;
+ 8: begin { OR }
+ case var1Type.BaseType of
+ btU8: tbtU8(var1^) := tbtU8(var1^) or PSGetUInt(Var2, var2type);
+ btS8: tbts8(var1^) := tbts8(var1^) or PSGetInt(Var2, var2type);
+ btU16: tbtU16(var1^) := tbtU16(var1^) or PSGetUInt(Var2, var2type);
+ btS16: tbts16(var1^) := tbts16(var1^) or PSGetInt(Var2, var2type);
+ btU32: tbtU32(var1^) := tbtU32(var1^) or PSGetUInt(Var2, var2type);
+ btS32: tbts32(var1^) := tbts32(var1^) or PSGetInt(Var2, var2type);
+ {$IFNDEF PS_NOINT64}
+ btS64: tbts64(var1^) := tbts64(var1^) or PSGetInt64(var2, var2type);
+ {$ENDIF}
+ btVariant:
+ begin
+ if not IntPIFVariantToVariant(var2, var2type, tvar) then
+ begin
+ Result := false;
+ end else
+ Variant(var1^) := Variant(var1^) or tvar;
+ end;
+ else begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ end;
+ if not Result then begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ end;
+ 9: begin { XOR }
+ case var1Type.BaseType of
+ btU8: tbtU8(var1^) := tbtU8(var1^) xor PSGetUInt(Var2, var2type);
+ btS8: tbts8(var1^) := tbts8(var1^) xor PSGetInt(Var2, var2type);
+ btU16: tbtU16(var1^) := tbtU16(var1^) xor PSGetUInt(Var2, var2type);
+ btS16: tbts16(var1^) := tbts16(var1^) xor PSGetInt(Var2, var2type);
+ btU32: tbtU32(var1^) := tbtU32(var1^) xor PSGetUInt(Var2, var2type);
+ btS32: tbts32(var1^) := tbts32(var1^) xor PSGetInt(Var2, var2type);
+ {$IFNDEF PS_NOINT64}
+ btS64: tbts64(var1^) := tbts64(var1^) xor PSGetInt64(var2, var2type);
+ {$ENDIF}
+ btVariant:
+ begin
+ if not IntPIFVariantToVariant(var2, var2type, tvar) then
+ begin
+ Result := false;
+ end else
+ Variant(var1^) := Variant(var1^) xor tvar;
+ end;
+ else begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ end;
+ if not Result then begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ end;
+ 10:
+ begin // as
+ case var1Type.BaseType of
+ btClass:
+ begin
+ if var2type.BaseType <> btU32 then
+ Result := False
+ else
+ begin
+ var2type := FTypes[tbtu32(var2^)];
+ if (var2type = nil) or (var2type.BaseType <> btClass) then
+ Result := false
+ else
+ begin
+ if not Class_IS(Self, TObject(var1^), var2type) then
+ Result := false
+ end;
+ end;
+ end;
+ else begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ end;
+ if not Result then begin
+ CMD_Err(erTypeMismatch);
+ exit;
+ end;
+ end;
+ else begin
+ Result := False;
+ CMD_Err(erInvalidOpcodeParameter);
+ exit;
+ end;
+ end;
+ except
+ {$IFDEF DELPHI6UP}
+ Tmp := AcquireExceptionObject;
+ {$ELSE}
+ if RaiseList <> nil then
+ begin
+ Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject);
+ PRaiseFrame(RaiseList)^.ExceptObject := nil;
+ end else
+ Tmp := nil;
+ {$ENDIF}
+ if Tmp <> nil then
+ begin
+ if Tmp is EPSException then
+ begin
+ Result := False;
+ ExceptionProc(EPSException(tmp).ProcNo, EPSException(tmp).ProcPos, erCustomError, tbtString(EPSException(tmp).Message), nil);
+ exit;
+ end else
+ if Tmp is EDivByZero then
+ begin
+ Result := False;
+ CMD_Err3(erDivideByZero, '', Tmp);
+ Exit;
+ end;
+ if Tmp is EZeroDivide then
+ begin
+ Result := False;
+ CMD_Err3(erDivideByZero, '', Tmp);
+ Exit;
+ end;
+ if Tmp is EMathError then
+ begin
+ Result := False;
+ CMD_Err3(erMathError, '', Tmp);
+ Exit;
+ end;
+ end;
+ if (tmp <> nil) and (Tmp is Exception) then
+ CMD_Err3(erException, tbtString(Exception(Tmp).Message), Tmp)
+ else
+ CMD_Err3(erException, '', Tmp);
+ Result := False;
+ end;
+end;
+
+function TPSExec.ReadVariable(var Dest: TPSResultData; UsePointer: Boolean): Boolean;
+var
+ VarType: Cardinal;
+ Param: Cardinal;
+ Tmp: PIfVariant;
+ at: TPSTypeRec;
+
+begin
+ if FCurrentPosition + 4 >= FDataLength then
+ begin
+ CMD_Err(erOutOfRange); // Error
+ Result := False;
+ exit;
+ end;
+ VarType := FData^[FCurrentPosition];
+ Inc(FCurrentPosition);
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ Param := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+ {$else}
+ Param := Cardinal((@FData^[FCurrentPosition])^);
+ {$endif}
+ Inc(FCurrentPosition, 4);
+ case VarType of
+ 0:
+ begin
+ Dest.FreeType := vtNone;
+ if Param < PSAddrNegativeStackStart then
+ begin
+ if Param >= Cardinal(FGlobalVars.Count) then
+ begin
+ CMD_Err(erOutOfGlobalVarsRange);
+ Result := False;
+ exit;
+ end;
+ Tmp := FGlobalVars.Data[param];
+ end else
+ begin
+ Param := Cardinal(Longint(-PSAddrStackStart) +
+ Longint(FCurrStackBase) + Longint(Param));
+ if Param >= Cardinal(FStack.Count) then
+ begin
+ CMD_Err(erOutOfGlobalVarsRange);
+ Result := False;
+ exit;
+ end;
+ Tmp := FStack.Data[param];
+ end;
+ if (UsePointer) and (Tmp.FType.BaseType = btPointer) then
+ begin
+ Dest.aType := PPSVariantPointer(Tmp).DestType;
+ Dest.P := PPSVariantPointer(Tmp).DataDest;
+ if Dest.P = nil then
+ begin
+ Cmd_Err(erNullPointerException);
+ Result := False;
+ exit;
+ end;
+ end else
+ begin
+ Dest.aType := PPSVariantData(Tmp).vi.FType;
+ Dest.P := @PPSVariantData(Tmp).Data;
+ end;
+ end;
+ 1: begin
+ if Param >= FTypes.Count then
+ begin
+ CMD_Err(erInvalidType);
+ Result := False;
+ exit;
+ end;
+ at := FTypes.Data^[Param];
+ Param := FTempVars.FLength;
+ FTempVars.FLength := Cardinal(Longint(Param) + Longint(at.RealSize) + Longint(RTTISize + 3)) and not 3;
+ if FTempVars.FLength > FTempVars.FCapacity then FtempVars.AdjustLength;
+ Tmp := Pointer(IPointer(FtempVars.FDataPtr) + IPointer(Param));
+
+ if Cardinal(FTempVars.FCount) >= Cardinal(FTempVars.FCapacity) then
+ begin
+ Inc(FTempVars.FCapacity, FCapacityInc);// := FCount + 1;
+ ReAllocMem(FTempVars.FData, FTempVars.FCapacity shl 2);
+ end;
+ FTempVars.FData[FTempVars.FCount] := Tmp; // Instead of SetItem
+ Inc(FTempVars.FCount);
+ {$IFNDEF PS_NOSMARTLIST}
+ Inc(FTempVars.FCheckCount);
+ if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
+ {$ENDIF}
+
+
+ Tmp.FType := at;
+ Dest.P := @PPSVariantData(Tmp).Data;
+ Dest.aType := tmp.FType;
+ dest.FreeType := vtTempVar;
+ case Dest.aType.BaseType of
+ btSet:
+ begin
+ if not ReadData(Dest.P^, TPSTypeRec_Set(Dest.aType).aByteSize) then
+ begin
+ CMD_Err(erOutOfRange);
+ FTempVars.Pop;
+ Result := False;
+ exit;
+ end;
+ end;
+ bts8, btchar, btU8:
+ begin
+ if FCurrentPosition >= FDataLength then
+ begin
+ CMD_Err(erOutOfRange);
+ FTempVars.Pop;
+ Result := False;
+ exit;
+ end;
+ tbtu8(dest.p^) := FData^[FCurrentPosition];
+ Inc(FCurrentPosition);
+ end;
+ bts16, {$IFNDEF PS_NOWIDESTRING}btwidechar,{$ENDIF} btU16:
+ begin
+ if FCurrentPosition + 1>= FDataLength then
+ begin
+ CMD_Err(erOutOfRange);
+ FTempVars.Pop;
+ Result := False;
+ exit;
+ end;
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ tbtu16(dest.p^) := unaligned(tbtu16((@FData^[FCurrentPosition])^));
+ {$else}
+ tbtu16(dest.p^) := tbtu16((@FData^[FCurrentPosition])^);
+ {$endif}
+ Inc(FCurrentPosition, 2);
+ end;
+ bts32, btU32:
+ begin
+ if FCurrentPosition + 3>= FDataLength then
+ begin
+ CMD_Err(erOutOfRange);
+ FTempVars.Pop;
+ Result := False;
+ exit;
+ end;
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ tbtu32(dest.p^) := unaligned(tbtu32((@FData^[FCurrentPosition])^));
+ {$else}
+ tbtu32(dest.p^) := tbtu32((@FData^[FCurrentPosition])^);
+ {$endif}
+ Inc(FCurrentPosition, 4);
+ end;
+ btProcPtr:
+ begin
+ if FCurrentPosition + 3>= FDataLength then
+ begin
+ CMD_Err(erOutOfRange);
+ FTempVars.Pop;
+ Result := False;
+ exit;
+ end;
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ tbtu32(dest.p^) := unaligned(tbtu32((@FData^[FCurrentPosition])^));
+ {$else}
+ tbtu32(dest.p^) := tbtu32((@FData^[FCurrentPosition])^);
+ {$endif}
+ tbtu32(Pointer(IPointer(dest.p)+PointerSize)^) := 0;
+ tbtu32(Pointer(IPointer(dest.p)+PointerSize)^) := 0;
+ Inc(FCurrentPosition, 4);
+ end;
+ {$IFNDEF PS_NOINT64}
+ bts64:
+ begin
+ if FCurrentPosition + 7>= FDataLength then
+ begin
+ CMD_Err(erOutOfRange);
+ FTempVars.Pop;
+ Result := False;
+ exit;
+ end;
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ tbts64(dest.p^) := unaligned(tbts64((@FData^[FCurrentPosition])^));
+ {$else}
+ tbts64(dest.p^) := tbts64((@FData^[FCurrentPosition])^);
+ {$endif}
+ Inc(FCurrentPosition, 8);
+ end;
+ {$ENDIF}
+ btSingle:
+ begin
+ if FCurrentPosition + (Sizeof(Single)-1)>= FDataLength then
+ begin
+ CMD_Err(erOutOfRange);
+ FTempVars.Pop;
+ Result := False;
+ exit;
+ end;
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ tbtsingle(dest.p^) := unaligned(tbtsingle((@FData^[FCurrentPosition])^));
+ {$else}
+ tbtsingle(dest.p^) := tbtsingle((@FData^[FCurrentPosition])^);
+ {$endif}
+ Inc(FCurrentPosition, Sizeof(Single));
+ end;
+ btDouble:
+ begin
+ if FCurrentPosition + (Sizeof(Double)-1)>= FDataLength then
+ begin
+ CMD_Err(erOutOfRange);
+ FTempVars.Pop;
+ Result := False;
+ exit;
+ end;
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ tbtdouble(dest.p^) := unaligned(tbtdouble((@FData^[FCurrentPosition])^));
+ {$else}
+ tbtdouble(dest.p^) := tbtdouble((@FData^[FCurrentPosition])^);
+ {$endif}
+ Inc(FCurrentPosition, Sizeof(double));
+ end;
+
+ btExtended:
+ begin
+ if FCurrentPosition + (sizeof(Extended)-1)>= FDataLength then
+ begin
+ CMD_Err(erOutOfRange);
+ FTempVars.Pop;
+ Result := False;
+ exit;
+ end;
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ tbtextended(dest.p^) := unaligned(tbtextended((@FData^[FCurrentPosition])^));
+ {$else}
+ tbtextended(dest.p^) := tbtextended((@FData^[FCurrentPosition])^);
+ {$endif}
+ Inc(FCurrentPosition, sizeof(Extended));
+ end;
+ btPchar, btString:
+ begin
+ if FCurrentPosition + 3 >= FDataLength then
+ begin
+ Cmd_Err(erOutOfRange);
+ FTempVars.Pop;
+ Result := False;
+ exit;
+ end;
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ Param := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+ {$else}
+ Param := Cardinal((@FData^[FCurrentPosition])^);
+ {$endif}
+ Inc(FCurrentPosition, 4);
+ Pointer(Dest.P^) := nil;
+ SetLength(tbtstring(Dest.P^), Param);
+ if not ReadData(tbtstring(Dest.P^)[1], Param) then
+ begin
+ CMD_Err(erOutOfRange);
+ FTempVars.Pop;
+ Result := False;
+ exit;
+ end;
+ end;
+ {$IFNDEF PS_NOWIDESTRING}
+ btWidestring:
+ begin
+ if FCurrentPosition + 3 >= FDataLength then
+ begin
+ Cmd_Err(erOutOfRange);
+ FTempVars.Pop;
+ Result := False;
+ exit;
+ end;
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ Param := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+ {$else}
+ Param := Cardinal((@FData^[FCurrentPosition])^);
+ {$endif}
+ Inc(FCurrentPosition, 4);
+ Pointer(Dest.P^) := nil;
+ SetLength(tbtwidestring(Dest.P^), Param);
+ if not ReadData(tbtwidestring(Dest.P^)[1], Param*2) then
+ begin
+ CMD_Err(erOutOfRange);
+ FTempVars.Pop;
+ Result := False;
+ exit;
+ end;
+ end;
+ btUnicodeString:
+ begin
+ if FCurrentPosition + 3 >= FDataLength then
+ begin
+ Cmd_Err(erOutOfRange);
+ FTempVars.Pop;
+ Result := False;
+ exit;
+ end;
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ Param := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+ {$else}
+ Param := Cardinal((@FData^[FCurrentPosition])^);
+ {$endif}
+ Inc(FCurrentPosition, 4);
+ Pointer(Dest.P^) := nil;
+ SetLength(tbtUnicodestring(Dest.P^), Param);
+ if not ReadData(tbtUnicodestring(Dest.P^)[1], Param*2) then
+ begin
+ CMD_Err(erOutOfRange);
+ FTempVars.Pop;
+ Result := False;
+ exit;
+ end;
+ end;
+ {$ENDIF}
+ else begin
+ CMD_Err(erInvalidType);
+ FTempVars.Pop;
+ Result := False;
+ exit;
+ end;
+ end;
+ end;
+ 2:
+ begin
+ Dest.FreeType := vtNone;
+ if Param < PSAddrNegativeStackStart then begin
+ if Param >= Cardinal(FGlobalVars.Count) then
+ begin
+ CMD_Err(erOutOfGlobalVarsRange);
+ Result := False;
+ exit;
+ end;
+ Tmp := FGlobalVars.Data[param];
+ end
+ else begin
+ Param := Cardinal(Longint(-PSAddrStackStart) + Longint(FCurrStackBase) + Longint(Param));
+ if Param >= Cardinal(FStack.Count) then
+ begin
+ CMD_Err(erOutOfStackRange);
+ Result := False;
+ exit;
+ end;
+ Tmp := FStack.Data[param];
+ end;
+ if Tmp.FType.BaseType = btPointer then
+ begin
+ Dest.aType := PPSVariantPointer(Tmp).DestType;
+ Dest.P := PPSVariantPointer(Tmp).DataDest;
+ if Dest.P = nil then
+ begin
+ Cmd_Err(erNullPointerException);
+ Result := False;
+ exit;
+ end;
+ end else
+ begin
+ Dest.aType := PPSVariantData(Tmp).vi.FType;
+ Dest.P := @PPSVariantData(Tmp).Data;
+ end;
+ if FCurrentPosition + 3 >= FDataLength then
+ begin
+ CMD_Err(erOutOfRange);
+ Result := False;
+ exit;
+ end;
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ Param := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+ {$else}
+ Param := Cardinal((@FData^[FCurrentPosition])^);
+ {$endif}
+ Inc(FCurrentPosition, 4);
+ case Dest.aType.BaseType of
+ btRecord:
+ begin
+ if Param > Cardinal(TPSTypeRec_Record(Dest.aType).FFieldTypes.Count) then
+ begin
+ CMD_Err(erOutOfRange);
+ Result := False;
+ exit;
+ end;
+ Dest.P := Pointer(IPointer(Dest.P) + IPointer(TPSTypeRec_Record(Dest.aType).RealFieldOffsets[Param]));
+ Dest.aType := TPSTypeRec_Record(Dest.aType).FieldTypes[Param];
+ end;
+ btArray:
+ begin
+ if Param >= Cardinal(PSDynArrayGetLength(Pointer(Dest.P^), dest.aType)) then
+ begin
+ CMD_Err(erOutOfRange);
+ Result := False;
+ exit;
+ end;
+ Dest.P := Pointer(IPointer(Dest.P^) + (Param * TPSTypeRec_Array(Dest.aType).FArrayType.RealSize));
+ Dest.aType := TPSTypeRec_Array(dest.aType).ArrayType;
+ end;
+ btStaticArray:
+ begin
+ if Param >= Cardinal(TPSTypeRec_StaticArray(Dest.aType).Size) then
+ begin
+ CMD_Err(erOutOfRange);
+ Result := False;
+ exit;
+ end;
+ Dest.P := Pointer(IPointer(Dest.P) + (Param * TPSTypeRec_Array(Dest.aType).FArrayType.RealSize));
+ Dest.aType := TPSTypeRec_Array(dest.aType).ArrayType;
+ end;
+ else
+ CMD_Err(erInvalidType);
+ Result := False;
+ exit;
+ end;
+
+ if UsePointer and (Dest.aType.BaseType = btPointer) then
+ begin
+ Dest.aType := TPSTypeRec(Pointer(IPointer(Dest.p)+PointerSize)^);
+ Dest.P := Pointer(Dest.p^);
+ if Dest.P = nil then
+ begin
+ Cmd_Err(erNullPointerException);
+ Result := False;
+ exit;
+ end;
+ end;
+ end;
+ 3:
+ begin
+ Dest.FreeType := vtNone;
+ if Param < PSAddrNegativeStackStart then begin
+ if Param >= Cardinal(FGlobalVars.Count) then
+ begin
+ CMD_Err(erOutOfGlobalVarsRange);
+ Result := False;
+ exit;
+ end;
+ Tmp := FGlobalVars.Data[param];
+ end
+ else begin
+ Param := Cardinal(Longint(-PSAddrStackStart) + Longint(FCurrStackBase) + Longint(Param));
+ if Param >= Cardinal(FStack.Count) then
+ begin
+ CMD_Err(erOutOfStackRange);
+ Result := False;
+ exit;
+ end;
+ Tmp := FStack.Data[param];
+ end;
+ if (Tmp.FType.BaseType = btPointer) then
+ begin
+ Dest.aType := PPSVariantPointer(Tmp).DestType;
+ Dest.P := PPSVariantPointer(Tmp).DataDest;
+ if Dest.P = nil then
+ begin
+ Cmd_Err(erNullPointerException);
+ Result := False;
+ exit;
+ end;
+ end else
+ begin
+ Dest.aType := PPSVariantData(Tmp).vi.FType;
+ Dest.P := @PPSVariantData(Tmp).Data;
+ end;
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ Param := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+ {$else}
+ Param := Cardinal((@FData^[FCurrentPosition])^);
+ {$endif}
+ Inc(FCurrentPosition, 4);
+ if Param < PSAddrNegativeStackStart then
+ begin
+ if Param >= Cardinal(FGlobalVars.Count) then
+ begin
+ CMD_Err(erOutOfGlobalVarsRange);
+ Result := false;
+ exit;
+ end;
+ Tmp := FGlobalVars[Param];
+ end
+ else begin
+ Param := Cardinal(Longint(-PSAddrStackStart) + Longint(FCurrStackBase) + Longint(Param));
+ if Cardinal(Param) >= Cardinal(FStack.Count) then
+ begin
+ CMD_Err(erOutOfStackRange);
+ Result := false;
+ exit;
+ end;
+ Tmp := FStack[Param];
+ end;
+ case Tmp.FType.BaseType of
+ btu8: Param := PPSVariantU8(Tmp).Data;
+ bts8: Param := PPSVariants8(Tmp).Data;
+ btu16: Param := PPSVariantU16(Tmp).Data;
+ bts16: Param := PPSVariants16(Tmp).Data;
+ btu32: Param := PPSVariantU32(Tmp).Data;
+ bts32: Param := PPSVariants32(Tmp).Data;
+ btPointer:
+ begin
+ if PPSVariantPointer(tmp).DestType <> nil then
+ begin
+ case PPSVariantPointer(tmp).DestType.BaseType of
+ btu8: Param := tbtu8(PPSVariantPointer(tmp).DataDest^);
+ bts8: Param := tbts8(PPSVariantPointer(tmp).DataDest^);
+ btu16: Param := tbtu16(PPSVariantPointer(tmp).DataDest^);
+ bts16: Param := tbts16(PPSVariantPointer(tmp).DataDest^);
+ btu32, btProcPtr: Param := tbtu32(PPSVariantPointer(tmp).DataDest^);
+ bts32: Param := tbts32(PPSVariantPointer(tmp).DataDest^);
+ else
+ begin
+ CMD_Err(ErTypeMismatch);
+ Result := false;
+ exit;
+ end;
+ end;
+ end else
+ begin
+ CMD_Err(ErTypeMismatch);
+ Result := false;
+ exit;
+ end;
+ end;
+ else
+ CMD_Err(ErTypeMismatch);
+ Result := false;
+ exit;
+ end;
+ case Dest.aType.BaseType of
+ btRecord:
+ begin
+ if Param > Cardinal(TPSTypeRec_Record(Dest.aType).FFieldTypes.Count) then
+ begin
+ CMD_Err(erOutOfRange);
+ Result := False;
+ exit;
+ end;
+ Dest.P := Pointer(IPointer(Dest.P) + IPointer(TPSTypeRec_Record(Dest.aType).RealFieldOffsets[Param]));
+ Dest.aType := TPSTypeRec_Record(Dest.aType).FieldTypes[Param];
+ end;
+ btArray:
+ begin
+ if Cardinal(Param) >= Cardinal(PSDynArrayGetLength(Pointer(Dest.P^), dest.aType)) then
+ begin
+ CMD_Err(erOutOfRange);
+ Result := False;
+ exit;
+ end;
+ Dest.P := Pointer(IPointer(Dest.P^) + (Param * TPSTypeRec_Array(Dest.aType).FArrayType.RealSize));
+ Dest.aType := TPSTypeRec_Array(dest.aType).ArrayType;
+ end;
+ btStaticArray:
+ begin
+ if Param >= Cardinal(TPSTypeRec_StaticArray(Dest.aType).Size) then
+ begin
+ CMD_Err(erOutOfRange);
+ Result := False;
+ exit;
+ end;
+ Dest.P := Pointer(IPointer(Dest.P) + (Param * TPSTypeRec_Array(Dest.aType).FArrayType.RealSize));
+ Dest.aType := TPSTypeRec_Array(dest.aType).ArrayType;
+ end;
+ else
+ CMD_Err(erInvalidType);
+ Result := False;
+ exit;
+ end;
+ if UsePointer and (Dest.aType.BaseType = btPointer) then
+ begin
+ Dest.aType := TPSTypeRec(Pointer(IPointer(Dest.p)+PointerSize)^);
+ Dest.P := Pointer(Dest.p^);
+ if Dest.P = nil then
+ begin
+ Cmd_Err(erNullPointerException);
+ Result := False;
+ exit;
+ end;
+ end;
+ end;
+ else
+ begin
+ Result := False;
+ exit;
+ end;
+ end;
+ Result := true;
+end;
+
+function TPSExec.DoMinus(Dta: Pointer; aType: TPSTypeRec): Boolean;
+begin
+ case atype.BaseType of
+ btU8: tbtu8(dta^) := -tbtu8(dta^);
+ btU16: tbtu16(dta^) := -tbtu16(dta^);
+ btU32: tbtu32(dta^) := -tbtu32(dta^);
+ btS8: tbts8(dta^) := -tbts8(dta^);
+ btS16: tbts16(dta^) := -tbts16(dta^);
+ btS32: tbts32(dta^) := -tbts32(dta^);
+ {$IFNDEF PS_NOINT64}
+ bts64: tbts64(dta^) := -tbts64(dta^);
+ {$ENDIF}
+ btSingle: tbtsingle(dta^) := -tbtsingle(dta^);
+ btDouble: tbtdouble(dta^) := -tbtdouble(dta^);
+ btExtended: tbtextended(dta^) := -tbtextended(dta^);
+ btCurrency: tbtcurrency(dta^) := -tbtcurrency(dta^);
+ btVariant:
+ begin
+ try
+ Variant(dta^) := - Variant(dta^);
+ except
+ CMD_Err(erTypeMismatch);
+ Result := False;
+ exit;
+ end;
+ end;
+ else
+ begin
+ CMD_Err(erTypeMismatch);
+ Result := False;
+ exit;
+ end;
+ end;
+ Result := True;
+end;
+
+function TPSExec.DoBooleanNot(Dta: Pointer; aType: TPSTypeRec): Boolean;
+begin
+ case aType.BaseType of
+ btU8: tbtu8(dta^) := tbtu8(tbtu8(dta^) = 0);
+ btU16: tbtu16(dta^) := tbtu16(tbtu16(dta^) = 0);
+ btU32: tbtu32(dta^) := tbtu32(tbtu32(dta^) = 0);
+ btS8: tbts8(dta^) := tbts8(tbts8(dta^) = 0);
+ btS16: tbts16(dta^) := tbts16(tbts16(dta^) = 0);
+ btS32: tbts32(dta^) := tbts32(tbts32(dta^) = 0);
+ {$IFNDEF PS_NOINT64}
+ bts64: tbts64(dta^) := tbts64(tbts64(dta^) = 0);
+ {$ENDIF}
+ btVariant:
+ begin
+ try
+ Variant(dta^) := Variant(dta^) = 0;
+ except
+ CMD_Err(erTypeMismatch);
+ Result := False;
+ exit;
+ end;
+ end;
+ else
+ begin
+ CMD_Err(erTypeMismatch);
+ Result := False;
+ exit;
+ end;
+ end;
+ Result := True;
+end;
+
+
+procedure TPSExec.Stop;
+begin
+ if FStatus = isRunning then
+ FStatus := isLoaded
+ else if FStatus = isPaused then begin
+ FStatus := isLoaded;
+ FStack.Clear;
+ FTempVars.Clear;
+ end;
+end;
+
+
+function TPSExec.ReadLong(var b: Cardinal): Boolean;
+begin
+ if FCurrentPosition + 3 < FDataLength then begin
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ b := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+ {$else}
+ b := Cardinal((@FData^[FCurrentPosition])^);
+ {$endif}
+ Inc(FCurrentPosition, 4);
+ Result := True;
+ end
+ else
+ Result := False;
+end;
+
+function TPSExec.RunProcP(const Params: array of Variant; const Procno: Cardinal): Variant;
+var
+ ParamList: TPSList;
+ ct: PIFTypeRec;
+ pvar: PPSVariant;
+ res, s: tbtString;
+ Proc: TPSInternalProcRec;
+ i: Longint;
+begin
+ if ProcNo >= FProcs.Count then raise Exception.Create(RPS_UnknownProcedure);
+ Proc := GetProcNo(ProcNo) as TPSInternalProcRec;
+ ParamList := TPSList.Create;
+ try
+ s := Proc.ExportDecl;
+ res := grfw(s);
+ i := High(Params);
+ while s <> '' do
+ begin
+ if i < 0 then raise Exception.Create(RPS_NotEnoughParameters);
+ ct := FTypes[StrToInt(copy(GRLW(s), 2, MaxInt))];
+ if ct = nil then raise Exception.Create(RPS_InvalidParameter);
+ pvar := CreateHeapVariant(ct);
+ ParamList.Add(pvar);
+
+ if not VariantToPIFVariant(Self, Params[i], pvar) then raise Exception.Create(RPS_InvalidParameter);
+
+ Dec(i);
+ end;
+ if I > -1 then raise Exception.Create(RPS_TooManyParameters);
+ if res <> '-1' then
+ begin
+ pvar := CreateHeapVariant(FTypes[StrToInt(res)]);
+ ParamList.Add(pvar);
+ end else
+ pvar := nil;
+
+ RunProc(ParamList, ProcNo);
+
+ RaiseCurrentException;
+
+ if pvar <> nil then
+ begin
+ PIFVariantToVariant(PVar, Result);
+ end else
+ Result := Null;
+ finally
+ FreePIFVariantList(ParamList);
+ end;
+end;
+function TPSExec.RunProcPVar(var Params: array of Variant; const Procno: Cardinal): Variant;
+var
+ ParamList: TPSList;
+ ct: PIFTypeRec;
+ pvar: PPSVariant;
+ res, s: tbtString;
+ Proc: TPSInternalProcRec;
+ i: Longint;
+begin
+ if ProcNo >= FProcs.Count then raise Exception.Create(RPS_UnknownProcedure);
+ Proc := GetProcNo(ProcNo) as TPSInternalProcRec;
+ ParamList := TPSList.Create;
+ try
+ s := Proc.ExportDecl;
+ res := grfw(s);
+ i := High(Params);
+ while s <> '' do
+ begin
+ if i < 0 then raise Exception.Create(RPS_NotEnoughParameters);
+ ct := FTypes[StrToInt(copy(GRLW(s), 2, MaxInt))];
+ if ct = nil then raise Exception.Create(RPS_InvalidParameter);
+ pvar := CreateHeapVariant(ct);
+ ParamList.Add(pvar);
+
+ if not VariantToPIFVariant(Self, Params[i], pvar) then raise Exception.Create(RPS_InvalidParameter);
+
+ Dec(i);
+ end;
+ if I > -1 then raise Exception.Create(RPS_TooManyParameters);
+ if res <> '-1' then
+ begin
+ pvar := CreateHeapVariant(FTypes[StrToInt(res)]);
+ ParamList.Add(pvar);
+ end else
+ pvar := nil;
+
+ RunProc(ParamList, ProcNo);
+
+ RaiseCurrentException;
+
+ for i := 0 to Length(Params) - 1 do
+ PIFVariantToVariant(ParamList[i],
+ Params[(Length(Params) - 1) - i]);
+
+ if pvar <> nil then
+ begin
+ PIFVariantToVariant(PVar, Result);
+ end else
+ Result := Null;
+ finally
+ FreePIFVariantList(ParamList);
+ end;
+end;
+
+function TPSExec.RunProcPN(const Params: array of Variant; const ProcName: tbtString): Variant;
+var
+ ProcNo: Cardinal;
+begin
+ ProcNo := GetProc(ProcName);
+ if ProcNo = InvalidVal then
+ raise Exception.Create(RPS_UnknownProcedure);
+ Result := RunProcP(Params, ProcNo);
+end;
+
+
+function TPSExec.RunProc(Params: TPSList; ProcNo: Cardinal): Boolean;
+var
+ I, I2: Integer;
+ vnew, Vd: PIfVariant;
+ Cp: TPSInternalProcRec;
+ oldStatus: TPSStatus;
+ tmp: TObject;
+begin
+ if FStatus <> isNotLoaded then begin
+ if ProcNo >= FProcs.Count then begin
+ CMD_Err(erOutOfProcRange);
+ Result := False;
+ exit;
+ end;
+ if Params <> nil then
+ begin
+ for I := 0 to Params.Count - 1 do
+ begin
+ vd := Params[I];
+ if vd = nil then
+ begin
+ Result := False;
+ exit;
+ end;
+ vnew := FStack.PushType(FindType2(btPointer));
+ if vd.FType.BaseType = btPointer then
+ begin
+ PPSVariantPointer(vnew).DestType := PPSVariantPointer(vd).DestType;
+ PPSVariantPointer(vnew).DataDest := PPSVariantPointer(vd).DataDest;
+ end else begin
+ PPSVariantPointer(vnew).DestType := vd.FType;
+ PPSVariantPointer(vnew).DataDest := @PPSVariantData(vd).Data;
+ end;
+ end;
+ end;
+ I := FStack.Count;
+ Cp := FCurrProc;
+ oldStatus := FStatus;
+ if TPSProcRec(FProcs.Data^[ProcNo]).ClassType <> TPSExternalProcRec then
+ begin
+ vd := FStack.PushType(FReturnAddressType);
+ PPSVariantReturnAddress(vd).Addr.ProcNo := nil;
+ PPSVariantReturnAddress(vd).Addr.Position := FCurrentPosition;
+ PPSVariantReturnAddress(vd).Addr.StackBase := FCurrStackBase;
+ FCurrStackBase := FStack.Count - 1;
+ FCurrProc := FProcs.Data^[ProcNo];
+ FData := FCurrProc.Data;
+ FDataLength := FCurrProc.Length;
+ FCurrentPosition := 0;
+ FStatus := isPaused;
+ Result := RunScript;
+ end else
+ begin
+ try
+ Result := TPSExternalProcRec(FProcs.Data^[ProcNo]).ProcPtr(Self, TPSExternalProcRec(FProcs.Data^[ProcNo]), FGlobalVars, FStack);
+ if not Result then
+ begin
+ if ExEx = erNoError then
+ CMD_Err(erCouldNotCallProc);
+ end;
+ except
+ {$IFDEF DELPHI6UP}
+ Tmp := AcquireExceptionObject;
+ {$ELSE}
+ if RaiseList <> nil then
+ begin
+ Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject);
+ PRaiseFrame(RaiseList)^.ExceptObject := nil;
+ end else
+ Tmp := nil;
+ {$ENDIF}
+ if Tmp <> nil then
+ begin
+ if Tmp is EPSException then
+ begin
+ Result := False;
+ ExceptionProc(EPSException(tmp).ProcNo, EPSException(tmp).ProcPos, erCustomError, tbtString(EPSException(tmp).Message), nil);
+ exit;
+ end else
+ if Tmp is EDivByZero then
+ begin
+ Result := False;
+ CMD_Err3(erDivideByZero, '', Tmp);
+ Exit;
+ end;
+ if Tmp is EZeroDivide then
+ begin
+ Result := False;
+ CMD_Err3(erDivideByZero, '', Tmp);
+ Exit;
+ end;
+ if Tmp is EMathError then
+ begin
+ Result := False;
+ CMD_Err3(erMathError, '', Tmp);
+ Exit;
+ end;
+ end;
+ if (Tmp <> nil) and (Tmp is Exception) then
+ CMD_Err3(erException, tbtString(Exception(Tmp).Message), Tmp) else
+ CMD_Err3(erException, '', Tmp);
+ Result := false;
+ exit;
+ end;
+ end;
+ if Cardinal(FStack.Count) > Cardinal(I) then
+ begin
+ vd := FStack[I];
+ if (vd <> nil) and (vd.FType = FReturnAddressType) then
+ begin
+ for i2 := FStack.Count - 1 downto I + 1 do
+ FStack.Pop;
+ FCurrentPosition := PPSVariantReturnAddress(vd).Addr.Position;
+ FCurrStackBase := PPSVariantReturnAddress(vd).Addr.StackBase;
+ FStack.Pop;
+ end;
+ end;
+ if Params <> nil then
+ begin
+ for I := Params.Count - 1 downto 0 do
+ begin
+ if FStack.Count = 0 then
+ Break
+ else
+ FStack.Pop;
+ end;
+ end;
+ FStatus := oldStatus;
+ FCurrProc := Cp;
+ if FCurrProc <> nil then
+ begin
+ FData := FCurrProc.Data;
+ FDataLength := FCurrProc.Length;
+ end;
+ end else begin
+ Result := False;
+ end;
+end;
+
+
+function TPSExec.FindType2(BaseType: TPSBaseType): PIFTypeRec;
+var
+ l: Cardinal;
+begin
+ FindType2 := FindType(0, BaseType, l);
+
+end;
+
+function TPSExec.FindType(StartAt: Cardinal; BaseType: TPSBaseType; var l: Cardinal): PIFTypeRec;
+var
+ I: Integer;
+ n: PIFTypeRec;
+begin
+ for I := StartAt to FTypes.Count - 1 do begin
+ n := FTypes[I];
+ if n.BaseType = BaseType then begin
+ l := I;
+ Result := n;
+ exit;
+ end;
+ end;
+ Result := nil;
+end;
+
+function TPSExec.GetTypeNo(l: Cardinal): PIFTypeRec;
+begin
+ Result := FTypes[l];
+end;
+
+function TPSExec.GetProc(const Name: tbtString): Cardinal;
+var
+ MM,
+ I: Longint;
+ n: PIFProcRec;
+ s: tbtString;
+begin
+ s := FastUpperCase(name);
+ MM := MakeHash(s);
+ for I := FProcs.Count - 1 downto 0 do begin
+ n := FProcs.Data^[I];
+ if (n.ClassType = TPSInternalProcRec) and (TPSInternalProcRec(n).ExportNameHash = MM) and (TPSInternalProcRec(n).ExportName = s) then begin
+ Result := I;
+ exit;
+ end else if (n.ClassType = TPSExternalProcRec) and (TPSExternalProcRec(n).Name = s) then
+ begin
+ Result := I;
+ exit;
+ end;
+ end;
+ Result := InvalidVal;
+end;
+
+function TPSExec.GetType(const Name: tbtString): Cardinal;
+var
+ MM,
+ I: Longint;
+ n: PIFTypeRec;
+ s: tbtString;
+begin
+ s := FastUpperCase(name);
+ MM := MakeHash(s);
+ for I := 0 to FTypes.Count - 1 do begin
+ n := FTypes.Data^[I];
+ if (Length(n.ExportName) <> 0) and (n.ExportNameHash = MM) and (n.ExportName = s) then begin
+ Result := I;
+ exit;
+ end;
+ end;
+ Result := InvalidVal;
+end;
+
+
+procedure TPSExec.AddResource(Proc, P: Pointer);
+var
+ Temp: PPSResource;
+begin
+ New(Temp);
+ Temp^.Proc := Proc;
+ Temp^.P := p;
+ FResources.Add(temp);
+end;
+
+procedure TPSExec.DeleteResource(P: Pointer);
+var
+ i: Longint;
+begin
+ for i := Longint(FResources.Count) -1 downto 0 do
+ begin
+ if PPSResource(FResources[I])^.P = P then
+ begin
+ FResources.Delete(I);
+ exit;
+ end;
+ end;
+end;
+
+function TPSExec.FindProcResource(Proc: Pointer): Pointer;
+var
+ I: Longint;
+ temp: PPSResource;
+begin
+ for i := Longint(FResources.Count) -1 downto 0 do
+ begin
+ temp := FResources[I];
+ if temp^.Proc = proc then
+ begin
+ Result := Temp^.P;
+ exit;
+ end;
+ end;
+ Result := nil;
+end;
+
+function TPSExec.IsValidResource(Proc, P: Pointer): Boolean;
+var
+ i: Longint;
+ temp: PPSResource;
+begin
+ for i := 0 to Longint(FResources.Count) -1 do
+ begin
+ temp := FResources[i];
+ if temp^.p = p then begin
+ result := temp^.Proc = Proc;
+ exit;
+ end;
+ end;
+ result := false;
+end;
+
+function TPSExec.FindProcResource2(Proc: Pointer;
+ var StartAt: Longint): Pointer;
+var
+ I: Longint;
+ temp: PPSResource;
+begin
+ if StartAt > longint(FResources.Count) -1 then
+ StartAt := longint(FResources.Count) -1;
+ for i := StartAt downto 0 do
+ begin
+ temp := FResources[I];
+ if temp^.Proc = proc then
+ begin
+ Result := Temp^.P;
+ StartAt := i -1;
+ exit;
+ end;
+ end;
+ StartAt := -1;
+ Result := nil;
+end;
+
+procedure TPSExec.RunLine;
+begin
+ if @FOnRunLine <> nil then
+ FOnRunLine(Self);
+end;
+
+procedure TPSExec.CMD_Err3(EC: TPSError; const Param: tbtString; ExObject: TObject);
+var
+ l: Longint;
+ C: Cardinal;
+begin
+ C := InvalidVal;
+ for l := FProcs.Count - 1 downto 0 do begin
+ if FProcs.Data^[l] = FCurrProc then begin
+ C := l;
+ break;
+ end;
+ end;
+ if @FOnException <> nil then
+ FOnException(Self, Ec, Param, ExObject, C, FCurrentPosition);
+ ExceptionProc(C, FCurrentPosition, EC, Param, ExObject);
+end;
+
+procedure TPSExec.AddSpecialProcImport(const FName: tbtString;
+ P: TPSOnSpecialProcImport; Tag: Pointer);
+var
+ N: PSpecialProc;
+begin
+ New(n);
+ n^.P := P;
+ N^.Name := FName;
+ n^.namehash := MakeHash(N^.Name);
+ n^.Tag := Tag;
+ FSpecialProcList.Add(n);
+end;
+
+function TPSExec.GetVar(const Name: tbtString): Cardinal;
+var
+ l: Longint;
+ h: longint;
+ s: tbtString;
+ p: PPSExportedVar;
+begin
+ s := FastUpperCase(name);
+ h := MakeHash(s);
+ for l := FExportedVars.Count - 1 downto 0 do
+ begin
+ p := FexportedVars.Data^[L];
+ if (p^.FNameHash = h) and(p^.FName=s) then
+ begin
+ Result := L;
+ exit;
+ end;
+ end;
+ Result := InvalidVal;
+end;
+
+function TPSExec.GetVarNo(C: Cardinal): PIFVariant;
+begin
+ Result := FGlobalVars[c];
+end;
+
+function TPSExec.GetVar2(const Name: tbtString): PIFVariant;
+begin
+ Result := GetVarNo(GetVar(Name));
+end;
+
+function TPSExec.GetProcNo(C: Cardinal): PIFProcRec;
+begin
+ Result := FProcs[c];
+end;
+
+function TPSExec.DoIntegerNot(Dta: Pointer; aType: TPSTypeRec): Boolean;
+begin
+ case aType.BaseType of
+ btU8: tbtu8(dta^) := not tbtu8(dta^);
+ btU16: tbtu16(dta^) := not tbtu16(dta^);
+ btU32: tbtu32(dta^) := not tbtu32(dta^);
+ btS8: tbts8(dta^) := not tbts8(dta^);
+ btS16: tbts16(dta^) := not tbts16(dta^);
+ btS32: tbts32(dta^) := not tbts32(dta^);
+ {$IFNDEF PS_NOINT64}
+ bts64: tbts64(dta^) := not tbts64(dta^);
+ {$ENDIF}
+ btVariant:
+ begin
+ try
+ Variant(dta^) := not Variant(dta^);
+ except
+ CMD_Err(erTypeMismatch);
+ Result := False;
+ exit;
+ end;
+ end;
+ else
+ begin
+ CMD_Err(erTypeMismatch);
+ Result := False;
+ exit;
+ end;
+ end;
+ Result := True;
+end;
+
+type
+ TMyRunLine = procedure(Self: TPSExec);
+ TPSRunLine = procedure of object;
+
+function GetRunLine(FOnRunLine: TPSOnLineEvent; meth: TPSRunLine): TMyRunLine;
+begin
+ if (TMethod(Meth).Code = @TPSExec.RunLine) and (@FOnRunLine = nil) then
+ Result := nil
+ else
+ Result := TMethod(Meth).Code;
+end;
+
+function TPSExec.RunScript: Boolean;
+var
+ CalcType: Cardinal;
+ vd, vs, v3: TPSResultData;
+ vtemp: PIFVariant;
+ p: Cardinal;
+ P2: Longint;
+ u: PIFProcRec;
+ Cmd: Cardinal;
+ I: Longint;
+ pp: TPSExceptionHandler;
+ FExitPoint: Cardinal;
+ FOldStatus: TPSStatus;
+ Tmp: TObject;
+ btemp: Boolean;
+ CallRunline: TMyRunLine;
+begin
+ FExitPoint := InvalidVal;
+ if FStatus = isLoaded then
+ begin
+ for i := FExceptionStack.Count -1 downto 0 do
+ begin
+ pp := FExceptionStack.Data[i];
+ pp.Free;
+ end;
+ FExceptionStack.Clear;
+ end;
+ ExceptionProc(InvalidVal, InvalidVal, erNoError, '', nil);
+ RunScript := True;
+ FOldStatus := FStatus;
+ case FStatus of
+ isLoaded: begin
+ if FMainProc = InvalidVal then
+ begin
+ RunScript := False;
+ exit;
+ end;
+ FStatus := isRunning;
+ FCurrProc := FProcs.Data^[FMainProc];
+ if FCurrProc.ClassType = TPSExternalProcRec then begin
+ CMD_Err(erNoMainProc);
+ FStatus := isLoaded;
+ exit;
+ end;
+ FData := FCurrProc.Data;
+ FDataLength := FCurrProc.Length;
+ FCurrStackBase := InvalidVal;
+ FCurrentPosition := 0;
+ end;
+ isPaused: begin
+ FStatus := isRunning;
+ end;
+ else begin
+ RunScript := False;
+ exit;
+ end;
+ end;
+ CallRunLine := GetRunLine(FOnRunLine, Self.RunLine);
+ repeat
+ FStatus := isRunning;
+// Cmd := InvalidVal;
+ while FStatus = isRunning do
+ begin
+ if @CallRunLine <> nil then CallRunLine(Self);
+ if FCurrentPosition >= FDataLength then
+ begin
+ CMD_Err(erOutOfRange); // Error
+ break;
+ end;
+// if cmd <> invalidval then ProfilerExitProc(Cmd+1);
+ cmd := FData^[FCurrentPosition];
+// ProfilerEnterProc(Cmd+1);
+ Inc(FCurrentPosition);
+ case Cmd of
+ CM_A:
+ begin
+ if not ReadVariable(vd, True) then
+ break;
+ if vd.FreeType <> vtNone then
+ begin
+ if vd.aType.BaseType in NeedFinalization then
+ FinalizeVariant(vd.P, vd.aType);
+ p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
+ Dec(FTempVars.FCount);
+ {$IFNDEF PS_NOSMARTLIST}
+ Inc(FTempVars.FCheckCount);
+ if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
+ {$ENDIF}
+ FTempVars.FLength := P;
+ if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
+
+ CMD_Err(erInvalidOpcodeParameter);
+ break;
+ end;
+ if not ReadVariable(vs, True) then
+ Break;
+ // nx change end
+{ if (vd.aType.BaseType = btClass) and (vs.aType.BaseType in [btS32]) then
+ DWord(vd.P^):=Dword(vs.P^)
+ else
+ if (vd.aType.BaseType in [btS32]) and (vs.aType.BaseType = btClass) then
+ DWord(vd.P^):=Dword(vs.P^)
+ else}
+ // nx change start
+ if not SetVariantValue(vd.P, vs.P, vd.aType, vs.aType) then
+ begin
+ if vs.FreeType <> vtNone then
+ begin
+ if vs.aType.BaseType in NeedFinalization then
+ FinalizeVariant(vs.P, vs.aType);
+ p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
+ Dec(FTempVars.FCount);
+ {$IFNDEF PS_NOSMARTLIST}
+ Inc(FTempVars.FCheckCount);
+ if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
+ {$ENDIF}
+ FTempVars.FLength := P;
+ if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
+ end;
+ Break;
+ end;
+ if vs.FreeType <> vtNone then
+ begin
+ if vs.aType.BaseType in NeedFinalization then
+ FinalizeVariant(vs.P, vs.aType);
+ p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
+ Dec(FTempVars.FCount);
+ {$IFNDEF PS_NOSMARTLIST}
+ Inc(FTempVars.FCheckCount);
+ if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
+ {$ENDIF}
+ FTempVars.FLength := P;
+ if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
+ end;
+ end;
+ CM_CA:
+ begin
+ if FCurrentPosition >= FDataLength then
+ begin
+ CMD_Err(erOutOfRange); // Error
+ break;
+ end;
+ calctype := FData^[FCurrentPosition];
+ Inc(FCurrentPosition);
+ if not ReadVariable(vd, True) then
+ break;
+ if vd.FreeType <> vtNone then
+ begin
+ if vd.aType.BaseType in NeedFinalization then
+ FinalizeVariant(vd.P, vd.aType);
+ p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
+ Dec(FTempVars.FCount);
+ {$IFNDEF PS_NOSMARTLIST}
+ Inc(FTempVars.FCheckCount);
+ if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
+ {$ENDIF}
+ FTempVars.FLength := P;
+ if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
+ CMD_Err(erInvalidOpcodeParameter);
+ break;
+ end;
+ if not ReadVariable(vs, True) then
+ Break;
+ if not DoCalc(vd.P, vs.p, vd.aType, vs.aType, CalcType) then
+ begin
+ if vs.FreeType <> vtNone then
+ begin
+ if vs.aType.BaseType in NeedFinalization then
+ FinalizeVariant(vs.P, vs.aType);
+ p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
+ Dec(FTempVars.FCount);
+ {$IFNDEF PS_NOSMARTLIST}
+ Inc(FTempVars.FCheckCount);
+ if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
+ {$ENDIF}
+ FTempVars.FLength := P;
+ if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
+ end;
+ Break;
+ end;
+ if vs.FreeType <> vtNone then
+ begin
+ if vs.aType.BaseType in NeedFinalization then
+ FinalizeVariant(vs.P, vs.aType);
+ p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
+ Dec(FTempVars.FCount);
+ {$IFNDEF PS_NOSMARTLIST}
+ Inc(FTempVars.FCheckCount);
+ if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
+ {$ENDIF}
+ FTempVars.FLength := P;
+ if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
+ end;
+ end;
+ CM_P:
+ begin
+ if not ReadVariable(vs, True) then
+ Break;
+ vtemp := FStack.PushType(vs.aType);
+ vd.P := Pointer(IPointer(vtemp)+PointerSize);
+ vd.aType := Pointer(vtemp^);
+ vd.FreeType := vtNone;
+ if not SetVariantValue(Vd.P, vs.P, vd.aType, vs.aType) then
+ begin
+ if vs.FreeType <> vtnone then
+ begin
+ if vs.aType.BaseType in NeedFinalization then
+ FinalizeVariant(vs.P, vs.aType);
+ p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
+ Dec(FTempVars.FCount);
+ {$IFNDEF PS_NOSMARTLIST}
+ Inc(FTempVars.FCheckCount);
+ if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
+ {$ENDIF}
+ FTempVars.FLength := P;
+ if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
+ end;
+ break;
+ end;
+ if vs.FreeType <> vtnone then
+ begin
+ if vs.aType.BaseType in NeedFinalization then
+ FinalizeVariant(vs.P, vs.aType);
+ p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
+ Dec(FTempVars.FCount);
+ {$IFNDEF PS_NOSMARTLIST}
+ Inc(FTempVars.FCheckCount);
+ if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
+ {$ENDIF}
+ FTempVars.FLength := P;
+ if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
+ end;
+ end;
+ CM_PV:
+ begin
+ if not ReadVariable(vs, True) then
+ Break;
+ if vs.FreeType <> vtnone then
+ begin
+ FTempVars.Pop;
+ CMD_Err(erInvalidOpcodeParameter);
+ break;
+ end;
+ vtemp := FStack.PushType(FindType2(btPointer));
+ if vs.aType.BaseType = btPointer then
+ begin
+ PPSVariantPointer(vtemp).DataDest := Pointer(vs.p^);
+ PPSVariantPointer(vtemp).DestType := Pointer(Pointer(IPointer(vs.P)+PointerSize)^);
+ PPSVariantPointer(vtemp).FreeIt := False;
+ end
+ else
+ begin
+ PPSVariantPointer(vtemp).DataDest := vs.p;
+ PPSVariantPointer(vtemp).DestType := vs.aType;
+ PPSVariantPointer(vtemp).FreeIt := False;
+ end;
+ end;
+ CM_PO: begin
+ if FStack.Count = 0 then
+ begin
+ CMD_Err(erOutOfStackRange);
+ break;
+ end;
+ vtemp := FStack.Data^[FStack.Count -1];
+ if (vtemp = nil) or (vtemp.FType.BaseType = btReturnAddress) then
+ begin
+ CMD_Err(erOutOfStackRange);
+ break;
+ end;
+ FStack.Pop;
+(* Dec(FStack.FCount);
+ {$IFNDEF PS_NOSMARTLIST}
+ Inc(FStack.FCheckCount);
+ if FStack.FCheckCount > FMaxCheckCount then FStack.Recreate;
+ {$ENDIF}
+ FStack.FLength := Longint(IPointer(vtemp) - IPointer(FStack.DataPtr));
+ if TPSTypeRec(vtemp^).BaseType in NeedFinalization then
+ FinalizeVariant(Pointer(IPointer(vtemp)+PointerSize), Pointer(vtemp^));
+ if ((FStack.FCapacity - FStack.FLength) shr 12) > 2 then FStack.AdjustLength;*)
+ end;
+ Cm_C: begin
+ if FCurrentPosition + 3 >= FDataLength then
+ begin
+ Cmd_Err(erOutOfRange);
+ Break;
+ end;
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+ {$else}
+ p := Cardinal((@FData^[FCurrentPosition])^);
+ {$endif}
+ Inc(FCurrentPosition, 4);
+ if p >= FProcs.Count then begin
+ CMD_Err(erOutOfProcRange);
+ break;
+ end;
+ u := FProcs.Data^[p];
+ if u.ClassType = TPSExternalProcRec then begin
+ try
+ if not TPSExternalProcRec(u).ProcPtr(Self, TPSExternalProcRec(u), FGlobalVars, FStack) then begin
+ if ExEx = erNoError then
+ CMD_Err(erCouldNotCallProc);
+ Break;
+ end;
+ except
+ {$IFDEF DELPHI6UP}
+ Tmp := AcquireExceptionObject;
+ {$ELSE}
+ if RaiseList <> nil then
+ begin
+ Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject);
+ PRaiseFrame(RaiseList)^.ExceptObject := nil;
+ end else
+ Tmp := nil;
+ {$ENDIF}
+ if Tmp <> nil then
+ begin
+ if Tmp is EPSException then
+ begin
+ ExceptionProc(EPSException(tmp).ProcNo, EPSException(tmp).ProcPos, erCustomError, tbtString(EPSException(tmp).Message), nil);
+ Break;
+ end else
+ if Tmp is EDivByZero then
+ begin
+ CMD_Err3(erDivideByZero, '', Tmp);
+ Break;
+ end;
+ if Tmp is EZeroDivide then
+ begin
+ CMD_Err3(erDivideByZero, '', Tmp);
+ Break;
+ end;
+ if Tmp is EMathError then
+ begin
+ CMD_Err3(erMathError, '', Tmp);
+ Break;
+ end;
+ end;
+ if (Tmp <> nil) and (Tmp is Exception) then
+ CMD_Err3(erException, tbtString(Exception(Tmp).Message), Tmp) else
+ CMD_Err3(erException, '', Tmp);
+ Break;
+ end;
+ end
+ else begin
+ Vtemp := Fstack.PushType(FReturnAddressType);
+ vd.P := Pointer(IPointer(VTemp)+PointerSize);
+ vd.aType := pointer(vtemp^);
+ vd.FreeType := vtNone;
+ PPSVariantReturnAddress(vtemp).Addr.ProcNo := FCurrProc;
+ PPSVariantReturnAddress(vtemp).Addr.Position := FCurrentPosition;
+ PPSVariantReturnAddress(vtemp).Addr.StackBase := FCurrStackBase;
+
+ FCurrStackBase := FStack.Count - 1;
+ FCurrProc := TPSInternalProcRec(u);
+ FData := FCurrProc.Data;
+ FDataLength := FCurrProc.Length;
+ FCurrentPosition := 0;
+ end;
+ end;
+ CM_PG:
+ begin
+ FStack.Pop;
+ if FCurrentPosition + 3 >= FDataLength then
+ begin
+ Cmd_Err(erOutOfRange);
+ Break;
+ end;
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+ {$else}
+ p := Cardinal((@FData^[FCurrentPosition])^);
+ {$endif}
+ Inc(FCurrentPosition, 4);
+ FCurrentPosition := FCurrentPosition + p;
+ end;
+ CM_P2G:
+ begin
+ FStack.Pop;
+ FStack.Pop;
+ if FCurrentPosition + 3 >= FDataLength then
+ begin
+ Cmd_Err(erOutOfRange);
+ Break;
+ end;
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+ {$else}
+ p := Cardinal((@FData^[FCurrentPosition])^);
+ {$endif}
+ Inc(FCurrentPosition, 4);
+ FCurrentPosition := FCurrentPosition + p;
+ end;
+ Cm_G:
+ begin
+ if FCurrentPosition + 3 >= FDataLength then
+ begin
+ Cmd_Err(erOutOfRange);
+ Break;
+ end;
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+ {$else}
+ p := Cardinal((@FData^[FCurrentPosition])^);
+ {$endif}
+ Inc(FCurrentPosition, 4);
+ FCurrentPosition := FCurrentPosition + p;
+ end;
+ Cm_CG:
+ begin
+ if FCurrentPosition + 3 >= FDataLength then
+ begin
+ Cmd_Err(erOutOfRange);
+ Break;
+ end;
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+ {$else}
+ p := Cardinal((@FData^[FCurrentPosition])^);
+ {$endif}
+ Inc(FCurrentPosition, 4);
+ btemp := true;
+ if not ReadVariable(vs, btemp) then
+ Break;
+ case Vs.aType.BaseType of
+ btU8: btemp := tbtu8(vs.p^) <> 0;
+ btS8: btemp := tbts8(vs.p^) <> 0;
+ btU16: btemp := tbtu16(vs.p^) <> 0;
+ btS16: btemp := tbts16(vs.p^) <> 0;
+ btU32: btemp := tbtu32(vs.p^) <> 0;
+ btS32: btemp := tbts32(vs.p^) <> 0;
+ else begin
+ CMD_Err(erInvalidType);
+ if vs.FreeType <> vtNone then
+ FTempVars.Pop;
+ break;
+ end;
+ end;
+ if vs.FreeType <> vtNone then
+ FTempVars.Pop;
+ if btemp then
+ FCurrentPosition := FCurrentPosition + p;
+ end;
+ Cm_CNG:
+ begin
+ if FCurrentPosition + 3 >= FDataLength then
+ begin
+ Cmd_Err(erOutOfRange);
+ Break;
+ end;
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+ {$else}
+ p := Cardinal((@FData^[FCurrentPosition])^);
+ {$endif}
+ Inc(FCurrentPosition, 4);
+ btemp := true;
+ if not ReadVariable(vs, BTemp) then
+ Break;
+ case Vs.aType.BaseType of
+ btU8: btemp := tbtu8(vs.p^) = 0;
+ btS8: btemp := tbts8(vs.p^) = 0;
+ btU16: btemp := tbtu16(vs.p^) = 0;
+ btS16: btemp := tbts16(vs.p^) = 0;
+ btU32: btemp := tbtu32(vs.p^) = 0;
+ btS32: btemp := tbts32(vs.p^) = 0;
+ else begin
+ CMD_Err(erInvalidType);
+ if vs.FreeType <> vtNone then
+ FTempVars.Pop;
+ break;
+ end;
+ end;
+ if vs.FreeType <> vtNone then
+ FTempVars.Pop;
+ if btemp then
+ FCurrentPosition := FCurrentPosition + p;
+ end;
+ Cm_R: begin
+ FExitPoint := FCurrentPosition -1;
+ P2 := 0;
+ if FExceptionStack.Count > 0 then
+ begin
+ pp := FExceptionStack.Data[FExceptionStack.Count -1];
+ while (pp.BasePtr = FCurrStackBase) or ((pp.BasePtr > FCurrStackBase) and (pp.BasePtr <> InvalidVal)) do
+ begin
+ if pp.StackSize < Cardinal(FStack.Count) then
+ begin
+ for p := Longint(FStack.count) -1 downto Longint(pp.StackSize) do
+ FStack.Pop
+ end;
+ FCurrStackBase := pp.BasePtr;
+ if pp.FinallyOffset <> InvalidVal then
+ begin
+ FCurrentPosition := pp.FinallyOffset;
+ pp.FinallyOffset := InvalidVal;
+ p2 := 1;
+ break;
+ end else if pp.Finally2Offset <> InvalidVal then
+ begin
+ FCurrentPosition := pp.Finally2Offset;
+ pp.Finally2Offset := InvalidVal;
+ p2 := 1;
+ break;
+ end else
+ begin
+ pp.Free;
+ FExceptionStack.DeleteLast;
+ if FExceptionStack.Count = 0 then break;
+ pp := FExceptionStack.Data[FExceptionStack.Count -1];
+ end;
+ end;
+ end;
+ if p2 = 0 then
+ begin
+ FExitPoint := InvalidVal;
+ if FCurrStackBase = InvalidVal then
+ begin
+ FStatus := FOldStatus;
+ break;
+ end;
+ for P2 := FStack.Count - 1 downto FCurrStackBase + 1 do
+ FStack.Pop;
+ if FCurrStackBase >= FStack.Count then
+ begin
+ FStatus := FOldStatus;
+ break;
+ end;
+ vtemp := FStack.Data[FCurrStackBase];
+ FCurrProc := PPSVariantReturnAddress(vtemp).Addr.ProcNo;
+ FCurrentPosition := PPSVariantReturnAddress(vtemp).Addr.Position;
+ FCurrStackBase := PPSVariantReturnAddress(vtemp).Addr.StackBase;
+ FStack.Pop;
+ if FCurrProc = nil then begin
+ FStatus := FOldStatus;
+ break;
+ end;
+ FData := FCurrProc.Data;
+ FDataLength := FCurrProc.Length;
+ end;
+ end;
+ Cm_Pt: begin
+ if FCurrentPosition + 3 >= FDataLength then
+ begin
+ Cmd_Err(erOutOfRange);
+ Break;
+ end;
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+ {$else}
+ p := Cardinal((@FData^[FCurrentPosition])^);
+ {$endif}
+ Inc(FCurrentPosition, 4);
+ if p > FTypes.Count then
+ begin
+ CMD_Err(erInvalidType);
+ break;
+ end;
+ FStack.PushType(FTypes.Data^[p]);
+ end;
+ cm_bn:
+ begin
+ if not ReadVariable(vd, True) then
+ Break;
+ if vd.FreeType <> vtNone then
+ FTempVars.Pop;
+ if not DoBooleanNot(Vd.P, vd.aType) then
+ break;
+ end;
+ cm_in:
+ begin
+ if not ReadVariable(vd, True) then
+ Break;
+ if vd.FreeType <> vtNone then
+ FTempVars.Pop;
+ if not DoIntegerNot(Vd.P, vd.aType) then
+ break;
+ end;
+ cm_vm:
+ begin
+ if not ReadVariable(vd, True) then
+ Break;
+ if vd.FreeType <> vtNone then
+ FTempVars.Pop;
+ if not DoMinus(Vd.P, vd.aType) then
+ break;
+ end;
+ cm_sf:
+ begin
+ if not ReadVariable(vd, True) then
+ Break;
+ if FCurrentPosition >= FDataLength then
+ begin
+ CMD_Err(erOutOfRange); // Error
+ if vd.FreeType <> vtNone then
+ FTempVars.Pop;
+ break;
+ end;
+ p := FData^[FCurrentPosition];
+ Inc(FCurrentPosition);
+ case Vd.aType.BaseType of
+ btU8: FJumpFlag := tbtu8(Vd.p^) <> 0;
+ btS8: FJumpFlag := tbts8(Vd.p^) <> 0;
+ btU16: FJumpFlag := tbtu16(Vd.p^) <> 0;
+ btS16: FJumpFlag := tbts16(Vd.p^) <> 0;
+ btU32: FJumpFlag := tbtu32(Vd.p^) <> 0;
+ btS32: FJumpFlag := tbts32(Vd.p^) <> 0;
+ else begin
+ CMD_Err(erInvalidType);
+ if vd.FreeType <> vtNone then
+ FTempVars.Pop;
+ break;
+ end;
+ end;
+ if p <> 0 then
+ FJumpFlag := not FJumpFlag;
+ if vd.FreeType <> vtNone then
+ FTempVars.Pop;
+ end;
+ cm_fg:
+ begin
+ if FCurrentPosition + 3 >= FDataLength then
+ begin
+ Cmd_Err(erOutOfRange);
+ Break;
+ end;
+ {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+ p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+ {$else}
+ p := Cardinal((@FData^[FCurrentPosition])^);
+ {$endif}
+ Inc(FCurrentPosition, 4);
+ if FJumpFlag then
+ FCurrentPosition := FCurrentPosition + p;
+ end;
+ cm_puexh:
+ begin
+ pp := TPSExceptionHandler.Create;
+ pp.CurrProc := FCurrProc;
+ pp.BasePtr :=FCurrStackBase;
+ pp.StackSize := FStack.Count;
+ if not ReadLong(pp.FinallyOffset) then begin
+ CMD_Err(erOutOfRange);
+ pp.Free;
+ Break;
+ end;
+ if not ReadLong(pp.ExceptOffset) then begin
+ CMD_Err(erOutOfRange);
+ pp.Free;
+ Break;
+ end;
+ if not ReadLong(pp.Finally2Offset) then begin
+ CMD_Err(erOutOfRange);
+ pp.Free;
+ Break;
+ end;
+ if not ReadLong(pp.EndOfBlock) then begin
+ CMD_Err(erOutOfRange);
+ pp.Free;
+ Break;
+ end;
+ if pp.FinallyOffset <> InvalidVal then
+ pp.FinallyOffset := pp.FinallyOffset + FCurrentPosition;
+ if pp.ExceptOffset <> InvalidVal then
+ pp.ExceptOffset := pp.ExceptOffset + FCurrentPosition;
+ if pp.Finally2Offset <> InvalidVal then
+ pp.Finally2Offset := pp.Finally2Offset + FCurrentPosition;
+ if pp.EndOfBlock <> InvalidVal then
+ pp.EndOfBlock := pp.EndOfBlock + FCurrentPosition;
+ if ((pp.FinallyOffset <> InvalidVal) and (pp.FinallyOffset >= FDataLength)) or
+ ((pp.ExceptOffset <> InvalidVal) and (pp.ExceptOffset >= FDataLength)) or
+ ((pp.Finally2Offset <> InvalidVal) and (pp.Finally2Offset >= FDataLength)) or
+ ((pp.EndOfBlock <> InvalidVal) and (pp.EndOfBlock >= FDataLength)) then
+ begin
+ CMD_Err(ErOutOfRange);
+ pp.Free;
+ Break;
+ end;
+ FExceptionStack.Add(pp);
+ end;
+ cm_poexh:
+ begin
+ if FCurrentPosition >= FDataLength then
+ begin
+ CMD_Err(erOutOfRange); // Error
+ break;
+ end;
+ p := FData^[FCurrentPosition];
+ Inc(FCurrentPosition);
+ case p of
+ 2:
+ begin
+ if (FExceptionStack.Count = 0) then
+ begin
+ cmd_err(ErOutOfRange);
+ Break;
+ end;
+ pp := FExceptionStack.Data^[FExceptionStack.Count -1];
+ if pp = nil then begin
+ cmd_err(ErOutOfRange);
+ Break;
+ end;
+ pp.ExceptOffset := InvalidVal;
+ if pp.Finally2Offset <> InvalidVal then
+ begin
+ FCurrentPosition := pp.Finally2Offset;
+ pp.Finally2Offset := InvalidVal;
+ end else begin
+ p := pp.EndOfBlock;
+ pp.Free;
+ FExceptionStack.DeleteLast;
+ if FExitPoint <> InvalidVal then
+ begin
+ FCurrentPosition := FExitPoint;
+ end else begin
+ FCurrentPosition := p;
+ end;
+ end;
+ end;
+ 0:
+ begin
+ pp := FExceptionStack.Data^[FExceptionStack.Count -1];
+ if pp = nil then begin
+ cmd_err(ErOutOfRange);
+ Break;
+ end;
+ if pp.FinallyOffset <> InvalidVal then
+ begin
+ FCurrentPosition := pp.FinallyOffset;
+ pp.FinallyOffset := InvalidVal;
+ end else if pp.Finally2Offset <> InvalidVal then
+ begin
+ FCurrentPosition := pp.Finally2Offset;
+ pp.ExceptOffset := InvalidVal;
+ end else begin
+ p := pp.EndOfBlock;
+ pp.Free;
+ FExceptionStack.DeleteLast;
+ if ExEx <> eNoError then
+ begin
+ Tmp := ExObject;
+ ExObject := nil;
+ ExceptionProc(ExProc, ExPos, ExEx, ExParam, Tmp);
+ end else
+ if FExitPoint <> InvalidVal then
+ begin
+ FCurrentPosition := FExitPoint;
+ end else begin
+ FCurrentPosition := p;
+ end;
+ end;
+ end;
+ 1:
+ begin
+ pp := FExceptionStack.Data^[FExceptionStack.Count -1];
+ if pp = nil then begin
+ cmd_err(ErOutOfRange);
+ Break;
+ end;
+ if (ExEx <> ENoError) and (pp.ExceptOffset <> InvalidVal) and (pp.ExceptOffset <> InvalidVal -1) then
+ begin
+ FCurrentPosition := pp.ExceptOffset;
+ pp.ExceptOffset := Cardinal(InvalidVal -1);
+ pp.ExceptionData := ExEx;
+ pp.ExceptionObject := ExObject;
+ pp.ExceptionParam := ExParam;
+ ExEx := ErNoError;
+ ExObject := nil;
+ end else if (pp.Finally2Offset <> InvalidVal) then
+ begin
+ FCurrentPosition := pp.Finally2Offset;
+ pp.Finally2Offset := InvalidVal;
+ end else begin
+ p := pp.EndOfBlock;
+ pp.Free;
+ FExceptionStack.DeleteLast;
+ if (ExEx <> eNoError) and (p <> InvalidVal) then
+ begin
+ Tmp := ExObject;
+ ExObject := nil;
+ ExceptionProc(ExProc, ExPos, ExEx, ExParam, Tmp);
+ end else
+ if FExitPoint <> InvalidVal then
+ begin
+ FCurrentPosition := FExitPoint;
+ end else begin
+ FCurrentPosition := p;
+ end;
+ end;
+ end;
+ 3:
+ begin
+ pp := FExceptionStack.Data^[FExceptionStack.Count -1];
+ if pp = nil then begin
+ cmd_err(ErOutOfRange);
+ Break;
+ end;
+ p := pp.EndOfBlock;
+ pp.Free;
+ FExceptionStack.DeleteLast;
+ if ExEx <> eNoError then
+ begin
+ Tmp := ExObject;
+ ExObject := nil;
+ ExceptionProc(ExProc, ExPos, ExEx, ExParam, Tmp);
+ end else
+ if FExitPoint <> InvalidVal then
+ begin
+ FCurrentPosition := FExitPoint;
+ end else begin
+ FCurrentPosition := p;
+ end;
+ end;
+ end;
+ end;
+ cm_spc:
+ begin
+ if not ReadVariable(vd, False) then
+ Break;
+ if vd.FreeType <> vtNone then
+ begin
+ FTempVars.Pop;
+ CMD_Err(erInvalidOpcodeParameter);
+ break;
+ end;
+ if (Vd.aType.BaseType <> btPointer) then
+ begin
+ CMD_Err(erInvalidOpcodeParameter);
+ break;
+ end;
+ if not ReadVariable(vs, False) then
+ Break;
+ if Pointer(Pointer(IPointer(vD.P)+PointerSize2)^) <> nil then
+ DestroyHeapVariant2(Pointer(vD.P^), Pointer(Pointer(IPointer(vd.P)+PointerSize)^));
+ if vs.aType.BaseType = btPointer then
+ begin
+ if Pointer(vs.P^) <> nil then
+ begin
+ Pointer(vd.P^) := CreateHeapVariant2(Pointer(Pointer(IPointer(vs.P) + PointerSize)^));
+ Pointer(Pointer(IPointer(vd.P) + PointerSize)^) := Pointer(Pointer(IPointer(vs.P) + PointerSize)^);
+ Pointer(Pointer(IPointer(vd.P) + PointerSize2)^) := Pointer(1);
+ if not CopyArrayContents(Pointer(vd.P^), Pointer(vs.P^), 1, Pointer(Pointer(IPointer(vd.P) + PointerSize)^)) then
+ begin
+ if vs.FreeType <> vtNone then
+ FTempVars.Pop;
+ CMD_Err(ErTypeMismatch);
+ break;
+ end;
+ end else
+ begin
+ Pointer(vd.P^) := nil;
+ Pointer(Pointer(IPointer(vd.P) + PointerSize)^) := nil;
+ Pointer(Pointer(IPointer(vd.P) + PointerSize2)^) := nil;
+ end;
+ end else begin
+ Pointer(vd.P^) := CreateHeapVariant2(vs.aType);
+ Pointer(Pointer(IPointer(vd.P) + PointerSize)^) := vs.aType;
+ LongBool(Pointer(IPointer(vd.P) + PointerSize2)^) := true;
+ if not CopyArrayContents(Pointer(vd.P^), vs.P, 1, vs.aType) then
+ begin
+ if vs.FreeType <> vtNone then
+ FTempVars.Pop;
+ CMD_Err(ErTypeMismatch);
+ break;
+ end;
+ end;
+ if vs.FreeType <> vtNone then
+ FTempVars.Pop;
+
+ end;
+ cm_nop:;
+ cm_dec:
+ begin
+ if not ReadVariable(vd, True) then
+ Break;
+ if vd.FreeType <> vtNone then
+ begin
+ FTempVars.Pop;
+ CMD_Err(erInvalidOpcodeParameter);
+ break;
+ end;
+ case vd.aType.BaseType of
+ btu8: dec(tbtu8(vd.P^));
+ bts8: dec(tbts8(vd.P^));
+ btu16: dec(tbtu16(vd.P^));
+ bts16: dec(tbts16(vd.P^));
+ btu32: dec(tbtu32(vd.P^));
+ bts32: dec(tbts32(vd.P^));
+{$IFNDEF PS_NOINT64}
+ bts64: dec(tbts64(vd.P^));
+{$ENDIF}
+ else
+ begin
+ CMD_Err(ErTypeMismatch);
+ Break;
+ end;
+ end;
+ end;
+ cm_inc:
+ begin
+ if not ReadVariable(vd, True) then
+ Break;
+ if vd.FreeType <> vtNone then
+ begin
+ FTempVars.Pop;
+ CMD_Err(erInvalidOpcodeParameter);
+ break;
+ end;
+ case vd.aType.BaseType of
+ btu8: Inc(tbtu8(vd.P^));
+ bts8: Inc(tbts8(vd.P^));
+ btu16: Inc(tbtu16(vd.P^));
+ bts16: Inc(tbts16(vd.P^));
+ btu32: Inc(tbtu32(vd.P^));
+ bts32: Inc(tbts32(vd.P^));
+{$IFNDEF PS_NOINT64}
+ bts64: Inc(tbts64(vd.P^));
+{$ENDIF}
+ else
+ begin
+ CMD_Err(ErTypeMismatch);
+ Break;
+ end;
+ end;
+ end;
+ cm_sp:
+ begin
+ if not ReadVariable(vd, False) then
+ Break;
+ if vd.FreeType <> vtNone then
+ begin
+ FTempVars.Pop;
+ CMD_Err(erInvalidOpcodeParameter);
+ break;
+ end;
+ if (Vd.aType.BaseType <> btPointer) then
+ begin
+ CMD_Err(erInvalidOpcodeParameter);
+ break;
+ end;
+ if not ReadVariable(vs, False) then
+ Break;
+ if vs.FreeType <> vtNone then
+ begin
+ FTempVars.Pop;
+ CMD_Err(erInvalidOpcodeParameter);
+ break;
+ end;
+ if vs.aType.BaseType = btPointer then
+ begin
+ Pointer(vd.P^) := Pointer(vs.p^);
+ Pointer(Pointer(IPointer(vd.P)+PointerSize)^) := Pointer(Pointer(IPointer(vs.P)+PointerSize)^);
+ end
+ else
+ begin
+ Pointer(vd.P^) := vs.P;
+ Pointer(Pointer(IPointer(vd.P)+PointerSize)^) := vs.aType;
+ end;
+ end;
+ Cm_cv:
+ begin
+ if not ReadVariable(vd, True) then
+ Break;
+ if vd.aType.BaseType <> btProcPtr then
+ begin
+ if vd.FreeType <> vtNone then
+ FTempVars.Pop;
+ CMD_Err(ErTypeMismatch);
+ break;
+ end;
+ p := tbtu32(vd.P^);
+ if vd.FreeType <> vtNone then
+ FTempVars.Pop;
+ if (p = 0) and (Pointer(Pointer(IPointer(vd.p)+PointerSize2)^) <> nil) then
+ begin
+ if not InvokeExternalMethod(TPSTypeRec_ProcPtr(vd.aType), Pointer(Pointer(IPointer(vd.p)+PointerSize)^), Pointer(Pointer(IPointer(vd.p)+PointerSize2)^)) then
+ Break;
+ end else begin
+ if (p >= FProcs.Count) or (p = FMainProc) then begin
+ CMD_Err(erOutOfProcRange);
+ break;
+ end;
+ u := FProcs.Data^[p];
+ if u.ClassType = TPSExternalProcRec then begin
+ try
+ if not TPSExternalProcRec(u).ProcPtr(Self, TPSExternalProcRec(u), FGlobalVars, FStack) then begin
+ if ExEx = erNoError then
+ CMD_Err(erCouldNotCallProc);
+ Break;
+ end;
+ except
+ {$IFDEF DELPHI6UP}
+ Tmp := AcquireExceptionObject;
+ {$ELSE}
+ if RaiseList <> nil then
+ begin
+ Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject);
+ PRaiseFrame(RaiseList)^.ExceptObject := nil;
+ end else
+ Tmp := nil;
+ {$ENDIF}
+ if Tmp <> nil then
+ begin
+ if Tmp is EPSException then
+ begin
+ ExceptionProc(EPSException(tmp).ProcNo, EPSException(tmp).ProcPos, erCustomError, tbtString(EPSException(tmp).Message), nil);
+ break;
+ end else
+ if Tmp is EDivByZero then
+ begin
+ CMD_Err3(erDivideByZero, '', Tmp);
+ break;
+ end;
+ if Tmp is EZeroDivide then
+ begin
+ CMD_Err3(erDivideByZero, '', Tmp);
+ break;
+ end;
+ if Tmp is EMathError then
+ begin
+ CMD_Err3(erMathError, '', Tmp);
+ break;
+ end;
+ end;
+ if (Tmp <> nil) and (Tmp is Exception) then
+ CMD_Err3(erException, tbtString(Exception(Tmp).Message), Tmp) else
+ CMD_Err3(erException, '', Tmp);
+ Break;
+ end;
+ end
+ else begin
+ vtemp := FStack.PushType(FReturnAddressType);
+ PPSVariantReturnAddress(vtemp).Addr.ProcNo := FCurrProc;
+ PPSVariantReturnAddress(vtemp).Addr.Position := FCurrentPosition;
+ PPSVariantReturnAddress(vtemp).Addr.StackBase := FCurrStackBase;
+ FCurrStackBase := FStack.Count - 1;
+ FCurrProc := TPSInternalProcRec(u);
+ FData := FCurrProc.Data;
+ FDataLength := FCurrProc.Length;
+ FCurrentPosition := 0;
+ end;
+ end;
+ end;
+ CM_CO:
+ begin
+ if FCurrentPosition >= FDataLength then
+ begin
+ CMD_Err(erOutOfRange); // Error
+ break;
+ end;
+ calctype := FData^[FCurrentPosition];
+ Inc(FCurrentPosition);
+ if not ReadVariable(v3, True) then
+ Break;
+ if v3.FreeType <> vtNone then
+ begin
+ if v3.aType.BaseType in NeedFinalization then
+ FinalizeVariant(v3.P, v3.aType);
+ p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
+ Dec(FTempVars.FCount);
+ {$IFNDEF PS_NOSMARTLIST}
+ Inc(FTempVars.FCheckCount);
+ if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
+ {$ENDIF}
+ FTempVars.FLength := P;
+ if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
+ CMD_Err(erInvalidOpcodeParameter);
+ break;
+ end;
+ if not ReadVariable(vs, True) then
+ Break;
+ if not ReadVariable(vd, True) then
+ begin
+ if vs.FreeType <> vtNone then
+ begin
+ if vs.aType.BaseType in NeedFinalization then
+ FinalizeVariant(vs.P, vs.aType);
+ p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
+ Dec(FTempVars.FCount);
+ {$IFNDEF PS_NOSMARTLIST}
+ Inc(FTempVars.FCheckCount);
+ if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
+ {$ENDIF}
+ FTempVars.FLength := P;
+ if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
+ end;
+ Break;
+ end;
+ DoBooleanCalc(Vs.P, Vd.P, v3.P, vs.aType, vd.aType, v3.aType, CalcType);
+ if vd.FreeType <> vtNone then
+ begin
+ if vd.aType.BaseType in NeedFinalization then
+ FinalizeVariant(vd.P, vd.aType);
+ p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
+ Dec(FTempVars.FCount);
+ {$IFNDEF PS_NOSMARTLIST}
+ Inc(FTempVars.FCheckCount);
+ if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
+ {$ENDIF}
+ FTempVars.FLength := P;
+ if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
+ end;
+ if vs.FreeType <> vtNone then
+ begin
+ if vs.aType.BaseType in NeedFinalization then
+ FinalizeVariant(vs.P, vs.aType);
+ p := IPointer(FTempVars.Data^[FtempVars.Count-1]) - IPointer(FtempVars.DataPtr);
+ Dec(FTempVars.FCount);
+ {$IFNDEF PS_NOSMARTLIST}
+ Inc(FTempVars.FCheckCount);
+ if FTempVars.FCheckCount > FMaxCheckCount then FTempVars.Recreate;
+ {$ENDIF}
+ FTempVars.FLength := P;
+ if ((FTempVars.FCapacity - FTempVars.FLength) shr 12) > 2 then FTempVars.AdjustLength;
+ end;
+ end;
+
+ else
+ CMD_Err(erInvalidOpcode); // Error
+ end;
+ end;
+// if cmd <> invalidval then ProfilerExitProc(Cmd+1);
+// if ExEx <> erNoError then FStatus := FOldStatus;
+ until (FExceptionStack.Count = 0) or (Fstatus <> IsRunning);
+ if FStatus = isLoaded then begin
+ for I := Longint(FStack.Count) - 1 downto 0 do
+ FStack.Pop;
+ FStack.Clear;
+ if FCallCleanup then Cleanup;
+ end;
+ Result := ExEx = erNoError;
+end;
+
+function NVarProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
+var
+ tmp: TPSVariantIFC;
+begin
+ case Longint(p.Ext1) of
+ 0:
+ begin
+ if @Caller.FOnSetNVariant = nil then begin Result := False; exit; end;
+ tmp := NewTPSVariantIFC(Stack.Items[Stack.Count - 2], True);
+ if (Tmp.Dta = nil) or (tmp.aType.BaseType <> btVariant) then begin Result := False; exit; end;
+ Caller.FOnSetNVariant(Caller, Stack.GetAnsiString(-1), Variant(tmp.Dta^));
+ Result := true;
+ end;
+ 1:
+ begin
+ if @Caller.FOnGetNVariant = nil then begin Result := False; exit; end;
+ tmp := NewTPSVariantIFC(Stack.Items[Stack.Count - 1], False);
+ if (Tmp.Dta = nil) or (tmp.aType.BaseType <> btVariant) then begin Result := False; exit; end;
+ Variant(tmp.Dta^) := Caller.FOnGetNVariant(Caller, Stack.GetAnsiString(-2));
+ Result := true;
+ end;
+ else
+ Result := False;
+ end;
+end;
+
+function DefProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
+var
+ temp: TPSVariantIFC;
+ I: Longint;
+ b: Boolean;
+ pex: TPSExceptionHandler;
+ Tmp: TObject;
+begin
+ case Longint(p.Ext1) of
+ 0: Stack.SetAnsiString(-1, IntToStr(Stack.{$IFNDEF PS_NOINT64}GetInt64{$ELSE}GetInt{$ENDIF}(-2))); // inttostr
+ 1: Stack.SetInt(-1, StrToInt(Stack.GetAnsiString(-2))); // strtoint
+ 2: Stack.SetInt(-1, StrToIntDef(Stack.GetAnsiString(-2), Stack.GetInt(-3))); // strtointdef
+ 3:
+ if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then
+ Stack.SetInt(-1, Pos(Stack.GetUnicodeString(-2), Stack.GetUnicodeString(-3)))// pos
+ else
+ if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then
+ Stack.SetInt(-1, Pos(Stack.GetWideString(-2), Stack.GetWideString(-3)))// pos
+ else
+ Stack.SetInt(-1, Pos(Stack.GetAnsiString(-2), Stack.GetAnsiString(-3)));// pos
+ 4:
+ if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then
+ Stack.SetWideString(-1, Copy(Stack.GetWideString(-2), Stack.GetInt(-3), Stack.GetInt(-4))) // copy
+ else
+ if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then
+ Stack.SetUnicodeString(-1, Copy(Stack.GetUnicodeString(-2), Stack.GetInt(-3), Stack.GetInt(-4))) // copy
+ else
+ Stack.SetAnsiString(-1, Copy(Stack.GetAnsiString(-2), Stack.GetInt(-3), Stack.GetInt(-4))); // copy
+ 5: //delete
+ begin
+ temp := NewTPSVariantIFC(Stack[Stack.Count -1], True);
+ if (temp.Dta <> nil) and (temp.aType.BaseType = btUnicodeString) then
+ begin
+ Delete(tbtUnicodeString(temp.Dta^), Stack.GetInt(-2), Stack.GetInt(-3));
+ end else
+ if (temp.Dta <> nil) and (temp.aType.BaseType = btWideString) then
+ begin
+ Delete(tbtwidestring(temp.Dta^), Stack.GetInt(-2), Stack.GetInt(-3));
+ end else begin
+ if (temp.Dta = nil) or (temp.aType.BaseType <> btString) then
+ begin
+ Result := False;
+ exit;
+ end;
+ Delete(tbtstring(temp.Dta^), Stack.GetInt(-2), Stack.GetInt(-3));
+ end;
+ end;
+ 6: // insert
+ begin
+ temp := NewTPSVariantIFC(Stack[Stack.Count -2], True);
+ if (temp.Dta <> nil) and (temp.aType.BaseType = btUnicodeString) then begin
+ Insert(Stack.GetUnicodeString(-1), tbtUnicodeString(temp.Dta^), Stack.GetInt(-3));
+ end else if (temp.Dta <> nil) and (temp.aType.BaseType = btWideString) then begin
+ Insert(Stack.GetWideString(-1), tbtwidestring(temp.Dta^), Stack.GetInt(-3));
+ end else begin
+ if (temp.Dta = nil) or (temp.aType.BaseType <> btString) then
+ begin
+ Result := False;
+ exit;
+ end;
+ Insert(Stack.GetAnsiString(-1), tbtstring(temp.Dta^), Stack.GetInt(-3));
+ end;
+ end;
+ 7: // StrGet
+ begin
+ temp := NewTPSVariantIFC(Stack[Stack.Count -2], True);
+ if (temp.Dta = nil) or (temp.aType.BaseType <> btString) then
+ begin
+ Result := False;
+ exit;
+ end;
+ I := Stack.GetInt(-3);
+ if (i<1) or (i>length(tbtstring(temp.Dta^))) then
+ begin
+ Caller.CMD_Err2(erCustomError, tbtString(RPS_OutOfStringRange));
+ Result := False;
+ exit;
+ end;
+ Stack.SetInt(-1,Ord(tbtstring(temp.Dta^)[i]));
+ end;
+ 8: // StrSet
+ begin
+ temp := NewTPSVariantIFC(Stack[Stack.Count -3], True);
+ if (temp.Dta = nil) or (temp.aType.BaseType <> btString) then
+ begin
+ Result := False;
+ exit;
+ end;
+ I := Stack.GetInt(-2);
+ if (i<1) or (i>length(tbtstring(temp.Dta^))) then
+ begin
+ Caller.CMD_Err2(erCustomError, tbtString(RPS_OutOfStringRange));
+ Result := True;
+ exit;
+ end;
+ tbtstring(temp.Dta^)[i] := tbtchar(Stack.GetInt(-1));
+ end;
+ 10:
+{$IFDEF DELPHI2009UP}
+ if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then
+ Stack.SetUnicodeString(-1, UpperCase(Stack.GetUnicodeString(-2))) // Uppercase
+ else
+{$ENDIF}
+ if (Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString) or
+ (Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString) then
+ Stack.SetWideString(-1, WideUpperCase(Stack.GetWideString(-2))) // Uppercase
+ else
+ Stack.SetAnsiString(-1, FastUppercase(Stack.GetAnsiString(-2))); // Uppercase
+ 11:
+{$IFDEF DELPHI2009UP}
+ if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then
+ Stack.SetUnicodeString(-1, LowerCase(Stack.GetUnicodeString(-2))) // Uppercase
+ else
+{$ENDIF}
+ if (Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString) or
+ (Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString) then
+ Stack.SetWideString(-1, WideLowerCase(Stack.GetWideString(-2))) // Uppercase
+ else
+ Stack.SetAnsiString(-1, FastLowercase(Stack.GetAnsiString(-2)));// LowerCase
+ 12:
+ if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then
+ Stack.SetUnicodeString(-1, SysUtils.Trim(Stack.GetUnicodestring(-2))) // Uppercase
+ else if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then
+ Stack.SetWideString(-1, SysUtils.Trim(Stack.GetWideString(-2))) // Uppercase
+ else
+ Stack.SetAnsiString(-1, Trim(Stack.GetAnsiString(-2)));// Trim
+ 13: Stack.SetInt(-1, Length(Stack.GetAnsiString(-2))); // Length
+ 14: // SetLength
+ begin
+ temp := NewTPSVariantIFC(Stack[Stack.Count -1], True);
+ if (temp.Dta = nil) or (temp.aType.BaseType <> btString) then
+ begin
+ Result := False;
+ exit;
+ end;
+ SetLength(tbtstring(temp.Dta^), STack.GetInt(-2));
+ end;
+ 15: Stack.SetReal(-1, Sin(Stack.GetReal(-2))); // Sin
+ 16: Stack.SetReal(-1, Cos(Stack.GetReal(-2))); // Cos
+ 17: Stack.SetReal(-1, SQRT(Stack.GetReal(-2))); // Sqrt
+ 18: Stack.SetInt(-1, Round(Stack.GetReal(-2))); // Round
+ 19: Stack.SetInt(-1, Trunc(Stack.GetReal(-2))); // Trunc
+ 20: Stack.SetReal(-1, Int(Stack.GetReal(-2))); // Int
+ 21: Stack.SetReal(-1, Pi); // Pi
+ 22: Stack.SetReal(-1, Abs(Stack.GetReal(-2))); // Abs
+ 23: Stack.SetReal(-1, StrToFloat(Stack.GetAnsiString(-2))); // StrToFloat
+ 24: Stack.SetAnsiString(-1, FloatToStr(Stack.GetReal(-2)));// FloatToStr
+ 25:
+ if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then
+ Stack.SetUnicodeString(-1, upadL(Stack.GetUnicodeString(-2), Stack.GetInt(-3))) // PadL
+ else
+ if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then
+ Stack.SetWideString(-1, wPadL(Stack.GetWideString(-2), Stack.GetInt(-3))) // PadL
+ else
+ Stack.SetAnsiString(-1, PadL(Stack.GetAnsiString(-2), Stack.GetInt(-3))); // PadL
+ 26:
+ if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then
+ Stack.SetUnicodeString(-1, uPadR(Stack.GetUnicodeString(-2), Stack.GetInt(-3))) // PadR
+ else
+ if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then
+ Stack.SetWideString(-1, wPadR(Stack.GetWideString(-2), Stack.GetInt(-3))) // PadR
+ else
+ Stack.SetAnsiString(-1, PadR(Stack.GetAnsiString(-2), Stack.GetInt(-3))); // PadR
+ 27:
+ if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then
+ Stack.SetUnicodeString(-1, uPadZ(Stack.GetUnicodeString(-2), Stack.GetInt(-3)))// PadZ
+ else
+ if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then
+ Stack.SetWideString(-1, wPadZ(Stack.GetWideString(-2), Stack.GetInt(-3)))// PadZ
+ else
+ Stack.SetAnsiString(-1, PadZ(Stack.GetAnsiString(-2), Stack.GetInt(-3)));// PadZ
+ 28: Stack.SetAnsiString(-1, StringOfChar(tbtChar(Stack.GetInt(-2)), Stack.GetInt(-3))); // Replicate/StrOfChar
+ 29: // Assigned
+ begin
+ temp := NewTPSVariantIFC(Stack[Stack.Count -2], True);
+ if Temp.dta = nil then
+ begin
+ Result := False;
+ exit;
+ end;
+ case temp.aType.BaseType of
+ btU8, btS8: b := tbtu8(temp.dta^) <> 0;
+ btU16, btS16: b := tbtu16(temp.dta^) <> 0;
+ btU32, btS32: b := tbtu32(temp.dta^) <> 0;
+ btString, btPChar: b := tbtstring(temp.dta^) <> '';
+{$IFNDEF PS_NOWIDESTRING}
+ btWideString: b := tbtwidestring(temp.dta^)<> '';
+ btUnicodeString: b := tbtUnicodeString(temp.dta^)<> '';
+{$ENDIF}
+ btArray, btClass{$IFNDEF PS_NOINTERFACES}, btInterface{$ENDIF}: b := Pointer(temp.dta^) <> nil;
+ else
+ Result := False;
+ Exit;
+ end;
+ if b then
+ Stack.SetInt(-1, 1)
+ else
+ Stack.SetInt(-1, 0);
+ end;
+ 30:
+ begin {RaiseLastException}
+ if (Caller.FExceptionStack.Count > 0) then begin
+ pex := Caller.FExceptionStack.Data[Caller.fExceptionStack.Count -1];
+ if pex.ExceptOffset = Cardinal(InvalidVal -1) then begin
+ Tmp := pex.ExceptionObject;
+ pex.ExceptionObject := nil;
+ Caller.ExceptionProc(Caller.ExProc, pex.ExceptOffset, pex.ExceptionData, pex.ExceptionParam, tmp);
+ end;
+ end;
+ end;
+ 31: Caller.CMD_Err2(TPSError(Stack.GetInt(-1)), Stack.GetAnsiString(-2)); {RaiseExeption}
+ 32: Stack.SetInt(-1, Ord(Caller.LastEx)); {ExceptionType}
+ 33: Stack.SetAnsiString(-1, Caller.LastExParam); {ExceptionParam}
+ 34: Stack.SetInt(-1, Caller.LastExProc); {ExceptionProc}
+ 35: Stack.SetInt(-1, Caller.LastExPos); {ExceptionPos}
+ 36: Stack.SetAnsiString(-1, PSErrorToString(TPSError(Stack.GetInt(-2)), Stack.GetAnsiString(-3))); {ExceptionToString}
+ 37: Stack.SetAnsiString(-1, tbtString(AnsiUpperCase(string(Stack.GetAnsiString(-2))))); // AnsiUppercase
+ 38: Stack.SetAnsiString(-1, tbtString(AnsiLowercase(string(Stack.GetAnsiString(-2))))); // AnsiLowerCase
+{$IFNDEF PS_NOINT64}
+ 39: Stack.SetInt64(-1, StrToInt64(string(Stack.GetAnsiString(-2)))); // StrToInt64
+ 40: Stack.SetAnsiString(-1, SysUtils.IntToStr(Stack.GetInt64(-2)));// Int64ToStr
+{$ENDIF}
+ 41: // sizeof
+ begin
+ temp := NewTPSVariantIFC(Stack[Stack.Count -2], False);
+ if Temp.aType = nil then
+ Stack.SetInt(-1, 0)
+ else
+ Stack.SetInt(-1, Temp.aType.RealSize)
+ end;
+{$IFNDEF PS_NOWIDESTRING}
+ 42: // WStrGet
+ begin
+ temp := NewTPSVariantIFC(Stack[Stack.Count -2], True);
+ if temp.dta = nil then begin
+ result := false;
+ exit;
+ end;
+ case temp.aType.BaseType of
+ btWideString:
+ begin
+ I := Stack.GetInt(-3);
+ if (i<1) or (i>length(tbtwidestring(temp.Dta^))) then
+ begin
+ Caller.CMD_Err2(erCustomError, tbtString(RPS_OutOfStringRange));
+ Result := False;
+ exit;
+ end;
+ Stack.SetInt(-1,Ord(tbtwidestring(temp.Dta^)[i]));
+ end;
+ btUnicodeString:
+ begin
+ I := Stack.GetInt(-3);
+ if (i<1) or (i>length(tbtUnicodeString(temp.Dta^))) then
+ begin
+ Caller.CMD_Err2(erCustomError, tbtString(RPS_OutOfStringRange));
+ Result := False;
+ exit;
+ end;
+ Stack.SetInt(-1,Ord(tbtUnicodeString(temp.Dta^)[i]));
+ end;
+
+ else
+ begin
+ Result := False;
+ exit;
+ end;
+ end;
+ end;
+ 43: // WStrSet
+ begin
+ temp := NewTPSVariantIFC(Stack[Stack.Count -3], True);
+ if (temp.Dta = nil) then
+ begin
+ Result := False;
+ exit;
+ end;
+ case temp.aType.BaseType of
+ btWideString:
+ begin
+ I := Stack.GetInt(-2);
+ if (i<1) or (i>length(tbtWidestring(temp.Dta^))) then
+ begin
+ Caller.CMD_Err2(erCustomError, tbtString(RPS_OutOfStringRange));
+ Result := True;
+ exit;
+ end;
+ tbtWidestring(temp.Dta^)[i] := WideChar(Stack.GetInt(-1));
+ end;
+
+ btUnicodeString:
+ begin
+ I := Stack.GetInt(-2);
+ if (i<1) or (i>length(tbtunicodestring(temp.Dta^))) then
+ begin
+ Caller.CMD_Err2(erCustomError, tbtString(RPS_OutOfStringRange));
+ Result := True;
+ exit;
+ end;
+ tbtunicodestring(temp.Dta^)[i] := WideChar(Stack.GetInt(-1));
+ end;
+ else
+ begin
+ Result := False;
+ exit;
+ end;
+ end;
+ end;
+{$ENDIF}
+ else
+ begin
+ Result := False;
+ exit;
+ end;
+ end;
+ Result := True;
+end;
+function GetArrayLength(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
+var
+ arr: TPSVariantIFC;
+begin
+ Arr := NewTPSVariantIFC(Stack[Stack.Count-2], True);
+ if (arr.Dta = nil) or (arr.aType.BaseType <> btArray) then
+ begin
+ Result := false;
+ exit;
+ end;
+ Stack.SetInt(-1, PSDynArrayGetLength(Pointer(arr.Dta^), arr.aType));
+ Result := True;
+end;
+
+function SetArrayLength(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
+var
+ arr: TPSVariantIFC;
+begin
+ Arr := NewTPSVariantIFC(Stack[Stack.Count-1], True);
+ if (arr.Dta = nil) or (arr.aType.BaseType <> btArray) then
+ begin
+ Result := false;
+ exit;
+ end;
+ PSDynArraySetLength(Pointer(arr.Dta^), arr.aType, Stack.GetInt(-2));
+ Result := True;
+end;
+
+
+function InterfaceProc(Sender: TPSExec; p: TPSExternalProcRec; Tag: Pointer): Boolean; forward;
+
+procedure RegisterInterfaceLibraryRuntime(Se: TPSExec);
+begin
+ SE.AddSpecialProcImport('intf', InterfaceProc, nil);
+end;
+
+{$IFNDEF DELPHI6UP}
+function Null: Variant;
+begin
+ Result := System.Null;
+end;
+
+function Unassigned: Variant;
+begin
+ Result := System.Unassigned;
+end;
+{$ENDIF}
+function Length_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
+var
+ arr: TPSVariantIFC;
+begin
+ arr:=NewTPSVariantIFC(Stack[Stack.Count-2],false);
+ case arr.aType.BaseType of
+ btArray:
+ begin
+ Stack.SetInt(-1,PSDynArrayGetLength(Pointer(arr.Dta^),arr.aType));
+ Result:=true;
+ end;
+ btStaticArray:
+ begin
+ Stack.SetInt(-1,TPSTypeRec_StaticArray(arr.aType).Size);
+ Result:=true;
+ end;
+ btString:
+ begin
+ Stack.SetInt(-1,length(tbtstring(arr.Dta^)));
+ Result:=true;
+ end;
+ {$IFNDEF PS_NOWIDESTRING}
+ btWideString:
+ begin
+ Stack.SetInt(-1,length(tbtWidestring(arr.Dta^)));
+ Result:=true;
+ end;
+ btUnicodeString:
+ begin
+ Stack.SetInt(-1,length(tbtUnicodeString(arr.Dta^)));
+ Result:=true;
+ end;
+ {$ENDIF}
+ btvariant:
+ begin
+ Stack.SetInt(-1,length(Variant(arr.Dta^)));
+ Result:=true;
+ end;
+ else
+ begin
+ Caller.CMD_Err(ErTypeMismatch);
+ result := true;
+ end;
+ end;
+end;
+
+
+function SetLength_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
+var
+ arr: TPSVariantIFC;
+begin
+ Result:=false;
+ arr:=NewTPSVariantIFC(Stack[Stack.Count-1],true);
+ if arr.aType.BaseType=btArray then
+ begin
+ PSDynArraySetLength(Pointer(arr.Dta^),arr.aType,Stack.GetInt(-2));
+ Result:=true;
+ end else
+ if arr.aType.BaseType=btString then
+ begin
+ SetLength(tbtstring(arr.Dta^),STack.GetInt(-2));
+ Result:=true;
+{$IFNDEF PS_NOWIDESTRING}
+ end else
+ if arr.aType.BaseType=btWideString then
+ begin
+ SetLength(tbtwidestring(arr.Dta^),STack.GetInt(-2));
+ Result:=true;
+ end else
+ if arr.aType.BaseType=btUnicodeString then
+ begin
+ SetLength(tbtUnicodeString(arr.Dta^),STack.GetInt(-2));
+ Result:=true;
+{$ENDIF}
+ end;
+end;
+
+function Low_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
+var
+ arr: TPSVariantIFC;
+begin
+ Result:=true;
+ arr:=NewTPSVariantIFC(Stack[Stack.Count-2],false);
+ case arr.aType.BaseType of
+ btArray : Stack.SetInt(-1,0);
+ btStaticArray: Stack.SetInt(-1,TPSTypeRec_StaticArray(arr.aType).StartOffset);
+ btString : Stack.SetInt(-1,1);
+ btU8 : Stack.SetInt(-1,Low(Byte)); //Byte: 0
+ btS8 : Stack.SetInt(-1,Low(ShortInt)); //ShortInt: -128
+ btU16 : Stack.SetInt(-1,Low(Word)); //Word: 0
+ btS16 : Stack.SetInt(-1,Low(SmallInt)); //SmallInt: -32768
+ btU32 : Stack.SetInt(-1,Low(Cardinal)); //Cardinal/LongWord: 0
+ btS32 : Stack.SetInt(-1,Low(Integer)); //Integer/LongInt: -2147483648
+ else Result:=false;
+ end;
+end;
+
+function High_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
+var
+ arr: TPSVariantIFC;
+begin
+ Result:=true;
+ arr:=NewTPSVariantIFC(Stack[Stack.Count-2],false);
+ case arr.aType.BaseType of
+ btArray : Stack.SetInt(-1,PSDynArrayGetLength(Pointer(arr.Dta^),arr.aType)-1);
+ btStaticArray: Stack.SetInt(-1,TPSTypeRec_StaticArray(arr.aType).StartOffset+TPSTypeRec_StaticArray(arr.aType).Size-1);
+ btString : Stack.SetInt(-1,Length(tbtstring(arr.Dta^)));
+ btU8 : Stack.SetInt(-1,High(Byte)); //Byte: 255
+ btS8 : Stack.SetInt(-1,High(ShortInt)); //ShortInt: 127
+ btU16 : Stack.SetInt(-1,High(Word)); //Word: 65535
+ btS16 : Stack.SetInt(-1,High(SmallInt)); //SmallInt: 32767
+ btU32 : Stack.SetUInt(-1,High(Cardinal)); //Cardinal/LongWord: 4294967295
+ btS32 : Stack.SetInt(-1,High(Integer)); //Integer/LongInt: 2147483647
+ else Result:=false;
+ end;
+end;
+
+function Dec_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
+var
+ arr: TPSVariantIFC;
+begin
+ Result:=true;
+ arr:=NewTPSVariantIFC(Stack[Stack.Count-1],true);
+ case arr.aType.BaseType of
+ btU8 : Stack.SetInt(-1,Tbtu8(arr.dta^)-1); //Byte
+ btS8 : Stack.SetInt(-1,Tbts8(arr.dta^)-1); //ShortInt
+ btU16 : Stack.SetInt(-1,Tbtu16(arr.dta^)-1); //Word
+ btS16 : Stack.SetInt(-1,Tbts16(arr.dta^)-1); //SmallInt
+ btU32 : Stack.SetInt(-1,Tbtu32(arr.dta^)-1); //Cardinal/LongWord
+ btS32 : Stack.SetInt(-1,Tbts32(arr.dta^)-1); //Integer/LongInt
+ else Result:=false;
+ end;
+end;
+
+function Inc_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
+var
+ arr: TPSVariantIFC;
+begin
+ Result:=true;
+ arr:=NewTPSVariantIFC(Stack[Stack.Count-1],true);
+ case arr.aType.BaseType of
+ btU8 : Stack.SetInt(-1,Tbtu8(arr.dta^)+1); //Byte
+ btS8 : Stack.SetInt(-1,Tbts8(arr.dta^)+1); //ShortInt
+ btU16 : Stack.SetInt(-1,Tbtu16(arr.dta^)+1); //Word
+ btS16 : Stack.SetInt(-1,Tbts16(arr.dta^)+1); //SmallInt
+ btU32 : Stack.SetInt(-1,Tbtu32(arr.dta^)+1); //Cardinal/LongWord
+ btS32 : Stack.SetInt(-1,Tbts32(arr.dta^)+1); //Integer/LongInt
+ else Result:=false;
+ end;
+end;
+
+
+procedure TPSExec.RegisterStandardProcs;
+begin
+ RegisterFunctionName('!NOTIFICATIONVARIANTSET', NVarProc, Pointer(0), nil);
+ RegisterFunctionName('!NOTIFICATIONVARIANTGET', NVarProc, Pointer(1), nil);
+
+ RegisterFunctionName('INTTOSTR', DefProc, Pointer(0), nil);
+ RegisterFunctionName('STRTOINT', DefProc, Pointer(1), nil);
+ RegisterFunctionName('STRTOINTDEF', DefProc, Pointer(2), nil);
+ RegisterFunctionName('POS', DefProc, Pointer(3), nil);
+ RegisterFunctionName('COPY', DefProc, Pointer(4), nil);
+ RegisterFunctionName('DELETE', DefProc, Pointer(5), nil);
+ RegisterFunctionName('INSERT', DefProc, Pointer(6), nil);
+
+ RegisterFunctionName('STRGET', DefProc, Pointer(7), nil);
+ RegisterFunctionName('STRSET', DefProc, Pointer(8), nil);
+ RegisterFunctionName('UPPERCASE', DefProc, Pointer(10), nil);
+ RegisterFunctionName('LOWERCASE', DefProc, Pointer(11), nil);
+ RegisterFunctionName('TRIM', DefProc, Pointer(12), nil);
+
+ RegisterFunctionName('LENGTH',Length_,nil,nil);
+ RegisterFunctionName('SETLENGTH',SetLength_,nil,nil);
+ RegisterFunctionName('LOW',Low_,nil,nil);
+ RegisterFunctionName('HIGH',High_,nil,nil);
+ RegisterFunctionName('DEC',Dec_,nil,nil);
+ RegisterFunctionName('INC',Inc_,nil,nil);
+
+ RegisterFunctionName('SIN', DefProc, Pointer(15), nil);
+ RegisterFunctionName('COS', DefProc, Pointer(16), nil);
+ RegisterFunctionName('SQRT', DefProc, Pointer(17), nil);
+ RegisterFunctionName('ROUND', DefProc, Pointer(18), nil);
+ RegisterFunctionName('TRUNC', DefProc, Pointer(19), nil);
+ RegisterFunctionName('INT', DefProc, Pointer(20), nil);
+ RegisterFunctionName('PI', DefProc, Pointer(21), nil);
+ RegisterFunctionName('ABS', DefProc, Pointer(22), nil);
+ RegisterFunctionName('STRTOFLOAT', DefProc, Pointer(23), nil);
+ RegisterFunctionName('FLOATTOSTR', DefProc, Pointer(24), nil);
+ RegisterFunctionName('PADL', DefProc, Pointer(25), nil);
+ RegisterFunctionName('PADR', DefProc, Pointer(26), nil);
+ RegisterFunctionName('PADZ', DefProc, Pointer(27), nil);
+ RegisterFunctionName('REPLICATE', DefProc, Pointer(28), nil);
+ RegisterFunctionName('STRINGOFCHAR', DefProc, Pointer(28), nil);
+ RegisterFunctionName('!ASSIGNED', DefProc, Pointer(29), nil);
+
+ RegisterDelphiFunction(@Unassigned, 'UNASSIGNED', cdRegister);
+ RegisterDelphiFunction(@VarIsEmpty, 'VARISEMPTY', cdRegister);
+ RegisterDelphiFunction(@Null, 'NULL', cdRegister);
+ RegisterDelphiFunction(@VarIsNull, 'VARISNULL', cdRegister);
+ RegisterDelphiFunction(@VarType, 'VARTYPE', cdRegister);
+ {$IFNDEF PS_NOIDISPATCH}
+ RegisterDelphiFunction(@IDispatchInvoke, 'IDISPATCHINVOKE', cdregister);
+ {$ENDIF}
+
+
+ RegisterFunctionName('GETARRAYLENGTH', GetArrayLength, nil, nil);
+ RegisterFunctionName('SETARRAYLENGTH', SetArrayLength, nil, nil);
+
+ RegisterFunctionName('RAISELASTEXCEPTION', DefPRoc, Pointer(30), nil);
+ RegisterFunctionName('RAISEEXCEPTION', DefPRoc, Pointer(31), nil);
+ RegisterFunctionName('EXCEPTIONTYPE', DefPRoc, Pointer(32), nil);
+ RegisterFunctionName('EXCEPTIONPARAM', DefPRoc, Pointer(33), nil);
+ RegisterFunctionName('EXCEPTIONPROC', DefPRoc, Pointer(34), nil);
+ RegisterFunctionName('EXCEPTIONPOS', DefPRoc, Pointer(35), nil);
+ RegisterFunctionName('EXCEPTIONTOSTRING', DefProc, Pointer(36), nil);
+ RegisterFunctionName('ANSIUPPERCASE', DefProc, Pointer(37), nil);
+ RegisterFunctionName('ANSILOWERCASE', DefProc, Pointer(38), nil);
+
+ {$IFNDEF PS_NOINT64}
+ RegisterFunctionName('STRTOINT64', DefProc, Pointer(39), nil);
+ RegisterFunctionName('INT64TOSTR', DefProc, Pointer(40), nil);
+ {$ENDIF}
+ RegisterFunctionName('SIZEOF', DefProc, Pointer(41), nil);
+
+ {$IFNDEF PS_NOWIDESTRING}
+ RegisterFunctionName('WSTRGET', DefProc, Pointer(42), nil);
+ RegisterFunctionName('WSTRSET', DefProc, Pointer(43), nil);
+ {$ENDIF}
+
+ RegisterInterfaceLibraryRuntime(Self);
+end;
+
+
+function ToString(p: PansiChar): tbtString;
+begin
+ SetString(Result, p, StrLen(p));
+end;
+
+function IntPIFVariantToVariant(Src: pointer; aType: TPSTypeRec; var Dest: Variant): Boolean;
+ function BuildArray(P: Pointer; aType: TPSTypeRec; Len: Longint): Boolean;
+ var
+ i, elsize: Longint;
+ v: variant;
+ begin
+ elsize := aType.RealSize;
+ Dest := VarArrayCreate([0, Len-1], varVariant);
+ for i := 0 to Len -1 do
+ begin
+ if not IntPIFVariantToVariant(p, aType, v) then
+ begin
+ result := false;
+ exit;
+ end;
+ Dest[i] := v;
+ p := Pointer(IPointer(p) + Cardinal(elSize));
+ end;
+ result := true;
+ end;
+begin
+ if aType = nil then
+ begin
+ Dest := null;
+ Result := True;
+ exit;
+ end;
+ if aType.BaseType = btPointer then
+ begin
+ aType := TPSTypeRec(Pointer(IPointer(src)+PointerSize)^);
+ Src := Pointer(Pointer(Src)^);
+ end;
+
+ case aType.BaseType of
+ btVariant: Dest := variant(src^);
+ btArray: if not BuildArray(Pointer(Src^), TPSTypeRec_Array(aType).ArrayType, PSDynArrayGetLength(Pointer(src^), aType)) then begin result := false; exit; end;
+ btStaticArray: if not BuildArray(Pointer(Src), TPSTypeRec_StaticArray(aType).ArrayType, PSDynArrayGetLength(Pointer(src^), aType)) then begin result := false; exit; end;
+ btU8:
+ if aType.ExportName = 'BOOLEAN' then
+ Dest := boolean(tbtu8(Src^) <> 0)
+ else
+ Dest := tbtu8(Src^);
+ btS8: Dest := tbts8(Src^);
+ btU16: Dest := tbtu16(Src^);
+ btS16: Dest := tbts16(Src^);
+ btU32: Dest := {$IFDEF DELPHI6UP}tbtu32{$ELSE}tbts32{$ENDIF}(Src^);
+ btS32: Dest := tbts32(Src^);
+ btSingle: Dest := tbtsingle(Src^);
+ btCurrency: Dest:=tbtCurrency(Src^);
+ btDouble:
+ begin
+ if aType.ExportName = 'TDATETIME' then
+ Dest := TDateTime(tbtDouble(Src^))
+ else
+ Dest := tbtDouble(Src^);
+ end;
+ btExtended: Dest := tbtExtended(Src^);
+ btString: Dest := tbtString(Src^);
+ btPChar: Dest := ToString(PansiChar(Src^));
+ {$IFNDEF PS_NOINT64}
+ {$IFDEF DELPHI6UP} btS64: Dest := tbts64(Src^); {$ELSE} bts64: begin Result := False; exit; end; {$ENDIF}
+ {$ENDIF}
+ btChar: Dest := tbtString(tbtchar(src^));
+ {$IFNDEF PS_NOWIDESTRING}
+ btWideString: Dest := tbtWideString(src^);
+ btWideChar: Dest := tbtwidestring(tbtwidechar(src^));
+ btUnicodeString: Dest := tbtUnicodeString(src^);
+ {$ENDIF}
+ else
+ begin
+ Result := False;
+ exit;
+ end;
+ end;
+ Result := True;
+end;
+
+function PIFVariantToVariant(Src: PIFVariant; var Dest: Variant): Boolean;
+begin
+ Result := IntPIFVariantToVariant(@PPSVariantData(src).Data, Src.FType, Dest);
+end;
+
+function VariantToPIFVariant(Exec: TPSExec; const Src: Variant; Dest: PIFVariant): Boolean;
+var
+ TT: PIFTypeRec;
+begin
+ if Dest = nil then begin Result := false; exit; end;
+ tt := Exec.FindType2(btVariant);
+ if tt = nil then begin Result := false; exit; end;
+ if Dest.FType.BaseType = btPointer then
+ Result := Exec.SetVariantValue(PPSVariantPointer(Dest).DataDest, @Src, PPSVariantPointer(Dest).DestType, tt)
+ else
+ Result := Exec.SetVariantValue(@PPSVariantData(Dest).Data, @Src, Dest.FType, tt);
+end;
+
+type
+ POpenArray = ^TOpenArray;
+ TOpenArray = record
+ AType: Byte; {0}
+ OrgVar: PPSVariantIFC;
+ FreeIt: Boolean;
+ ElementSize,
+ ItemCount: Longint;
+ Data: Pointer;
+ VarParam: Boolean;
+ end;
+function CreateOpenArray(VarParam: Boolean; Sender: TPSExec; val: PPSVariantIFC): POpenArray;
+var
+ datap, p: Pointer;
+ ctype: TPSTypeRec;
+ cp: Pointer;
+ i: Longint;
+begin
+ if (Val.aType.BaseType <> btArray) and (val.aType.BaseType <> btStaticArray) then
+ begin
+ Result := nil;
+ exit;
+ end;
+ New(Result);
+ Result.AType := 0;
+ Result.OrgVar := Val;
+ Result.VarParam := VarParam;
+
+ if val.aType.BaseType = btStaticArray then
+ begin
+ Result^.ItemCount := TPSTypeRec_StaticArray(val.aType).Size;
+ datap := Val.Dta;
+ end else
+ begin
+ Result^.ItemCount := PSDynArrayGetLength(Pointer(Val.Dta^), val.aType);
+ datap := Pointer(Val.Dta^);
+ end;
+ if TPSTypeRec_Array(Val.aType).ArrayType.BaseType <> btPointer then
+ begin
+ Result.FreeIt := False;
+ result.ElementSize := 0;
+ Result.Data := datap;
+ exit;
+ end;
+ Result.FreeIt := True;
+ Result.ElementSize := sizeof(TVarRec);
+ GetMem(Result.Data, Result.ItemCount * Result.ElementSize);
+ P := Result.Data;
+ FillChar(p^, Result^.ItemCount * Result^.ElementSize, 0);
+ for i := 0 to Result^.ItemCount -1 do
+ begin
+ ctype := Pointer(Pointer(IPointer(datap)+PointerSize)^);
+ cp := Pointer(Datap^);
+ if cp = nil then
+ begin
+ tvarrec(p^).VType := vtPointer;
+ tvarrec(p^).VPointer := nil;
+ end else begin
+ case ctype.BaseType of
+ btVariant: begin
+ tvarrec(p^).VType := vtVariant;
+ tvarrec(p^).VVariant := cp;
+ end;
+ btchar: begin
+ tvarrec(p^).VType := vtChar;
+ tvarrec(p^).VChar := tbtChar(tbtchar(cp^));
+ end;
+ btSingle:
+ begin
+ tvarrec(p^).VType := vtExtended;
+ New(tvarrec(p^).VExtended);
+ tvarrec(p^).VExtended^ := tbtsingle(cp^);
+ end;
+ btExtended:
+ begin
+ tvarrec(p^).VType := vtExtended;
+ New(tvarrec(p^).VExtended);
+ tvarrec(p^).VExtended^ := tbtextended(cp^);;
+ end;
+ btDouble:
+ begin
+ tvarrec(p^).VType := vtExtended;
+ New(tvarrec(p^).VExtended);
+ tvarrec(p^).VExtended^ := tbtdouble(cp^);
+ end;
+ {$IFNDEF PS_NOWIDESTRING}
+ btwidechar: begin
+ tvarrec(p^).VType := vtWideChar;
+ tvarrec(p^).VWideChar := tbtwidechar(cp^);
+ end;
+ {$IFDEF DELPHI2009UP}
+ btUnicodeString: begin
+ tvarrec(p^).VType := vtUnicodeString;
+ tbtunicodestring(TVarRec(p^).VWideString) := tbtunicodestring(cp^);
+ end;
+ {$ELSE}
+ btUnicodeString,
+ {$ENDIF}
+ btwideString: begin
+ tvarrec(p^).VType := vtWideString;
+ tbtwidestring(TVarRec(p^).VWideString) := tbtwidestring(cp^);
+ end;
+ {$ENDIF}
+ btU8: begin
+ tvarrec(p^).VType := vtInteger;
+ tvarrec(p^).VInteger := tbtu8(cp^);
+ end;
+ btS8: begin
+ tvarrec(p^).VType := vtInteger;
+ tvarrec(p^).VInteger := tbts8(cp^);
+ end;
+ btU16: begin
+ tvarrec(p^).VType := vtInteger;
+ tvarrec(p^).VInteger := tbtu16(cp^);
+ end;
+ btS16: begin
+ tvarrec(p^).VType := vtInteger;
+ tvarrec(p^).VInteger := tbts16(cp^);
+ end;
+ btU32: begin
+ tvarrec(p^).VType := vtInteger;
+ tvarrec(p^).VInteger := tbtu32(cp^);
+ end;
+ btS32: begin
+ tvarrec(p^).VType := vtInteger;
+ tvarrec(p^).VInteger := tbts32(cp^);
+ end;
+ {$IFNDEF PS_NOINT64}
+ btS64: begin
+ tvarrec(p^).VType := vtInt64;
+ New(tvarrec(p^).VInt64);
+ tvarrec(p^).VInt64^ := tbts64(cp^);
+ end;
+ {$ENDIF}
+ btString: begin
+ tvarrec(p^).VType := vtAnsiString;
+ tbtString(TVarRec(p^).VAnsiString) := tbtstring(cp^);
+ end;
+ btPChar:
+ begin
+ tvarrec(p^).VType := vtPchar;
+ TVarRec(p^).VPChar := pointer(cp^);
+ end;
+ btClass:
+ begin
+ tvarrec(p^).VType := vtObject;
+ tvarrec(p^).VObject := Pointer(cp^);
+ end;
+{$IFNDEF PS_NOINTERFACES}
+{$IFDEF Delphi3UP}
+ btInterface:
+ begin
+ tvarrec(p^).VType := vtInterface;
+ IUnknown(tvarrec(p^).VInterface) := IUnknown(cp^);
+ end;
+
+{$ENDIF}
+{$ENDIF}
+ end;
+ end;
+ datap := Pointer(IPointer(datap)+ (2*sizeof(Pointer)+sizeof(Longbool)));
+ p := PansiChar(p) + Result^.ElementSize;
+ end;
+end;
+
+procedure DestroyOpenArray(Sender: TPSExec; V: POpenArray);
+var
+ cp, datap: pointer;
+ ctype: TPSTypeRec;
+ p: PVarRec;
+ i: Longint;
+begin
+ if v.FreeIt then // basetype = btPointer
+ begin
+ p := v^.Data;
+ if v.OrgVar.aType.BaseType = btStaticArray then
+ datap := v.OrgVar.Dta
+ else
+ datap := Pointer(v.OrgVar.Dta^);
+ for i := 0 to v^.ItemCount -1 do
+ begin
+ ctype := Pointer(Pointer(IPointer(datap)+PointerSize)^);
+ cp := Pointer(Datap^);
+ case ctype.BaseType of
+ btU8:
+ begin
+ if v^.varParam then
+ tbtu8(cp^) := tvarrec(p^).VInteger
+ end;
+ btS8: begin
+ if v^.varParam then
+ tbts8(cp^) := tvarrec(p^).VInteger
+ end;
+ btU16: begin
+ if v^.varParam then
+ tbtu16(cp^) := tvarrec(p^).VInteger
+ end;
+ btS16: begin
+ if v^.varParam then
+ tbts16(cp^) := tvarrec(p^).VInteger
+ end;
+ btU32: begin
+ if v^.varParam then
+ tbtu32(cp^) := tvarrec(p^).VInteger
+ end;
+ btS32: begin
+ if v^.varParam then
+ tbts32(cp^) := tvarrec(p^).VInteger
+ end;
+ btChar: begin
+ if v^.VarParam then
+ tbtchar(cp^) := tbtChar(tvarrec(p^).VChar)
+ end;
+ btSingle: begin
+ if v^.VarParam then
+ tbtsingle(cp^) := tvarrec(p^).vextended^;
+ dispose(tvarrec(p^).vextended);
+ end;
+ btDouble: begin
+ if v^.VarParam then
+ tbtdouble(cp^) := tvarrec(p^).vextended^;
+ dispose(tvarrec(p^).vextended);
+ end;
+ btExtended: begin
+ if v^.VarParam then
+ tbtextended(cp^) := tvarrec(p^).vextended^;
+ dispose(tvarrec(p^).vextended);
+ end;
+ {$IFNDEF PS_NOINT64}
+ btS64: begin
+ if v^.VarParam then
+ tbts64(cp^) := tvarrec(p^).vInt64^;
+ dispose(tvarrec(p^).VInt64);
+ end;
+ {$ENDIF}
+ {$IFNDEF PS_NOWIDESTRING}
+ btWideChar: begin
+ if v^.varParam then
+ tbtwidechar(cp^) := tvarrec(p^).VWideChar;
+ end;
+ {$IFDEF DELPHI2009UP}
+ btUnicodeString:
+ begin
+ if v^.VarParam then
+ tbtunicodestring(cp^) := tbtunicodestring(TVarRec(p^).VUnicodeString);
+ finalize(tbtunicodestring(TVarRec(p^).VUnicodeString));
+ end;
+ {$ELSE}
+ btUnicodeString,
+ {$ENDIF}
+ btWideString:
+ begin
+ if v^.VarParam then
+ tbtwidestring(cp^) := tbtwidestring(TVarRec(p^).VWideString);
+ finalize(widestring(TVarRec(p^).VWideString));
+ end;
+ {$ENDIF}
+ btString: begin
+ if v^.VarParam then
+ tbtstring(cp^) := tbtstring(TVarRec(p^).VString);
+ finalize(tbtString(TVarRec(p^).VAnsiString));
+ end;
+ btClass: begin
+ if v^.VarParam then
+ Pointer(cp^) := TVarRec(p^).VObject;
+ end;
+{$IFNDEF PS_NOINTERFACES}
+{$IFDEF Delphi3UP}
+ btInterface: begin
+ if v^.VarParam then
+ IUnknown(cp^) := IUnknown(TVarRec(p^).VInterface);
+ finalize(tbtString(TVarRec(p^).VAnsiString));
+ end;
+{$ENDIF}
+{$ENDIF}
+ end;
+ datap := Pointer(IPointer(datap)+ (2*sizeof(Pointer)+sizeof(LongBool)));
+ p := Pointer(IPointer(p) + Cardinal(v^.ElementSize));
+ end;
+ FreeMem(v.Data, v.ElementSize * v.ItemCount);
+ end;
+ Dispose(V);
+end;
+
+
+{$ifndef FPC}
+ {$include x86.inc}
+{$else}
+{$IFDEF Delphi6UP}
+ {$if defined(cpu86)}
+ {$include x86.inc}
+ {$elseif defined(cpupowerpc)}
+ {$include powerpc.inc}
+ {$elseif defined(cpuarm)}
+ {$include arm.inc}
+ {$elseif defined(CPUX86_64)}
+ {$include x64.inc}
+ {$else}
+ {$fatal Pascal Script is not supported for your architecture at the moment!}
+ {$ifend}
+{$ELSE}
+{$include x86.inc}
+{$ENDIF}
+{$endif}
+
+type
+ PScriptMethodInfo = ^TScriptMethodInfo;
+ TScriptMethodInfo = record
+ Se: TPSExec;
+ ProcNo: Cardinal;
+ end;
+
+
+function MkMethod(FSE: TPSExec; No: Cardinal): TMethod;
+begin
+ if (no = 0) or (no = InvalidVal) then
+ begin
+ Result.Code := nil;
+ Result.Data := nil;
+ end else begin
+ Result.Code := @MyAllMethodsHandler;
+ Result.Data := GetMethodInfoRec(FSE, No);
+ end;
+end;
+
+
+procedure PFree(Sender: TPSExec; P: PScriptMethodInfo);
+begin
+ Dispose(p);
+end;
+
+function GetMethodInfoRec(SE: TPSExec; ProcNo: Cardinal): Pointer;
+var
+ I: Longint;
+ pp: PScriptMethodInfo;
+begin
+ if (ProcNo = 0) or (ProcNo = InvalidVal) then
+ begin
+ Result := nil;
+ exit;
+ end;
+ I := 2147483647;
+ repeat
+ pp := Se.FindProcResource2(@PFree, I);
+ if (i <> -1) and (pp^.ProcNo = ProcNo) then
+ begin
+ Result := Pp;
+ exit;
+ end;
+ until i = -1;
+ New(pp);
+ pp^.Se := TPSExec(Se);
+ pp^.ProcNo := Procno;
+ Se.AddResource(@PFree, pp);
+ Result := pp;
+end;
+
+
+
+
+
+type
+ TPtrArr = array[0..1000] of Pointer;
+ PPtrArr = ^TPtrArr;
+ TByteArr = array[0..1000] of byte;
+ PByteArr = ^TByteArr;
+ PPointer = ^Pointer;
+
+
+function VirtualMethodPtrToPtr(Ptr, FSelf: Pointer): Pointer;
+{$IFDEF FPC}
+var
+ x : PPtrArr;
+{$ENDIF}
+begin
+ {$IFDEF FPC}
+ x := Pointer(TObject(FSelf).ClassType) + vmtMethodStart;
+ Result := x^[Longint(Ptr)];
+ {$ELSE}
+ Result := PPtrArr(PPointer(FSelf)^)^[Longint(Ptr)];
+ {$ENDIF}
+end;
+
+function VirtualClassMethodPtrToPtr(Ptr, FSelf: Pointer): Pointer;
+{$IFDEF FPC}
+var
+ x : PPtrArr;
+{$ENDIF}
+begin
+ {$IFDEF FPC}
+ x := Pointer(FSelf) + vmtMethodStart;
+ Result := x^[Longint(Ptr)];
+ {$ELSE}
+ Result := PPtrArr(FSelf)^[Longint(Ptr)];
+ {$ENDIF}
+end;
+
+
+procedure CheckPackagePtr(var P: PByteArr);
+begin
+ if (word((@p[0])^) = $25FF) and (word((@p[6])^)=$C08B)then
+ begin
+ p := PPointer((@p[2])^)^;
+ end;
+end;
+
+{$IFDEF VER90}{$DEFINE NO_vmtSelfPtr}{$ENDIF}
+{$IFDEF FPC}{$DEFINE NO_vmtSelfPtr}{$ENDIF}
+
+{$IFNDEF FPC}
+
+function FindVirtualMethodPtr(Ret: TPSRuntimeClass; FClass: TClass; Ptr: Pointer): Pointer;
+// Idea of getting the number of VMT items from GExperts
+var
+ p: PPtrArr;
+ I: Longint;
+begin
+ p := Pointer(FClass);
+ CheckPackagePtr(PByteArr(Ptr));
+ if Ret.FEndOfVMT = MaxInt then
+ begin
+ I := {$IFDEF NO_vmtSelfPtr}-48{$ELSE}vmtSelfPtr{$ENDIF} div SizeOf(Pointer) + 1;
+ while I < 0 do
+ begin
+ if I < 0 then
+ begin
+ if I <> ({$IFDEF VER90}-44{$ELSE}vmtTypeInfo{$ENDIF} div SizeOf(Pointer)) then
+ begin // from GExperts code
+ if (IPointer(p^[I]) > IPointer(p)) and ((IPointer(p^[I]) - IPointer(p))
+ div
+ PointerSize < Ret.FEndOfVMT) then
+ begin
+ Ret.FEndOfVMT := (IPointer(p^[I]) - IPointer(p)) div SizeOf(Pointer);
+ end;
+ end;
+ end;
+ Inc(I);
+ end;
+ if Ret.FEndOfVMT = MaxInt then
+ begin
+ Ret.FEndOfVMT := 0; // cound not find EndOfVMT
+ Result := nil;
+ exit;
+ end;
+ end;
+ I := 0;
+ while I < Ret.FEndOfVMT do
+ begin
+ if p^[I] = Ptr then
+ begin
+ Result := Pointer(I);
+ exit;
+ end;
+ I := I + 1;
+ end;
+ Result := nil;
+end;
+
+{$ELSE}
+
+function FindVirtualMethodPtr(Ret: TPSRuntimeClass; FClass: TClass; Ptr: Pointer): Pointer;
+var
+ x,p: PPtrArr;
+ I: Longint;
+ t : Pointer;
+begin
+ p := Pointer(FClass) + vmtMethodStart;
+ I := 0;
+ while (p^[I]<>nil) and (I < 10000) do
+ begin
+ if p^[I] = Ptr then
+ begin
+ Result := Pointer(I);
+ x := Pointer(FClass) + vmtMethodStart;
+ t := x^[I];
+ Assert(t=Ptr,'Computation of virtual method pointer fail : t<>Ptr');
+ exit;
+ end;
+ I := I + 1;
+ end;
+ Result := nil;
+end;
+
+{$ENDIF}
+
+
+function NewTPSVariantIFC(avar: PPSVariant; varparam: boolean): TPSVariantIFC;
+begin
+ Result.VarParam := varparam;
+ if avar = nil then
+ begin
+ Result.aType := nil;
+ result.Dta := nil;
+ end else
+ begin
+ Result.aType := avar.FType;
+ result.Dta := @PPSVariantData(avar).Data;
+ if Result.aType.BaseType = btPointer then
+ begin
+ Result.aType := Pointer(Pointer(IPointer(result.dta)+ PointerSize)^);
+ Result.Dta := Pointer(Result.dta^);
+ end;
+ end;
+end;
+
+function NewTPSVariantRecordIFC(avar: PPSVariant; Fieldno: Longint): TPSVariantIFC;
+var
+ offs: Cardinal;
+begin
+ Result := NewTPSVariantIFC(avar, false);
+ if Result.aType.BaseType = btRecord then
+ begin
+ Offs := Cardinal(TPSTypeRec_Record(Result.aType).RealFieldOffsets[FieldNo]);
+ Result.Dta := Pointer(IPointer(Result.dta) + Offs);
+ Result.aType := TPSTypeRec_Record(Result.aType).FieldTypes[FieldNo];
+ end else
+ begin
+ Result.Dta := nil;
+ Result.aType := nil;
+ end;
+end;
+
+function PSGetArrayField(const avar: TPSVariantIFC; Fieldno: Longint): TPSVariantIFC;
+var
+ offs: Cardinal;
+ n: Longint;
+begin
+ Result := aVar;
+ case Result.aType.BaseType of
+ btStaticArray, btArray:
+ begin
+ if Result.aType.BaseType = btStaticArray then
+ n := TPSTypeRec_StaticArray(Result.aType).Size
+ else
+ n := PSDynArrayGetLength(Pointer(Result.Dta^), Result.aType);
+ if (FieldNo <0) or (FieldNo >= n) then
+ begin
+ Result.Dta := nil;
+ Result.aType := nil;
+ exit;
+ end;
+ Offs := TPSTypeRec_Array(Result.aType).ArrayType.RealSize * Cardinal(FieldNo);
+ if Result.aType.BaseType = btStaticArray then
+ Result.Dta := Pointer(IPointer(Result.dta) + Offs)
+ else
+ Result.Dta := Pointer(IPointer(Result.dta^) + Offs);
+ Result.aType := TPSTypeRec_Array(Result.aType).ArrayType;
+ end
+ else
+ Result.Dta := nil;
+ Result.aType := nil;
+ end;
+end;
+
+function PSGetRecField(const avar: TPSVariantIFC; Fieldno: Longint): TPSVariantIFC;
+var
+ offs: Cardinal;
+begin
+ Result := aVar;
+ if Result.aType.BaseType = btRecord then
+ begin
+ Offs := Cardinal(TPSTypeRec_Record(Result.aType).RealFieldOffsets[FieldNo]);
+ Result.aType := TPSTypeRec_Record(Result.aType).FieldTypes[FieldNo];
+ Result.Dta := Pointer(IPointer(Result.dta) + Offs);
+ end else
+ begin
+ Result.Dta := nil;
+ Result.aType := nil;
+ end;
+end;
+
+function NewPPSVariantIFC(avar: PPSVariant; varparam: boolean): PPSVariantIFC;
+begin
+ New(Result);
+ Result^ := NewTPSVariantIFC(avar, varparam);
+end;
+
+
+procedure DisposePPSVariantIFC(aVar: PPSVariantIFC);
+begin
+ if avar <> nil then
+ Dispose(avar);
+end;
+
+procedure DisposePPSVariantIFCList(list: TPSList);
+var
+ i: Longint;
+begin
+ for i := list.Count -1 downto 0 do
+ DisposePPSVariantIFC(list[i]);
+ list.free;
+end;
+
+function ClassCallProcMethod(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
+var
+ i: Integer;
+ MyList: TPSList;
+ n: PIFVariant;
+ v: PPSVariantIFC;
+ FSelf: Pointer;
+ CurrStack: Cardinal;
+ cc: TPSCallingConvention;
+ s: tbtString;
+begin
+ s := p.Decl;
+ if length(S) < 2 then
+ begin
+ Result := False;
+ exit;
+ end;
+ cc := TPSCallingConvention(s[1]);
+ Delete(s, 1, 1);
+ if s[1] = #0 then
+ n := Stack[Stack.Count -1]
+ else
+ n := Stack[Stack.Count -2];
+ if (n = nil) or (n^.FType.BaseType <> btClass)or (PPSVariantClass(n).Data = nil) then
+ begin
+ Caller.CMD_Err(erNullPointerException);
+ result := false;
+ exit;
+ end;
+ FSelf := PPSVariantClass(n).Data;
+ CurrStack := Cardinal(Stack.Count) - Cardinal(length(s)) -1;
+ if s[1] = #0 then inc(CurrStack);
+ MyList := TPSList.Create;
+ for i := 2 to length(s) do
+ begin
+ MyList.Add(nil);
+ end;
+ for i := length(s) downto 2 do
+ begin
+ n := Stack[CurrStack];
+ MyList[i - 2] := NewPPSVariantIFC(n, s[i] <> #0);
+ inc(CurrStack);
+ end;
+ if s[1] <> #0 then
+ begin
+ v := NewPPSVariantIFC(Stack[CurrStack + 1], True);
+ end else v := nil;
+ try
+ if p.Ext2 = nil then
+ Result := Caller.InnerfuseCall(FSelf, p.Ext1, cc, MyList, v)
+ else
+ Result := Caller.InnerfuseCall(FSelf, VirtualMethodPtrToPtr(p.Ext1, FSelf), cc, MyList, v);
+ finally
+ DisposePPSVariantIFC(v);
+ DisposePPSVariantIFCList(mylist);
+ end;
+end;
+
+function ClassCallProcConstructor(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
+var
+ i, h: Longint;
+ v: PPSVariantIFC;
+ MyList: TPSList;
+ n: PIFVariant;
+ FSelf: Pointer;
+ CurrStack: Cardinal;
+ cc: TPSCallingConvention;
+ s: tbtString;
+ FType: PIFTypeRec;
+ x: TPSRuntimeClass;
+ IntVal: PIFVariant;
+begin
+ n := Stack[Stack.Count -2];
+ if (n = nil) or (n^.FType.BaseType <> btU32) then
+ begin
+ result := false;
+ exit;
+ end;
+ FType := Caller.GetTypeNo(PPSVariantU32(N).Data);
+ if (FType = nil) then
+ begin
+ Result := False;
+ exit;
+ end;
+ h := MakeHash(FType.ExportName);
+ FSelf := nil;
+ for i := 0 to TPSRuntimeClassImporter(p.Ext2).FClasses.Count -1 do
+ begin
+ x:= TPSRuntimeClassImporter(p.Ext2).FClasses[i];
+ if (x.FClassNameHash = h) and (x.FClassName = FType.ExportName) then
+ begin
+ FSelf := x.FClass;
+ end;
+ end;
+ if FSelf = nil then begin
+ Result := False;
+ exit;
+ end;
+ s := p.Decl;
+ if length(S) < 2 then
+ begin
+ Result := False;
+ exit;
+ end;
+ cc := TPSCallingConvention(s[1]);
+ Delete(s, 1, 1);
+ CurrStack := Cardinal(Stack.Count) - Cardinal(length(s)) -1;
+ if s[1] = #0 then inc(CurrStack);
+ IntVal := CreateHeapVariant(Caller.FindType2(btU32));
+ if IntVal = nil then
+ begin
+ Result := False;
+ exit;
+ end;
+ {$IFDEF FPC}
+ // under FPC a constructor it's called with self=0 (EAX) and
+ // the VMT class pointer in EDX so they are effectively swaped
+ // using register calling convention
+ PPSVariantU32(IntVal).Data := Cardinal(FSelf);
+ FSelf := pointer(1);
+ {$ELSE}
+ PPSVariantU32(IntVal).Data := 1;
+ {$ENDIF}
+ MyList := TPSList.Create;
+ MyList.Add(NewPPSVariantIFC(intval, false));
+ for i := 2 to length(s) do
+ begin
+ MyList.Add(nil);
+ end;
+ for i := length(s) downto 2 do
+ begin
+ n :=Stack[CurrStack];
+// if s[i] <> #0 then
+// begin
+// MyList[i - 2] := NewPPSVariantIFC(n, s[i] <> #0);
+// end;
+ MyList[i - 1] := NewPPSVariantIFC(n, s[i] <> #0);
+ inc(CurrStack);
+ end;
+ if s[1] <> #0 then
+ begin
+ v := NewPPSVariantIFC(Stack[CurrStack + 1], True);
+ end else v := nil;
+ try
+ Result := Caller.InnerfuseCall(FSelf, p.Ext1, TPSCallingConvention(Integer(cc) or 64), MyList, v);
+ finally
+ DisposePPSVariantIFC(v);
+ DisposePPSVariantIFCList(mylist);
+ DestroyHeapVariant(intval);
+ end;
+end;
+
+
+function ClassCallProcVirtualConstructor(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
+var
+ i, h: Longint;
+ v: PPSVariantIFC;
+ MyList: TPSList;
+ n: PIFVariant;
+ FSelf: Pointer;
+ CurrStack: Cardinal;
+ cc: TPSCallingConvention;
+ s: tbtString;
+ FType: PIFTypeRec;
+ x: TPSRuntimeClass;
+ IntVal: PIFVariant;
+begin
+ n := Stack[Stack.Count -2];
+ if (n = nil) or (n^.FType.BaseType <> btU32) then
+ begin
+ Caller.CMD_Err(erNullPointerException);
+ result := false;
+ exit;
+ end;
+ FType := Caller.GetTypeNo(PPSVariantU32(N).Data);
+ if (FType = nil) then
+ begin
+ Caller.CMD_Err(erNullPointerException);
+ Result := False;
+ exit;
+ end;
+ h := MakeHash(FType.ExportName);
+ FSelf := nil;
+ for i := 0 to TPSRuntimeClassImporter(p.Ext2).FClasses.Count -1 do
+ begin
+ x:= TPSRuntimeClassImporter(p.Ext2).FClasses[i];
+ if (x.FClassNameHash = h) and (x.FClassName = FType.ExportName) then
+ begin
+ FSelf := x.FClass;
+ end;
+ end;
+ if FSelf = nil then begin
+ Result := False;
+ exit;
+ end;
+ s := p.Decl;
+ if length(S) < 2 then
+ begin
+ Result := False;
+ exit;
+ end;
+ cc := TPSCallingConvention(s[1]);
+ delete(s, 1, 1);
+ CurrStack := Cardinal(Stack.Count) - Cardinal(length(s)) -1;
+ if s[1] = #0 then inc(CurrStack);
+ IntVal := CreateHeapVariant(Caller.FindType2(btU32));
+ if IntVal = nil then
+ begin
+ Result := False;
+ exit;
+ end;
+ PPSVariantU32(IntVal).Data := 1;
+ MyList := TPSList.Create;
+ MyList.Add(NewPPSVariantIFC(intval, false));
+ for i := 2 to length(s) do
+ begin
+ MyList.Add(nil);
+ end;
+ for i := length(s) downto 2 do
+ begin
+ n :=Stack[CurrStack];
+ MyList[i - 1] := NewPPSVariantIFC(n, s[i] <> #0);
+ inc(CurrStack);
+ end;
+ if s[1] <> #0 then
+ begin
+ v := NewPPSVariantIFC(Stack[CurrStack + 1], True);
+ end else v := nil;
+ try
+ Result := Caller.InnerfuseCall(FSelf, VirtualClassMethodPtrToPtr(p.Ext1, FSelf), cc, MyList, v);
+ finally
+ DisposePPSVariantIFC(v);
+ DisposePPSVariantIFCList(mylist);
+ DestroyHeapVariant(intval);
+ end;
+end;
+
+function CastProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
+var
+ TypeNo, InVar, ResVar: TPSVariantIFC;
+ FSelf: TClass;
+ FType: PIFTypeRec;
+ H, I: Longint;
+ x: TPSRuntimeClass;
+begin
+ TypeNo := NewTPSVariantIFC(Stack[Stack.Count-3], false);
+ InVar := NewTPSVariantIFC(Stack[Stack.Count-2], false);
+ ResVar := NewTPSVariantIFC(Stack[Stack.Count-1], true);
+ if (TypeNo.Dta = nil) or (InVar.Dta = nil) or (ResVar.Dta = nil) or
+ (TypeNo.aType.BaseType <> btu32) or (resvar.aType <> Caller.FTypes[tbtu32(Typeno.dta^)])
+ then
+ begin
+ Result := False;
+ Exit;
+ end;
+{$IFNDEF PS_NOINTERFACES}
+ if (invar.atype.BaseType = btInterface) and (resvar.aType.BaseType = btInterface) then
+ begin
+{$IFNDEF Delphi3UP}
+ if IUnknown(resvar.Dta^) <> nil then
+ IUnknown(resvar.Dta^).Release;
+{$ENDIF}
+ IUnknown(resvar.Dta^) := nil;
+ if (IUnknown(invar.Dta^) = nil) or (IUnknown(invar.Dta^).QueryInterface(TPSTypeRec_Interface(ResVar.aType).Guid, IUnknown(resvar.Dta^)) <> 0) then
+ begin
+ Caller.CMD_Err2(erCustomError, tbtString(RPS_CannotCastInterface));
+ Result := False;
+ exit;
+ end;
+{$IFDEF Delphi3UP}
+ end else if (Invar.aType.BaseType = btclass) and (resvar.aType.BaseType = btInterface) then
+ begin
+{$IFNDEF Delphi3UP}
+ if IUnknown(resvar.Dta^) <> nil then
+ IUnknown(resvar.Dta^).Release;
+{$ENDIF}
+ IUnknown(resvar.Dta^) := nil;
+ if (TObject(invar.Dta^)= nil) or (not TObject(invar.dta^).GetInterface(TPSTypeRec_Interface(ResVar.aType).Guid, IUnknown(resvar.Dta^))) then
+ begin
+ Caller.CMD_Err2(erCustomError, tbtString(RPS_CannotCastInterface));
+ Result := False;
+ exit;
+ end;
+{$ENDIF}
+ end else {$ENDIF}if (invar.aType.BaseType = btclass) and (resvar.aType.BaseType = btclass ) then
+ begin
+ FType := Caller.GetTypeNo(tbtu32(TypeNo.Dta^));
+ if (FType = nil) then
+ begin
+ Result := False;
+ exit;
+ end;
+ h := MakeHash(FType.ExportName);
+ FSelf := nil;
+ for i := 0 to TPSRuntimeClassImporter(p.Ext2).FClasses.Count -1 do
+ begin
+ x:= TPSRuntimeClassImporter(p.Ext2).FClasses[i];
+ if (x.FClassNameHash = h) and (x.FClassName = FType.ExportName) then
+ begin
+ FSelf := x.FClass;
+ end;
+ end;
+ if FSelf = nil then begin
+ Result := False;
+ exit;
+ end;
+
+ try
+ TObject(ResVar.Dta^) := TObject(InVar.Dta^) as FSelf;
+ except
+ Result := False;
+ Caller.CMD_Err2(erCustomError, tbtString(RPS_CannotCastObject));
+ exit;
+ end;
+ end else
+ begin
+ Result := False;
+ exit;
+ end;
+ result := True;
+end;
+
+
+function NilProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
+var
+ n: TPSVariantIFC;
+begin
+ n := NewTPSVariantIFC(Stack[Stack.Count-1], True);
+ if (n.Dta = nil) or ((n.aType.BaseType <> btClass) and (n.aType.BaseType <> btInterface)) then
+ begin
+ Result := False;
+ Caller.CMD_Err(erNullPointerException);
+ Exit;
+ end;
+{$IFNDEF PS_NOINTERFACES}
+ if n.aType.BaseType = btInterface then
+ begin
+ {$IFNDEF Delphi3UP}
+ if IUnknown(n.Dta^) <> nil then
+ IUnknown(n.Dta^).Release;
+ {$ENDIF}
+ IUnknown(n.Dta^) := nil;
+ end else
+ {$ENDIF}
+ Pointer(n.Dta^) := nil;
+ result := True;
+end;
+function IntfCallProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
+var
+ i: Integer;
+ MyList: TPSList;
+ n: TPSVariantIFC;
+ n2: PPSVariantIFC;
+ FSelf: Pointer;
+ CurrStack: Cardinal;
+ cc: TPSCallingConvention;
+ s: tbtString;
+begin
+ s := p.Decl;
+ if length(S) < 2 then
+ begin
+ Result := False;
+ exit;
+ end;
+ cc := TPSCallingConvention(s[1]);
+ Delete(s, 1, 1);
+ if s[1] = #0 then
+ n := NewTPSVariantIFC(Stack[Stack.Count -1], false)
+ else
+ n := NewTPSVariantIFC(Stack[Stack.Count -2], false);
+ if (n.dta = nil) or (n.atype.BaseType <> btInterface) or (Pointer(n.Dta^) = nil) then
+ begin
+ Caller.CMD_Err(erNullPointerException);
+ result := false;
+ exit;
+ end;
+ FSelf := Pointer(n.dta^);
+ CurrStack := Cardinal(Stack.Count) - Cardinal(length(s)) -1;
+ if s[1] = #0 then inc(CurrStack);
+ MyList := TPSList.Create;
+ for i := 2 to length(s) do
+ begin
+ MyList.Add(nil);
+ end;
+ for i := length(s) downto 2 do
+ begin
+ MyList[i - 2] := NewPPSVariantIFC(Stack[CurrStack], s[i] <> #0);
+ inc(CurrStack);
+ end;
+ if s[1] <> #0 then
+ begin
+ n2 := NewPPSVariantIFC(Stack[CurrStack + 1], True);
+ end else n2 := nil;
+ try
+ Caller.InnerfuseCall(FSelf, Pointer(Pointer(IPointer(FSelf^) + (Cardinal(p.Ext1) * Sizeof(Pointer)))^), cc, MyList, n2);
+ result := true;
+ finally
+ DisposePPSVariantIFC(n2);
+ DisposePPSVariantIFCList(MyList);
+ end;
+end;
+
+
+function InterfaceProc(Sender: TPSExec; p: TPSExternalProcRec; Tag: Pointer): Boolean;
+var
+ s: tbtString;
+begin
+ s := p.Decl;
+ delete(s,1,5); // delete 'intf:'
+ if s = '' then
+ begin
+ Result := False;
+ exit;
+ end;
+ if s[1] = '.'then
+ begin
+ Delete(s,1,1);
+ if length(S) < 6 then
+ begin
+ Result := False;
+ exit;
+ end;
+ p.ProcPtr := IntfCallProc;
+ p.Ext1 := Pointer((@s[1])^); // Proc Offset
+ Delete(s,1,4);
+ P.Decl := s;
+ Result := True;
+ end else Result := False;
+end;
+
+
+function getMethodNo(P: TMethod; SE: TPSExec): Cardinal;
+begin
+ if (p.Code <> @MyAllMethodsHandler) or (p.Data = nil)or (PScriptMethodInfo(p.Data)^.Se <> se) then
+ Result := 0
+ else
+ begin
+ Result := PScriptMethodInfo(p.Data)^.ProcNo;
+ end;
+end;
+
+function ClassCallProcProperty(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
+var
+ n: TPSVariantIFC;
+ ltemp: Longint;
+ FSelf: Pointer;
+ m: TMethod;
+begin
+ try
+ if p.Ext2 = Pointer(0) then
+ begin
+ n := NewTPSVariantIFC(Stack[Stack.Count -1], False);
+ if (n.Dta = nil) or (n.aType.BaseType <> btclass) then
+ begin
+ result := false;
+ Caller.CMD_Err(erNullPointerException);
+ exit;
+ end;
+ FSelf := Pointer(n.dta^);
+ if FSelf = nil then
+ begin
+ Caller.CMD_Err(erCouldNotCallProc);
+ Result := False;
+ exit;
+ end;
+ n := NewTPSVariantIFC(Stack[Stack.Count -2], false);
+ if (PPropInfo(p.Ext1)^.PropType^.Kind = tkMethod) and ((n.aType.BaseType = btu32) or (n.aType.BaseType = btProcPtr))then
+ begin
+ SetMethodProp(TObject(FSelf), PPropInfo(p.Ext1), MkMethod(Caller, tbtu32(n.dta^)));
+ end else
+ case n.aType.BaseType of
+ btSet:
+ begin
+ ltemp := 0;
+ move(Byte(n.Dta^), ltemp, TPSTypeRec_Set(n.aType).aByteSize);
+ SetOrdProp(TObject(FSelf), PPropInfo(p.Ext1), ltemp);
+ end;
+ btChar, btU8: SetOrdProp(TObject(FSelf), PPropInfo(p.Ext1), tbtu8(n.Dta^));
+ btS8: SetOrdProp(TObject(FSelf), PPropInfo(p.Ext1), tbts8(n.Dta^));
+ {$IFNDEF PS_NOWIDESTRING}btwidechar, {$ENDIF}btU16: SetOrdProp(TObject(FSelf), PPropInfo(p.Ext1), tbtu16(n.Dta^));
+ btS16: SetOrdProp(TObject(FSelf), PPropInfo(p.Ext1), tbts16(n.Dta^));
+ btU32: SetOrdProp(TObject(FSelf), PPropInfo(p.Ext1), tbtu32(n.Dta^));
+ btS32: SetOrdProp(TObject(FSelf), PPropInfo(p.Ext1), tbts32(n.Dta^));
+ btSingle: SetFloatProp(TObject(FSelf), p.Ext1, tbtsingle(n.Dta^));
+ btDouble: SetFloatProp(TObject(FSelf), p.Ext1, tbtdouble(n.Dta^));
+ btExtended: SetFloatProp(TObject(FSelf), p.Ext1, tbtextended(n.Dta^));
+ btString: SetStrProp(TObject(FSelf), p.Ext1, string(tbtString(n.Dta^)));
+ btPChar: SetStrProp(TObject(FSelf), p.Ext1, string(pansichar(n.Dta^)));
+ btClass: SetOrdProp(TObject(FSelf), P.Ext1, Longint(n.Dta^));
+ {$IFDEF DELPHI6UP}
+{$IFNDEF PS_NOWIDESTRING}
+{$IFNDEF DELPHI2009UP}btUnicodeString,{$ENDIF}
+ btWideString: SetWideStrProp(TObject(FSelf), P.Ext1, tbtWidestring(n.dta^));
+{$IFDEF DELPHI2009UP}
+ btUnicodeString: SetUnicodeStrProp(TObject(FSelf), P.Ext1, tbtUnicodestring(n.dta^));
+{$ENDIF}
+ {$ENDIF}
+{$ENDIF}
+ else
+ begin
+ Result := False;
+ exit;
+ end;
+ end;
+ Result := true;
+ end else begin
+ n := NewTPSVariantIFC(Stack[Stack.Count -2], False);
+ if (n.dta = nil) or (n.aType.BaseType <> btClass)then
+ begin
+ result := false;
+ Caller.CMD_Err(erNullPointerException);
+ exit;
+ end;
+ FSelf := Pointer(n.dta^);
+ if FSelf = nil then
+ begin
+ Caller.CMD_Err(erCouldNotCallProc);
+ Result := False;
+ exit;
+ end;
+ n := NewTPSVariantIFC(Stack[Stack.Count -1], false);
+ if (PPropInfo(p.Ext1)^.PropType^.Kind = tkMethod) and ((n.aType.BaseType = btu32) or (n.aType.BaseType = btprocptr)) then
+ begin
+ m := GetMethodProp(TObject(FSelf), PPropInfo(p.Ext1));
+ Cardinal(n.Dta^) := GetMethodNo(m, Caller);
+ if Cardinal(n.dta^) = 0 then
+ begin
+ Pointer(Pointer((IPointer(n.dta)+PointerSize))^) := m.Data;
+ Pointer(Pointer((IPointer(n.dta)+PointerSize2))^) := m.Code;
+ end;
+ end else
+ case n.aType.BaseType of
+ btSet:
+ begin
+ ltemp := GetOrdProp(TObject(FSelf), PPropInfo(p.Ext1));
+ move(ltemp, Byte(n.Dta^), TPSTypeRec_Set(n.aType).aByteSize);
+ end;
+ btU8: tbtu8(n.Dta^) := GetOrdProp(TObject(FSelf), p.Ext1);
+ btS8: tbts8(n.Dta^) := GetOrdProp(TObject(FSelf), p.Ext1);
+ btU16: tbtu16(n.Dta^) := GetOrdProp(TObject(FSelf), p.Ext1);
+ btS16: tbts16(n.Dta^) := GetOrdProp(TObject(FSelf), p.Ext1);
+ btU32: tbtu32(n.Dta^) := GetOrdProp(TObject(FSelf), p.Ext1);
+ btS32: tbts32(n.Dta^) := GetOrdProp(TObject(FSelf), p.Ext1);
+ btSingle: tbtsingle(n.Dta^) := GetFloatProp(TObject(FSelf), p.Ext1);
+ btDouble: tbtdouble(n.Dta^) := GetFloatProp(TObject(FSelf), p.Ext1);
+ btExtended: tbtextended(n.Dta^) := GetFloatProp(TObject(FSelf), p.Ext1);
+ btString: tbtString(n.Dta^) := tbtString(GetStrProp(TObject(FSelf), p.Ext1));
+ btClass: Longint(n.dta^) := GetOrdProp(TObject(FSelf), p.Ext1);
+ {$IFDEF DELPHI6UP}
+{$IFNDEF PS_NOWIDESTRING}
+ {$IFDEF DELPHI2009UP}
+ btUnicodeString: tbtUnicodeString(n.dta^) := GetUnicodeStrProp(TObject(FSelf), P.Ext1);
+ {$ELSE}
+ btUnicodeString,
+ {$ENDIF}
+ btWideString: tbtWidestring(n.dta^) := GetWideStrProp(TObject(FSelf), P.Ext1);
+{$ENDIF}
+{$ENDIF}
+ else
+ begin
+ Result := False;
+ exit;
+ end;
+ end;
+ Result := True;
+ end;
+ finally
+ end;
+end;
+
+function ClassCallProcPropertyHelper(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
+var
+ I, ParamCount: Longint;
+ Params: TPSList;
+ n: TPSVariantIFC;
+ FSelf: Pointer;
+begin
+ if Length(P.Decl) < 4 then begin
+ Result := False;
+ exit;
+ end;
+ ParamCount := Longint((@P.Decl[1])^);
+ if Longint(Stack.Count) < ParamCount +1 then begin
+ Result := False;
+ exit;
+ end;
+ Dec(ParamCount);
+ if p.Ext1 <> nil then // read
+ begin
+ n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 2], False);
+ if (n.Dta = nil) or (n.aType.BaseType <> btClass) then
+ begin
+ result := false;
+ Caller.CMD_Err(erNullPointerException);
+ exit;
+ end;
+ FSelf := pointer(n.Dta^);
+ if FSelf = nil then
+ begin
+ Caller.CMD_Err(erCouldNotCallProc);
+ Result := False;
+ exit;
+ end;
+ Params := TPSList.Create;
+ Params.Add(NewPPSVariantIFC(Stack[Longint(Stack.Count) - 1], True));
+ for i := Stack.Count -3 downto Longint(Stack.Count) - ParamCount -2 do
+ begin
+ Params.Add(NewPPSVariantIFC(Stack[I], False));
+ end;
+ try
+ Result := Caller.InnerfuseCall(FSelf, p.Ext1, cdRegister, Params, nil);
+ finally
+ DisposePPSVariantIFCList(Params);
+ end;
+ end else begin
+ n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 1], False);
+ if (n.Dta = nil) or (n.aType.BaseType <> btClass) then
+ begin
+ result := false;
+ Caller.CMD_Err(erNullPointerException);
+ exit;
+ end;
+ FSelf := pointer(n.Dta^);
+ if FSelf = nil then
+ begin
+ Caller.CMD_Err(erCouldNotCallProc);
+ Result := False;
+ exit;
+ end;
+ Params := TPSList.Create;
+ Params.Add(NewPPSVariantIFC(Stack[Longint(Stack.Count) - ParamCount - 2], False));
+
+ for i := Stack.Count -2 downto Longint(Stack.Count) - ParamCount -1 do
+ begin
+ Params.Add(NewPPSVariantIFC(Stack[I], False));
+ end;
+ try
+ Result := Caller.InnerfuseCall(FSelf, p.Ext2, cdregister, Params, nil);
+ finally
+ DisposePPSVariantIFCList(Params);
+ end;
+ end;
+end;
+
+function ClassCallProcPropertyHelperName(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
+var
+ I, ParamCount: Longint;
+ Params: TPSList;
+ tt: PIFVariant;
+ n: TPSVariantIFC;
+ FSelf: Pointer;
+begin
+ if Length(P.Decl) < 4 then begin
+ Result := False;
+ exit;
+ end;
+ ParamCount := Longint((@P.Decl[1])^);
+ if Longint(Stack.Count) < ParamCount +1 then begin
+ Result := False;
+ exit;
+ end;
+ Dec(ParamCount);
+ if p.Ext1 <> nil then // read
+ begin
+ n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 2], false);
+ if (n.Dta = nil) or (n.aType.BaseType <> btClass) then
+ begin
+ result := false;
+ Caller.CMD_Err(erNullPointerException);
+ exit;
+ end;
+ FSelf := Tobject(n.dta^);
+ Params := TPSList.Create;
+ Params.Add(NewPPSVariantIFC(Stack[Longint(Stack.Count) - 1], True));
+ for i := Stack.Count -3 downto Longint(Stack.Count) - ParamCount -2 do
+ Params.Add(NewPPSVariantIFC(Stack[I], False));
+ tt := CreateHeapVariant(Caller.FindType2(btString));
+ if tt <> nil then
+ begin
+ PPSVariantAString(tt).Data := p.Name;
+ Params.Add(NewPPSVariantIFC(tt, false));
+ end;
+ try
+ Result := Caller.InnerfuseCall(FSelf, p.Ext1, cdRegister, Params, nil);
+ finally
+ DestroyHeapVariant(tt);
+ DisposePPSVariantIFCList(Params);
+ end;
+ end else begin
+ n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 1], false);
+ if (n.Dta = nil) or (n.aType.BaseType <> btClass) then
+ begin
+ result := false;
+ Caller.CMD_Err(erNullPointerException);
+ exit;
+ end;
+ FSelf := Tobject(n.dta^);
+ Params := TPSList.Create;
+ Params.Add(NewPPSVariantIFC(Stack[Longint(Stack.Count) - 2], True));
+
+ for i := Stack.Count -2 downto Longint(Stack.Count) - ParamCount -1 do
+ begin
+ Params.Add(NewPPSVariantIFC(Stack[I], false));
+ end;
+ tt := CreateHeapVariant(Caller.FindType2(btString));
+ if tt <> nil then
+ begin
+ PPSVariantAString(tt).Data := p.Name;
+ Params.Add(NewPPSVariantIFC(tt, false));
+ end;
+ try
+ Result := Caller.InnerfuseCall(FSelf, p.Ext2, cdregister, Params, nil);
+ finally
+ DestroyHeapVariant(tt);
+ DisposePPSVariantIFCList(Params);
+ end;
+ end;
+end;
+
+
+
+function ClassCallProcEventPropertyHelper(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
+{Event property helper}
+var
+ I, ParamCount: Longint;
+ Params: TPSList;
+ n: TPSVariantIFC;
+ data: TMethod;
+ n2: PIFVariant;
+ FSelf: Pointer;
+begin
+ if Length(P.Decl) < 4 then begin
+ Result := False;
+ exit;
+ end;
+ ParamCount := Longint((@P.Decl[1])^);
+ if Longint(Stack.Count) < ParamCount +1 then begin
+ Result := False;
+ exit;
+ end;
+ Dec(ParamCount);
+ if p.Ext1 <> nil then // read
+ begin
+ n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 2], false);
+ if (n.Dta = nil) or (n.aType.BaseType <> btClass) then
+ begin
+ result := false;
+ Caller.CMD_Err(erNullPointerException);
+ exit;
+ end;
+ FSelf := Tobject(n.dta^);
+ n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 1], True); // Result
+ if (n.aType.BaseType <> btU32) and (n.aType.BaseType <> btProcPtr) then
+ begin
+ Result := False;
+ Caller.CMD_Err(erNullPointerException);
+ exit;
+ end;
+ n2 := CreateHeapVariant(Caller.FindType2(btPChar));
+ if n2 = nil then
+ begin
+ Result := False;
+ exit;
+ end;
+ Params := TPSList.Create;
+//{$IFDEF CPU64}
+//{$ELSE}
+ data.Code := nil;
+ data.Data := nil;
+//{$ENDIF}
+ PPSVariantDynamicArray(n2)^.Data:= @data;
+ Params.Add(NewPPSVariantIFC(n2, false));
+ for i := Stack.Count -3 downto Longint(Stack.Count) - ParamCount -2 do
+ Params.Add(NewPPSVariantIFC(Stack[i], False));
+ try
+ Result := Caller.InnerfuseCall(FSelf, p.Ext1, cdRegister, Params, nil);
+ finally
+ Cardinal(n.Dta^) := getMethodNo(data, Caller);
+ if Cardinal(n.Dta^) = 0 then
+ begin
+ Pointer(Pointer((IPointer(n.dta)+PointerSize))^) := data.Data;
+ Pointer(Pointer((IPointer(n.dta)+PointerSize2))^) := data.Code;
+ end;
+ DestroyHeapVariant(n2);
+ DisposePPSVariantIFCList(Params);
+ end;
+ end else begin
+ n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 1], false);
+ if (n.Dta = nil) or (n.aType.BaseType <> btClass) then
+ begin
+ result := false;
+ Caller.CMD_Err(erNullPointerException);
+ exit;
+ end;
+ FSelf := Tobject(n.dta^);
+ n := NewTPSVariantIFC(Stack[Longint(Stack.Count) - 2], false);
+ if (n.Dta = nil) or ((n.aType.BaseType <> btu32) and (n.aType.BaseType <> btProcPtr)) then
+ begin
+ result := false;
+ Caller.CMD_Err(erNullPointerException);
+ exit;
+ end;
+ n2 := CreateHeapVariant(Caller.FindType2(btPchar));
+ if n2 = nil then
+ begin
+ Result := False;
+ exit;
+ end;
+
+ if (n.aType.BaseType = btProcPtr) and (cardinal(n.dta^) = 0) then
+ data := TMethod(Pointer(IPointer(n.dta^)+4)^)
+ else
+ data := MkMethod(Caller, cardinal(n.dta^));
+ Params := TPSList.Create;
+ Params.Add(NewPPSVariantIFC(n2, False));
+
+ for i := Stack.Count -2 downto Longint(Stack.Count) - ParamCount -1 do
+ begin
+ Params.Add(NewPPSVariantIFC(Stack[I], False));
+ end;
+ try
+ Result := Caller.InnerfuseCall(FSelf, p.Ext2, cdregister, Params, nil);
+ finally
+ DestroyHeapVariant(n2);
+ DisposePPSVariantIFCList(Params);
+ end;
+ end;
+end;
+
+
+{'class:'+CLASSNAME+'|'+FUNCNAME+'|'+chr(CallingConv)+chr(hasresult)+params
+
+For property write functions there is an '@' after the funcname.
+}
+function SpecImport(Sender: TPSExec; p: TPSExternalProcRec; Tag: Pointer): Boolean;
+var
+ H, I: Longint;
+ S, s2: tbtString;
+ CL: TPSRuntimeClass;
+ Px: PClassItem;
+ pp: PPropInfo;
+ IsRead: Boolean;
+begin
+ s := p.Decl;
+ delete(s, 1, 6);
+ if s = '-' then {nil function}
+ begin
+ p.ProcPtr := NilProc;
+ Result := True;
+ exit;
+ end;
+ if s = '+' then {cast function}
+ begin
+ p.ProcPtr := CastProc;
+ p.Ext2 := Tag;
+ Result := True;
+ exit;
+ end;
+ s2 := copy(S, 1, pos(tbtchar('|'), s)-1);
+ delete(s, 1, length(s2) + 1);
+ H := MakeHash(s2);
+ ISRead := False;
+ cl := nil;
+ for I := TPSRuntimeClassImporter(Tag).FClasses.Count -1 downto 0 do
+ begin
+ Cl := TPSRuntimeClassImporter(Tag).FClasses[I];
+ if (Cl.FClassNameHash = h) and (cl.FClassName = s2) then
+ begin
+ IsRead := True;
+ break;
+ end;
+ end;
+ if not isRead then begin
+ Result := False;
+ exit;
+ end;
+ s2 := copy(S, 1, pos(tbtchar('|'), s)-1);
+ delete(s, 1, length(s2) + 1);
+ if (s2 <> '') and (s2[length(s2)] = '@') then
+ begin
+ IsRead := False;
+ Delete(S2, length(s2), 1);
+ end else
+ isRead := True;
+ p.Name := s2;
+ H := MakeHash(s2);
+ for i := cl.FClassItems.Count -1 downto 0 do
+ begin
+ px := cl.FClassItems[I];
+ if (px^.FNameHash = h) and (px^.FName = s2) then
+ begin
+ p.Decl := s;
+ case px^.b of
+ {0: ext1=ptr}
+ {1: ext1=pointerinlist}
+ {2: ext1=propertyinfo}
+ {3: ext1=readfunc; ext2=writefunc}
+ 4:
+ begin
+ p.ProcPtr := ClassCallProcConstructor;
+ p.Ext1 := px^.Ptr;
+ if p.Ext1 = nil then begin result := false; exit; end;
+ p.Ext2 := Tag;
+ end;
+ 5:
+ begin
+ p.ProcPtr := ClassCallProcVirtualConstructor;
+ p.Ext1 := px^.Ptr;
+ if p.Ext1 = nil then begin result := false; exit; end;
+ p.Ext2 := Tag;
+ end;
+ 6:
+ begin
+ p.ProcPtr := ClassCallProcEventPropertyHelper;
+ if IsRead then
+ begin
+ p.Ext1 := px^.FReadFunc;
+ if p.Ext1 = nil then begin result := false; exit; end;
+ p.Ext2 := nil;
+ end else
+ begin
+ p.Ext1 := nil;
+ p.Ext2 := px^.FWriteFunc;
+ if p.Ext2 = nil then begin result := false; exit; end;
+ end;
+ end;
+ 0:
+ begin
+ p.ProcPtr := ClassCallProcMethod;
+ p.Ext1 := px^.Ptr;
+ if p.Ext1 = nil then begin result := false; exit; end;
+ p.Ext2 := nil;
+ end;
+ 1:
+ begin
+ p.ProcPtr := ClassCallProcMethod;
+ p.Ext1 := px^.PointerInList;
+ //if p.Ext1 = nil then begin result := false; exit; end;
+ p.ext2 := pointer(1);
+ end;
+ 3:
+ begin
+ p.ProcPtr := ClassCallProcPropertyHelper;
+ if IsRead then
+ begin
+ p.Ext1 := px^.FReadFunc;
+ if p.Ext1 = nil then begin result := false; exit; end;
+ p.Ext2 := nil;
+ end else
+ begin
+ p.Ext1 := nil;
+ p.Ext2 := px^.FWriteFunc;
+ if p.Ext2 = nil then begin result := false; exit; end;
+ end;
+ end;
+ 7:
+ begin
+ p.ProcPtr := ClassCallProcPropertyHelperName;
+ if IsRead then
+ begin
+ p.Ext1 := px^.FReadFunc;
+ if p.Ext1 = nil then begin result := false; exit; end;
+ p.Ext2 := nil;
+ end else
+ begin
+ p.Ext1 := nil;
+ p.Ext2 := px^.FWriteFunc;
+ if p.Ext2 = nil then begin result := false; exit; end;
+ end;
+ end;
+ else
+ begin
+ result := false;
+ exit;
+ end;
+ end;
+ Result := true;
+ exit;
+ end;
+ end;
+ if cl.FClass.ClassInfo <> nil then
+ begin
+ pp := GetPropInfo(cl.FClass.ClassInfo, string(s2));
+ if pp <> nil then
+ begin
+ p.ProcPtr := ClassCallProcProperty;
+ p.Ext1 := pp;
+ if IsRead then
+ p.Ext2 := Pointer(1)
+ else
+ p.Ext2 := Pointer(0);
+ Result := True;
+ end else
+ result := false;
+ end else
+ Result := False;
+end;
+
+procedure RegisterClassLibraryRuntime(SE: TPSExec; Importer: TPSRuntimeClassImporter);
+begin
+ SE.AddSpecialProcImport('class', SpecImport, Importer);
+end;
+
+
+procedure TPSExec.ClearspecialProcImports;
+var
+ I: Longint;
+ P: PSpecialProc;
+begin
+ for I := FSpecialProcList.Count -1 downto 0 do
+ begin
+ P := FSpecialProcList[I];
+ Dispose(p);
+ end;
+ FSpecialProcList.Clear;
+end;
+
+procedure TPSExec.RaiseCurrentException;
+var
+ ExObj: TObject;
+begin
+ if ExEx = erNoError then exit; // do nothing
+ ExObj := Self.ExObject;
+ if ExObj <> nil then
+ begin
+ Self.ExObject := nil;
+ raise ExObj;
+ end;
+ raise EPSException.Create(PSErrorToString(ExceptionCode, ExceptionString), Self, ExProc, ExPos);
+end;
+
+procedure TPSExec.CMD_Err2(EC: TPSError; const Param: tbtString);
+begin
+ CMD_Err3(EC, Param, Nil);
+end;
+
+function TPSExec.GetProcAsMethod(const ProcNo: Cardinal): TMethod;
+begin
+ Result := MkMethod(Self, ProcNo);
+end;
+
+function TPSExec.GetProcAsMethodN(const ProcName: tbtString): TMethod;
+var
+ procno: Cardinal;
+begin
+ Procno := GetProc(ProcName);
+ if Procno = InvalidVal then
+ begin
+ Result.Code := nil;
+ Result.Data := nil;
+ end
+ else
+ Result := MkMethod(Self, procno)
+end;
+
+
+procedure TPSExec.RegisterAttributeType(useproc: TPSAttributeUseProc;
+ const TypeName: tbtString);
+var
+ att: TPSAttributeType;
+begin
+ att := TPSAttributeType.Create;
+ att.TypeName := TypeName;
+ att.TypeNameHash := MakeHash(TypeName);
+ att.UseProc := UseProc;
+ FAttributeTypes.Add(att);
+end;
+
+function TPSExec.GetProcCount: Cardinal;
+begin
+ Result := FProcs.Count;
+end;
+
+function TPSExec.GetTypeCount: Longint;
+begin
+ Result := FTypes.Count;
+end;
+
+function TPSExec.GetVarCount: Longint;
+begin
+ Result := FGlobalVars.Count;
+end;
+
+function TPSExec.FindSpecialProcImport(
+ P: TPSOnSpecialProcImport): pointer;
+var
+ i: Longint;
+ pr: PSpecialProc;
+begin
+ for i := FSpecialProcList.Count -1 downto 0 do
+ begin
+ pr := FSpecialProcList[i];
+ if @pr.P = @p then
+ begin
+ Result := pr.tag;
+ exit;
+ end;
+ end;
+ result := nil;
+end;
+
+function TPSExec.InvokeExternalMethod(At: TPSTypeRec_ProcPtr; Slf,
+ Ptr: Pointer): Boolean;
+var
+ res: PPSVariantIFC;
+ s: tbtString;
+ CurrStack, i: Longint;
+ n: PPSVariant;
+ MyList: TPSList;
+begin
+ s := TPSTypeRec_ProcPtr(at).ParamInfo;
+ CurrStack := Cardinal(FStack.Count) - Cardinal(length(s));
+ if s[1] = #0 then inc(CurrStack);
+ MyList := TPSList.Create;
+ for i := 2 to length(s) do
+ begin
+ MyList.Add(nil);
+ end;
+ for i := length(s) downto 2 do
+ begin
+ n := FStack[CurrStack];
+ MyList[i - 2] := NewPPSVariantIFC(n, s[i] <> #0);
+ inc(CurrStack);
+ end;
+ if s[1] <> #0 then
+ begin
+ res := NewPPSVariantIFC(FStack[CurrStack + 1], True);
+ end else res := nil;
+ Result := InnerfuseCall(Slf, Ptr, cdRegister, MyList, Res);
+
+ DisposePPSVariantIFC(res);
+ DisposePPSVariantIFCList(mylist);
+end;
+
+function TPSExec.LastEx: TPSError;
+var
+ pp: TPSExceptionHandler;
+begin
+ if FExceptionStack.Count = 0 then begin
+ result := ExEx;
+ exit;
+ end;
+ pp := fExceptionStack[fExceptionStack.Count-1];
+ result := pp.ExceptionData;
+end;
+
+function TPSExec.LastExParam: tbtString;
+begin
+ result := ExParam;
+end;
+
+function TPSExec.LastExPos: Integer;
+begin
+ result := ExPos;
+end;
+
+function TPSExec.LastExProc: Integer;
+begin
+ result := exProc;
+end;
+
+{ TPSRuntimeClass }
+
+constructor TPSRuntimeClass.Create(aClass: TClass; const AName: tbtString);
+begin
+ inherited Create;
+ FClass := AClass;
+ if AName = '' then
+ begin
+ FClassName := FastUpperCase(tbtString(aClass.ClassName));
+ FClassNameHash := MakeHash(FClassName);
+ end else begin
+ FClassName := FastUppercase(AName);
+ FClassNameHash := MakeHash(FClassName);
+ end;
+ FClassItems:= TPSList.Create;
+ FEndOfVmt := MaxInt;
+end;
+
+destructor TPSRuntimeClass.Destroy;
+var
+ I: Longint;
+ P: PClassItem;
+begin
+ for i:= FClassItems.Count -1 downto 0 do
+ begin
+ P := FClassItems[I];
+ Dispose(p);
+ end;
+ FClassItems.Free;
+ inherited Destroy;
+end;
+
+procedure TPSRuntimeClass.RegisterVirtualAbstractMethod(ClassDef: TClass;
+ ProcPtr: Pointer; const Name: tbtString);
+var
+ P: PClassItem;
+begin
+ New(P);
+ p^.FName := FastUppercase(Name);
+ p^.FNameHash := MakeHash(p^.FName);
+ p^.b := 1;
+ p^.PointerInList := FindVirtualMethodPtr(Self, ClassDef, ProcPtr);
+ FClassItems.Add(p);
+end;
+
+procedure TPSRuntimeClass.RegisterConstructor(ProcPtr: Pointer;
+ const Name: tbtString);
+var
+ P: PClassItem;
+begin
+ New(P);
+ p^.FName := FastUppercase(Name);
+ p^.FNameHash := MakeHash(p^.FName);
+ p^.b := 4;
+ p^.Ptr := ProcPtr;
+ FClassItems.Add(p);
+end;
+
+procedure TPSRuntimeClass.RegisterMethod(ProcPtr: Pointer; const Name: tbtString);
+var
+ P: PClassItem;
+begin
+ New(P);
+ p^.FName := FastUppercase(Name);
+ p^.FNameHash := MakeHash(p^.FName);
+ p^.b := 0;
+ p^.Ptr := ProcPtr;
+ FClassItems.Add(p);
+end;
+
+
+procedure TPSRuntimeClass.RegisterPropertyHelper(ReadFunc,
+ WriteFunc: Pointer; const Name: tbtString);
+var
+ P: PClassItem;
+begin
+ New(P);
+ p^.FName := FastUppercase(Name);
+ p^.FNameHash := MakeHash(p^.FName);
+ p^.b := 3;
+ p^.FReadFunc := ReadFunc;
+ p^.FWriteFunc := WriteFunc;
+ FClassItems.Add(p);
+end;
+
+procedure TPSRuntimeClass.RegisterVirtualConstructor(ProcPtr: Pointer;
+ const Name: tbtString);
+var
+ P: PClassItem;
+begin
+ New(P);
+ p^.FName := FastUppercase(Name);
+ p^.FNameHash := MakeHash(p^.FName);
+ p^.b := 5;
+ p^.PointerInList := FindVirtualMethodPtr(Self, FClass, ProcPtr);
+ FClassItems.Add(p);
+end;
+
+procedure TPSRuntimeClass.RegisterVirtualMethod(ProcPtr: Pointer; const Name: tbtString);
+var
+ P: PClassItem;
+begin
+ New(P);
+ p^.FName := FastUppercase(Name);
+ p^.FNameHash := MakeHash(p^.FName);
+ p^.b := 1;
+ p^.PointerInList := FindVirtualMethodPtr(Self, FClass, ProcPtr);
+ FClassItems.Add(p);
+end;
+
+procedure TPSRuntimeClass.RegisterEventPropertyHelper(ReadFunc,
+ WriteFunc: Pointer; const Name: tbtString);
+var
+ P: PClassItem;
+begin
+ New(P);
+ p^.FName := FastUppercase(Name);
+ p^.FNameHash := MakeHash(p^.FName);
+ p^.b := 6;
+ p^.FReadFunc := ReadFunc;
+ p^.FWriteFunc := WriteFunc;
+ FClassItems.Add(p);
+end;
+
+
+procedure TPSRuntimeClass.RegisterPropertyHelperName(ReadFunc,
+ WriteFunc: Pointer; const Name: tbtString);
+var
+ P: PClassItem;
+begin
+ New(P);
+ p^.FName := FastUppercase(Name);
+ p^.FNameHash := MakeHash(p^.FName);
+ p^.b := 7;
+ p^.FReadFunc := ReadFunc;
+ p^.FWriteFunc := WriteFunc;
+ FClassItems.Add(p);
+end;
+
+{ TPSRuntimeClassImporter }
+
+function TPSRuntimeClassImporter.Add(aClass: TClass): TPSRuntimeClass;
+begin
+ Result := FindClass(tbtstring(aClass.ClassName));
+ if Result <> nil then exit;
+ Result := TPSRuntimeClass.Create(aClass, '');
+ FClasses.Add(Result);
+end;
+
+function TPSRuntimeClassImporter.Add2(aClass: TClass;
+ const Name: tbtString): TPSRuntimeClass;
+begin
+ Result := FindClass(Name);
+ if Result <> nil then exit;
+ Result := TPSRuntimeClass.Create(aClass, Name);
+ FClasses.Add(Result);
+end;
+
+procedure TPSRuntimeClassImporter.Clear;
+var
+ I: Longint;
+begin
+ for i := 0 to FClasses.Count -1 do
+ begin
+ TPSRuntimeClass(FClasses[I]).Free;
+ end;
+ FClasses.Clear;
+end;
+
+constructor TPSRuntimeClassImporter.Create;
+begin
+ inherited Create;
+ FClasses := TPSList.Create;
+
+end;
+
+constructor TPSRuntimeClassImporter.CreateAndRegister(Exec: TPSexec;
+ AutoFree: Boolean);
+begin
+ inherited Create;
+ FClasses := TPSList.Create;
+ RegisterClassLibraryRuntime(Exec, Self);
+ if AutoFree then
+ Exec.AddResource(@RCIFreeProc, Self);
+end;
+
+destructor TPSRuntimeClassImporter.Destroy;
+begin
+ Clear;
+ FClasses.Free;
+ inherited Destroy;
+end;
+
+{$IFNDEF PS_NOINTERFACES}
+procedure SetVariantToInterface(V: PIFVariant; Cl: IUnknown);
+begin
+ if (v <> nil) and (v.FType.BaseType = btInterface) then
+ begin
+ PPSVariantinterface(v).Data := cl;
+ {$IFNDEF Delphi3UP}
+ if PPSVariantinterface(v).Data <> nil then
+ PPSVariantinterface(v).Data.AddRef;
+ {$ENDIF}
+ end;
+end;
+{$ENDIF}
+
+procedure SetVariantToClass(V: PIFVariant; Cl: TObject);
+begin
+ if (v <> nil) and (v.FType.BaseType = btClass) then
+ begin
+ PPSVariantclass(v).Data := cl;
+ end;
+end;
+
+function BGRFW(var s: tbtString): tbtString;
+var
+ l: Longint;
+begin
+ l := Length(s);
+ while l >0 do
+ begin
+ if s[l] = ' ' then
+ begin
+ Result := copy(s, l + 1, Length(s) - l);
+ Delete(s, l, Length(s) - l + 1);
+ exit;
+ end;
+ Dec(l);
+ end;
+ Result := s;
+ s := '';
+end;
+
+{$ifdef fpc}
+ {$if defined(cpupowerpc) or defined(cpuarm) or defined(cpu64)}
+ {$define empty_methods_handler}
+ {$ifend}
+{$endif}
+
+{$ifdef empty_methods_handler}
+procedure MyAllMethodsHandler;
+begin
+end;
+{$else}
+
+
+function MyAllMethodsHandler2(Self: PScriptMethodInfo; const Stack: PPointer; _EDX, _ECX: Pointer): Integer; forward;
+
+procedure MyAllMethodsHandler;
+// On entry:
+// EAX = Self pointer
+// EDX, ECX = param1 and param2
+// STACK = param3... paramcount
+asm
+ push 0
+ push ecx
+ push edx
+ mov edx, esp
+ add edx, 16 // was 12
+ pop ecx
+ call MyAllMethodsHandler2
+ pop ecx
+ mov edx, [esp]
+ add esp, eax
+ mov [esp], edx
+ mov eax, ecx
+end;
+
+function ResultAsRegister(b: TPSTypeRec): Boolean;
+begin
+ case b.BaseType of
+ btSingle,
+ btDouble,
+ btExtended,
+ btU8,
+ bts8,
+ bts16,
+ btu16,
+ bts32,
+ btu32,
+{$IFDEF PS_FPCSTRINGWORKAROUND}
+ btString,
+{$ENDIF}
+{$IFNDEF PS_NOINT64}
+ bts64,
+{$ENDIF}
+ btPChar,
+{$IFNDEF PS_NOWIDESTRING}
+ btWideChar,
+{$ENDIF}
+ btChar,
+ btclass,
+ btEnum: Result := true;
+ btSet: Result := b.RealSize <= PointerSize;
+ btStaticArray: Result := b.RealSize <= PointerSize;
+ else
+ Result := false;
+ end;
+end;
+
+function SupportsRegister(b: TPSTypeRec): Boolean;
+begin
+ case b.BaseType of
+ btU8,
+ bts8,
+ bts16,
+ btu16,
+ bts32,
+ btu32,
+ btstring,
+ btclass,
+{$IFNDEF PS_NOINTERFACES}
+ btinterface,
+{$ENDIF}
+ btPChar,
+{$IFNDEF PS_NOWIDESTRING}
+ btwidestring,
+ btUnicodeString,
+ btWideChar,
+{$ENDIF}
+ btChar,
+ btArray,
+ btEnum: Result := true;
+ btSet: Result := b.RealSize <= PointerSize;
+ btStaticArray: Result := b.RealSize <= PointerSize;
+ else
+ Result := false;
+ end;
+end;
+
+function AlwaysAsVariable(aType: TPSTypeRec): Boolean;
+begin
+ case atype.BaseType of
+ btVariant: Result := true;
+ btSet: Result := atype.RealSize > PointerSize;
+ btRecord: Result := atype.RealSize > PointerSize;
+ btStaticArray: Result := atype.RealSize > PointerSize;
+ else
+ Result := false;
+ end;
+end;
+
+
+procedure PutOnFPUStackExtended(ft: extended);
+asm
+// fstp tbyte ptr [ft]
+ fld tbyte ptr [ft]
+
+end;
+
+
+function MyAllMethodsHandler2(Self: PScriptMethodInfo; const Stack: PPointer; _EDX, _ECX: Pointer): Integer;
+var
+ Decl: tbtString;
+ I, C, regno: Integer;
+ Params: TPSList;
+ Res, Tmp: PIFVariant;
+ cpt: PIFTypeRec;
+ fmod: tbtchar;
+ s,e: tbtString;
+ FStack: pointer;
+ ex: TPSExceptionHandler;
+
+
+begin
+ Decl := TPSInternalProcRec(Self^.Se.FProcs[Self^.ProcNo]).ExportDecl;
+
+ FStack := Stack;
+ Params := TPSList.Create;
+ s := decl;
+ grfw(s);
+ while s <> '' do
+ begin
+ Params.Add(nil);
+ grfw(s);
+ end;
+ c := Params.Count;
+ regno := 0;
+ Result := 0;
+ s := decl;
+ grfw(s);
+ for i := c-1 downto 0 do
+ begin
+ e := grfw(s);
+ fmod := e[1];
+ delete(e, 1, 1);
+ cpt := Self.Se.GetTypeNo(StrToInt(e));
+ if ((fmod = '%') or (fmod = '!') or (AlwaysAsVariable(cpt))) and (RegNo < 2) then
+ begin
+ tmp := CreateHeapVariant(self.Se.FindType2(btPointer));
+ PPSVariantPointer(tmp).DestType := cpt;
+ Params[i] := tmp;
+ case regno of
+ 0: begin
+ PPSVariantPointer(tmp).DataDest := Pointer(_EDX);
+ inc(regno);
+ end;
+ 1: begin
+ PPSVariantPointer(tmp).DataDest := Pointer(_ECX);
+ inc(regno);
+ end;
+(* else begin
+ PPSVariantPointer(tmp).DataDest := Pointer(FStack^);
+ FStack := Pointer(IPointer(FStack) + 4);
+ end;*)
+ end;
+ end
+ else if SupportsRegister(cpt) and (RegNo < 2) then
+ begin
+ tmp := CreateHeapVariant(cpt);
+ Params[i] := tmp;
+ case regno of
+ 0: begin
+ CopyArrayContents(@PPSVariantData(tmp)^.Data, @_EDX, 1, cpt);
+ inc(regno);
+ end;
+ 1: begin
+ CopyArrayContents(@PPSVariantData(tmp)^.Data, @_ECX, 1, cpt);
+ inc(regno);
+ end;
+(* else begin
+ CopyArrayContents(@PPSVariantData(tmp)^.Data, Pointer(FStack), 1, cpt);
+ FStack := Pointer(IPointer(FStack) + 4);
+ end;*)
+ end;
+(* end else
+ begin
+ tmp := CreateHeapVariant(cpt);
+ Params[i] := tmp;
+ CopyArrayContents(@PPSVariantData(tmp)^.Data, Pointer(FStack), 1, cpt);
+ FStack := Pointer(IPointer(FStack) + cpt.RealSize + 3 and not 3);*)
+ end;
+ end;
+ s := decl;
+ e := grfw(s);
+
+ if e <> '-1' then
+ begin
+ cpt := Self.Se.GetTypeNo(StrToInt(e));
+ if not ResultAsRegister(cpt) then
+ begin
+ Res := CreateHeapVariant(Self.Se.FindType2(btPointer));
+ PPSVariantPointer(Res).DestType := cpt;
+ Params.Add(Res);
+ case regno of
+ 0: begin
+ PPSVariantPointer(Res).DataDest := Pointer(_EDX);
+ end;
+ 1: begin
+ PPSVariantPointer(Res).DataDest := Pointer(_ECX);
+ end;
+ else begin
+ PPSVariantPointer(Res).DataDest := Pointer(FStack^);
+ Inc(Result, PointerSize);
+ end;
+ end;
+ end else
+ begin
+ Res := CreateHeapVariant(cpt);
+ Params.Add(Res);
+ end;
+ end else Res := nil;
+ s := decl;
+ grfw(s);
+ for i := 0 to c -1 do
+ begin
+ e := grlw(s);
+ fmod := e[1];
+ delete(e, 1, 1);
+ if Params[i] <> nil then Continue;
+ cpt := Self.Se.GetTypeNo(StrToInt(e));
+ if (fmod = '%') or (fmod = '!') or (AlwaysAsVariable(cpt)) then
+ begin
+ tmp := CreateHeapVariant(self.Se.FindType2(btPointer));
+ PPSVariantPointer(tmp).DestType := cpt;
+ Params[i] := tmp;
+ PPSVariantPointer(tmp).DataDest := Pointer(FStack^);
+ FStack := Pointer(IPointer(FStack) + PointerSize);
+ Inc(Result, PointerSize);
+ end
+(* else if SupportsRegister(cpt) then
+ begin
+ tmp := CreateHeapVariant(cpt);
+ Params[i] := tmp;
+ CopyArrayContents(@PPSVariantData(tmp)^.Data, Pointer(FStack), 1, cpt);
+ FStack := Pointer(IPointer(FStack) + 4);
+ end;
+ end *)else
+ begin
+ tmp := CreateHeapVariant(cpt);
+ Params[i] := tmp;
+ CopyArrayContents(@PPSVariantData(tmp)^.Data, Pointer(FStack), 1, cpt);
+ FStack := Pointer((IPointer(FStack) + cpt.RealSize + 3) and not 3);
+ Inc(Result, (cpt.RealSize + 3) and not 3);
+ end;
+ end;
+ ex := TPSExceptionHandler.Create;
+ ex.FinallyOffset := InvalidVal;
+ ex.ExceptOffset := InvalidVal;
+ ex.Finally2Offset := InvalidVal;
+ ex.EndOfBlock := InvalidVal;
+ ex.CurrProc := nil;
+ ex.BasePtr := Self.Se.FCurrStackBase;
+ Ex.StackSize := Self.Se.FStack.Count;
+ i := Self.Se.FExceptionStack.Add(ex);
+ Self.Se.RunProc(Params, Self.ProcNo);
+ if Self.Se.FExceptionStack[i] = ex then
+ begin
+ Self.Se.FExceptionStack.Remove(ex);
+ ex.Free;
+ end;
+
+ if (Res <> nil) then
+ begin
+ Params.DeleteLast;
+ if (ResultAsRegister(Res.FType)) then
+ begin
+ if (res^.FType.BaseType = btSingle) or (res^.FType.BaseType = btDouble) or
+ (res^.FType.BaseType = btCurrency) or (res^.Ftype.BaseType = btExtended) then
+ begin
+ case Res^.FType.BaseType of
+ btSingle: PutOnFPUStackExtended(PPSVariantSingle(res).Data);
+ btDouble: PutOnFPUStackExtended(PPSVariantDouble(res).Data);
+ btExtended: PutOnFPUStackExtended(PPSVariantExtended(res).Data);
+ btCurrency: PutOnFPUStackExtended(PPSVariantCurrency(res).Data);
+ end;
+ DestroyHeapVariant(Res);
+ Res := nil;
+ end else
+ begin
+{$IFNDEF PS_NOINT64}
+ if res^.FType.BaseType <> btS64 then
+{$ENDIF}
+ CopyArrayContents(Pointer(Longint(Stack)-PointerSize2), @PPSVariantData(res)^.Data, 1, Res^.FType);
+ end;
+ end;
+ DestroyHeapVariant(res);
+ end;
+ for i := 0 to Params.Count -1 do
+ DestroyHeapVariant(Params[i]);
+ Params.Free;
+ if Self.Se.ExEx <> erNoError then
+ begin
+ if Self.Se.ExObject <> nil then
+ begin
+ FStack := Self.Se.ExObject;
+ Self.Se.ExObject := nil;
+ raise TObject(FStack);
+ end else
+ raise EPSException.Create(PSErrorToString(Self.SE.ExceptionCode, Self.Se.ExceptionString), Self.Se, Self.Se.ExProc, Self.Se.ExPos);
+ end;
+end;
+{$endif}
+function TPSRuntimeClassImporter.FindClass(const Name: tbtString): TPSRuntimeClass;
+var
+ h, i: Longint;
+ lName: tbtstring;
+ p: TPSRuntimeClass;
+begin
+ lName := FastUpperCase(Name);
+ h := MakeHash(lName);
+ for i := FClasses.Count -1 downto 0 do
+ begin
+ p := FClasses[i];
+ if (p.FClassNameHash = h) and (p.FClassName = lName) then
+ begin
+ Result := P;
+ exit;
+ end;
+ end;
+ Result := nil;
+end;
+
+function DelphiFunctionProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack; CC: TPSCallingConvention): Boolean;
+var
+ i: Integer;
+ MyList: TPSList;
+ n: PPSVariantIFC;
+ CurrStack: Cardinal;
+ s: tbtString;
+begin
+ s := P.Decl;
+ if length(s) = 0 then begin Result := False; exit; end;
+ CurrStack := Cardinal(Stack.Count) - Cardinal(length(s));
+ if s[1] = #0 then inc(CurrStack);
+ MyList := TPSList.Create;
+
+ for i := 2 to length(s) do
+ begin
+ MyList.Add(nil);
+ end;
+ for i := length(s) downto 2 do
+ begin
+ MyList[i - 2] := NewPPSVariantIFC(Stack[CurrStack], s[i] <> #0);
+ inc(CurrStack);
+ end;
+ if s[1] <> #0 then
+ begin
+ n := NewPPSVariantIFC(Stack[CurrStack], True);
+ end else n := nil;
+ try
+ result := Caller.InnerfuseCall(p.Ext2, p.Ext1, cc, MyList, n);
+ finally
+ DisposePPSVariantIFC(n);
+ DisposePPSVariantIFCList(mylist);
+ end;
+end;
+
+function DelphiFunctionProc_CDECL(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
+begin
+ Result := DelphiFunctionProc(Caller, p, Global, Stack, cdCdecl);
+end;
+function DelphiFunctionProc_Register(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
+begin
+ Result := DelphiFunctionProc(Caller, p, Global, Stack, cdRegister);
+end;
+function DelphiFunctionProc_Pascal(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
+begin
+ Result := DelphiFunctionProc(Caller, p, Global, Stack, cdPascal);
+end;
+function DelphiFunctionProc_Stdcall(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
+begin
+ Result := DelphiFunctionProc(Caller, p, Global, Stack, cdStdCall);
+end;
+function DelphiFunctionProc_Safecall(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
+begin
+ Result := DelphiFunctionProc(Caller, p, Global, Stack, cdSafeCall);
+end;
+
+procedure TPSExec.RegisterDelphiFunction(ProcPtr: Pointer;
+ const Name: tbtString; CC: TPSCallingConvention);
+begin
+ RegisterDelphiMethod(nil, ProcPtr, FastUppercase(Name), CC);
+end;
+
+procedure TPSExec.RegisterDelphiMethod(Slf, ProcPtr: Pointer;
+ const Name: tbtString; CC: TPSCallingConvention);
+begin
+ case cc of
+ cdRegister: RegisterFunctionName(FastUppercase(Name), DelphiFunctionProc_Register, ProcPtr, Slf);
+ cdPascal: RegisterFunctionName(FastUppercase(Name), DelphiFunctionProc_Pascal, ProcPtr, Slf);
+ cdStdCall: RegisterFunctionName(FastUppercase(Name), DelphiFunctionProc_Stdcall, ProcPtr, Slf);
+ cdSafeCall: RegisterFunctionName(FastUppercase(Name), DelphiFunctionProc_Safecall, ProcPtr, Slf);
+ cdCdecl: RegisterFunctionName(FastUppercase(Name), DelphiFunctionProc_CDECL, ProcPtr, Slf);
+ end;
+end;
+
+{ EPSException }
+
+constructor EPSException.Create(const Error: tbtString; Exec: TPSExec;
+ Procno, ProcPos: Cardinal);
+begin
+ inherited Create(string(Error));
+ FExec := Exec;
+ FProcNo := Procno;
+ FProcPos := ProcPos;
+end;
+
+{ TPSRuntimeAttribute }
+
+function TPSRuntimeAttribute.AddValue(aType: TPSTypeRec): PPSVariant;
+begin
+ Result := FValues.PushType(aType);
+end;
+
+procedure TPSRuntimeAttribute.AdjustSize;
+begin
+ FValues.Capacity := FValues.Length;
+end;
+
+constructor TPSRuntimeAttribute.Create(Owner: TPSRuntimeAttributes);
+begin
+ inherited Create;
+ FOwner := Owner;
+ FValues := TPSStack.Create;
+end;
+
+procedure TPSRuntimeAttribute.DeleteValue(i: Longint);
+begin
+ if Cardinal(i) <> Cardinal(FValues.Count -1) then
+ raise Exception.Create(RPS_CanOnlySendLastItem);
+ FValues.Pop;
+end;
+
+destructor TPSRuntimeAttribute.Destroy;
+begin
+ FValues.Free;
+ inherited Destroy;
+end;
+
+function TPSRuntimeAttribute.GetValue(I: Longint): PIFVariant;
+begin
+ Result := FValues[i];
+end;
+
+function TPSRuntimeAttribute.GetValueCount: Longint;
+begin
+ Result := FValues.Count;
+end;
+
+{ TPSRuntimeAttributes }
+
+function TPSRuntimeAttributes.Add: TPSRuntimeAttribute;
+begin
+ Result := TPSRuntimeAttribute.Create(Self);
+ FAttributes.Add(Result);
+end;
+
+constructor TPSRuntimeAttributes.Create(AOwner: TPSExec);
+begin
+ inherited Create;
+ FAttributes := TPSList.Create;
+ FOwner := AOwner;
+end;
+
+procedure TPSRuntimeAttributes.Delete(I: Longint);
+begin
+ TPSRuntimeAttribute(FAttributes[i]).Free;
+ FAttributes.Delete(i);
+end;
+
+destructor TPSRuntimeAttributes.Destroy;
+var
+ i: Longint;
+begin
+ for i := FAttributes.Count -1 downto 0 do
+ TPSRuntimeAttribute(FAttributes[i]).Free;
+ FAttributes.Free;
+ inherited Destroy;
+end;
+
+function TPSRuntimeAttributes.FindAttribute(
+ const Name: tbtString): TPSRuntimeAttribute;
+var
+ n: tbtString;
+ i, h: Longint;
+begin
+ n := FastUpperCase(Name);
+ h := MakeHash(n);
+ for i := 0 to FAttributes.Count -1 do
+ begin
+ Result := FAttributes[i];
+ if (Result.AttribTypeHash = h) and (Result.AttribType = n) then
+ exit;
+ end;
+ Result := nil;
+end;
+
+function TPSRuntimeAttributes.GetCount: Longint;
+begin
+ Result := FAttributes.Count;
+end;
+
+function TPSRuntimeAttributes.GetItem(I: Longint): TPSRuntimeAttribute;
+begin
+ Result := FAttributes[i];
+end;
+
+{ TPSInternalProcRec }
+
+destructor TPSInternalProcRec.Destroy;
+begin
+ if FData <> nil then
+ Freemem(Fdata, FLength);
+ inherited Destroy;
+end;
+
+{ TPsProcRec }
+
+constructor TPSProcRec.Create(Owner: TPSExec);
+begin
+ inherited Create;
+ FAttributes := TPSRuntimeAttributes.Create(Owner);
+end;
+
+destructor TPSProcRec.Destroy;
+begin
+ FAttributes.Free;
+ inherited Destroy;
+end;
+
+{ TPSTypeRec_Array }
+
+procedure TPSTypeRec_Array.CalcSize;
+begin
+ FrealSize := PointerSize;
+end;
+
+{ TPSTypeRec_StaticArray }
+
+procedure TPSTypeRec_StaticArray.CalcSize;
+begin
+ FrealSize := Cardinal(FArrayType.RealSize) * Cardinal(Size);
+end;
+
+{ TPSTypeRec_Set }
+
+procedure TPSTypeRec_Set.CalcSize;
+begin
+ FrealSize := FByteSize;
+end;
+
+const
+ MemDelta = 4096;
+
+{ TPSStack }
+
+procedure TPSStack.AdjustLength;
+var
+ MyLen: Longint;
+begin
+ MyLen := ((FLength shr 12) + 1) shl 12;
+
+ SetCapacity(MyLen);
+end;
+
+procedure TPSStack.Clear;
+var
+ v: Pointer;
+ i: Longint;
+begin
+ for i := Count -1 downto 0 do
+ begin
+ v := Data[i];
+ if TPSTypeRec(v^).BaseType in NeedFinalization then
+ FinalizeVariant(Pointer(IPointer(v)+PointerSize), TPSTypeRec(v^));
+ end;
+ inherited Clear;
+ FLength := 0;
+ SetCapacity(0);
+end;
+
+constructor TPSStack.Create;
+begin
+ inherited Create;
+ GetMem(FDataPtr, MemDelta);
+ FCapacity := MemDelta;
+ FLength := 0;
+end;
+
+destructor TPSStack.Destroy;
+var
+ v: Pointer;
+ i: Longint;
+begin
+ for i := Count -1 downto 0 do
+ begin
+ v := Data[i];
+ if TPSTypeRec(v^).BaseType in NeedFinalization then
+ FinalizeVariant(Pointer(IPointer(v)+PointerSize), Pointer(v^));
+ end;
+ FreeMem(FDataPtr, FCapacity);
+ inherited Destroy;
+end;
+
+function TPSStack.GetBool(ItemNo: Longint): Boolean;
+var
+ val: PPSVariant;
+begin
+ if ItemNo < 0 then
+ val := Items[Longint(ItemNo) + Longint(Count)]
+ else
+ val := Items[ItemNo];
+ Result := PSGetUInt(@PPSVariantData(val).Data, val.FType) <> 0;
+end;
+
+function TPSStack.GetClass(ItemNo: Longint): TObject;
+var
+ val: PPSVariant;
+begin
+ if ItemNo < 0 then
+ val := Items[Longint(ItemNo) + Longint(Count)]
+ else
+ val := Items[ItemNo];
+ Result := PSGetObject(@PPSVariantData(val).Data, val.FType);
+end;
+
+function TPSStack.GetCurrency(ItemNo: Longint): Currency;
+var
+ val: PPSVariant;
+begin
+ if ItemNo < 0 then
+ val := Items[Longint(ItemNo) + Longint(Count)]
+ else
+ val := Items[ItemNo];
+ Result := PSGetCurrency(@PPSVariantData(val).Data, val.FType);
+end;
+
+function TPSStack.GetInt(ItemNo: Longint): Longint;
+var
+ val: PPSVariant;
+begin
+ if ItemNo < 0 then
+ val := items[Longint(ItemNo) + Longint(Count)]
+ else
+ val := items[ItemNo];
+ Result := PSGetInt(@PPSVariantData(val).Data, val.FType);
+end;
+
+{$IFNDEF PS_NOINT64}
+function TPSStack.GetInt64(ItemNo: Longint): Int64;
+var
+ val: PPSVariant;
+begin
+ if ItemNo < 0 then
+ val := items[Longint(ItemNo) + Longint(Count)]
+ else
+ val := items[ItemNo];
+ Result := PSGetInt64(@PPSVariantData(val).Data, val.FType);
+end;
+{$ENDIF}
+
+function TPSStack.GetItem(I: Longint): PPSVariant;
+begin
+ if Cardinal(I) >= Cardinal(Count) then
+ Result := nil
+ else
+ Result := Data[i];
+end;
+
+function TPSStack.GetReal(ItemNo: Longint): Extended;
+var
+ val: PPSVariant;
+begin
+ if ItemNo < 0 then
+ val := items[Longint(ItemNo) + Longint(Count)]
+ else
+ val := items[ItemNo];
+ Result := PSGetreal(@PPSVariantData(val).Data, val.FType);
+end;
+
+function TPSStack.GetAnsiString(ItemNo: Longint): tbtString;
+var
+ val: PPSVariant;
+begin
+ if ItemNo < 0 then
+ val := items[Longint(ItemNo) + Longint(Count)]
+ else
+ val := items[ItemNo];
+ Result := PSGetAnsiString(@PPSVariantData(val).Data, val.FType);
+end;
+
+function TPSStack.GetString(ItemNo: Longint): string; // calls the native method
+begin
+ result := {$IFDEF DELPHI2009UP}GetUnicodeString(ItemNo){$ELSE}GetAnsiString(ItemNo){$ENDIF};
+end;
+
+function TPSStack.GetUInt(ItemNo: Longint): Cardinal;
+var
+ val: PPSVariant;
+begin
+ if ItemNo < 0 then
+ val := items[Longint(ItemNo) + Longint(Count)]
+ else
+ val := items[ItemNo];
+ Result := PSGetUInt(@PPSVariantData(val).Data, val.FType);
+end;
+
+function TPSStack.GetUnicodeString(ItemNo: Integer): tbtunicodestring;
+var
+ val: PPSVariant;
+begin
+ if ItemNo < 0 then
+ val := items[Longint(ItemNo) + Longint(Count)]
+ else
+ val := items[ItemNo];
+ Result := PSGetUnicodeString(@PPSVariantData(val).Data, val.FType);
+end;
+
+{$IFNDEF PS_NOWIDESTRING}
+function TPSStack.GetWideString(ItemNo: Longint): tbtWideString;
+var
+ val: PPSVariant;
+begin
+ if ItemNo < 0 then
+ val := items[Longint(ItemNo) + Longint(Count)]
+ else
+ val := items[ItemNo];
+ Result := PSGetWideString(@PPSVariantData(val).Data, val.FType);
+end;
+{$ENDIF}
+
+procedure TPSStack.Pop;
+var
+ p1: Pointer;
+ c: Longint;
+begin
+ c := count -1;
+ p1 := Data[c];
+ DeleteLast;
+ FLength := IPointer(p1) - IPointer(FDataPtr);
+ if TPSTypeRec(p1^).BaseType in NeedFinalization then
+ FinalizeVariant(Pointer(IPointer(p1)+PointerSize), Pointer(p1^));
+ if ((FCapacity - FLength) shr 12) > 2 then AdjustLength;
+end;
+
+function TPSStack.Push(TotalSize: Longint): PPSVariant;
+var
+ o: Cardinal;
+ p: Pointer;
+begin
+ o := FLength;
+ FLength := (FLength + TotalSize);
+ if FLength mod PointerSize <> 0 then
+ FLength := FLength + (PointerSize - (FLength mod PointerSize));
+ if FLength > FCapacity then AdjustLength;
+ p := Pointer(IPointer(FDataPtr) + IPointer(o));
+ Add(p);
+ Result := P;
+end;
+
+function TPSStack.PushType(aType: TPSTypeRec): PPSVariant;
+var
+ o: Cardinal;
+ p: Pointer;
+begin
+ Result := Push(aType.RealSize + Sizeof(Pointer));
+ Result.FType := aType;
+ InitializeVariant(Pointer(IPointer(Result)+PointerSize), aType);
+end;
+
+procedure TPSStack.SetBool(ItemNo: Longint; const Data: Boolean);
+var
+ val: PPSVariant;
+ ok: Boolean;
+begin
+ if ItemNo < 0 then
+ val := items[Longint(ItemNo) + Longint(Count)]
+ else
+ val := items[ItemNo];
+ ok := true;
+ if Data then
+ PSSetUInt(@PPSVariantData(val).Data, val.FType, ok, 1)
+ else
+ PSSetUInt(@PPSVariantData(val).Data, val.FType, ok, 0);
+ if not ok then raise Exception.Create(RPS_TypeMismatch);
+end;
+
+procedure TPSStack.SetCapacity(const Value: Longint);
+var
+ p: Pointer;
+ OOFS: IPointer;
+ I: Longint;
+begin
+ if Value < FLength then raise Exception.Create(RPS_CapacityLength);
+ if Value = 0 then
+ begin
+ if FDataPtr <> nil then
+ begin
+ FreeMem(FDataPtr, FCapacity);
+ FDataPtr := nil;
+ end;
+ FCapacity := 0;
+ end;
+ GetMem(p, Value);
+ if FDataPtr <> nil then
+ begin
+ if FLength > FCapacity then
+ OOFS := FCapacity
+ else
+ OOFS := FLength;
+ Move(FDataPtr^, p^, OOFS);
+ OOFS := IPointer(P) - IPointer(FDataPtr);
+
+ for i := Count -1 downto 0 do begin
+ Data[i] := Pointer(IPointer(Data[i]) + OOFS);
+ if Items[i].FType.FBaseType = btPointer then begin // check if pointer points to moved stack data
+ if (IPointer(PPSVariantPointer(Data[i]).DataDest) >= IPointer(FDataPtr)) and
+ (IPointer(PPSVariantPointer(Data[i]).DataDest) < IPointer(FDataPtr)+IPointer(FLength)) then
+ PPSVariantPointer(Data[i]).DataDest := Pointer(IPointer(PPSVariantPointer(Data[i]).DataDest) + OOFS);
+ end;
+ end;
+
+ FreeMem(FDataPtr, FCapacity);
+ end;
+ FDataPtr := p;
+ FCapacity := Value;
+end;
+
+procedure TPSStack.SetClass(ItemNo: Longint; const Data: TObject);
+var
+ val: PPSVariant;
+ ok: Boolean;
+begin
+ if ItemNo < 0 then
+ val := items[Longint(ItemNo) + Longint(Count)]
+ else
+ val := items[ItemNo];
+ ok := true;
+ PSSetObject(@PPSVariantData(val).Data, val.FType, ok, Data);
+ if not ok then raise Exception.Create(RPS_TypeMismatch);
+end;
+
+procedure TPSStack.SetCurrency(ItemNo: Longint; const Data: Currency);
+var
+ val: PPSVariant;
+ ok: Boolean;
+begin
+ if ItemNo < 0 then
+ val := items[Longint(ItemNo) + Longint(Count)]
+ else
+ val := items[ItemNo];
+ ok := true;
+ PSSetCurrency(@PPSVariantData(val).Data, val.FType, ok, Data);
+ if not ok then raise Exception.Create(RPS_TypeMismatch);
+end;
+
+procedure TPSStack.SetInt(ItemNo: Longint; const Data: Longint);
+var
+ val: PPSVariant;
+ ok: Boolean;
+begin
+ if ItemNo < 0 then
+ val := items[Longint(ItemNo) + Longint(Count)]
+ else
+ val := items[ItemNo];
+ ok := true;
+ PSSetInt(@PPSVariantData(val).Data, val.FType, ok, Data);
+ if not ok then raise Exception.Create(RPS_TypeMismatch);
+end;
+
+{$IFNDEF PS_NOINT64}
+procedure TPSStack.SetInt64(ItemNo: Longint; const Data: Int64);
+var
+ val: PPSVariant;
+ ok: Boolean;
+begin
+ if ItemNo < 0 then
+ val := items[Longint(ItemNo) + Longint(Count)]
+ else
+ val := items[ItemNo];
+ ok := true;
+ PSSetInt64(@PPSVariantData(val).Data, val.FType, ok, Data);
+ if not ok then raise Exception.Create(RPS_TypeMismatch);
+end;
+{$ENDIF}
+
+procedure TPSStack.SetReal(ItemNo: Longint; const Data: Extended);
+var
+ val: PPSVariant;
+ ok: Boolean;
+begin
+ if ItemNo < 0 then
+ val := items[Longint(ItemNo) + Longint(Count)]
+ else
+ val := items[ItemNo];
+ ok := true;
+ PSSetReal(@PPSVariantData(val).Data, val.FType, ok, Data);
+ if not ok then raise Exception.Create(RPS_TypeMismatch);
+end;
+
+procedure TPSStack.SetAnsiString(ItemNo: Longint; const Data: tbtString);
+var
+ val: PPSVariant;
+ ok: Boolean;
+begin
+ if ItemNo < 0 then
+ val := items[Longint(ItemNo) + Longint(Count)]
+ else
+ val := items[ItemNo];
+ ok := true;
+ PSSetAnsiString(@PPSVariantData(val).Data, val.FType, ok, Data);
+ if not ok then raise Exception.Create(RPS_TypeMismatch);
+end;
+
+procedure TPSStack.SetString(ItemNo: Longint; const Data: string);
+begin
+ {$IFDEF DELPHI2009UP}
+ SetUnicodeString(ItemNo, Data);
+ {$ELSE}
+ SetAnsiString(ItemNo, Data);
+ {$ENDIF}
+end;
+
+
+procedure TPSStack.SetUInt(ItemNo: Longint; const Data: Cardinal);
+var
+ val: PPSVariant;
+ ok: Boolean;
+begin
+ if ItemNo < 0 then
+ val := items[Longint(ItemNo) + Longint(Count)]
+ else
+ val := items[ItemNo];
+ ok := true;
+ PSSetUInt(@PPSVariantData(val).Data, val.FType, ok, Data);
+ if not ok then raise Exception.Create(RPS_TypeMismatch);
+end;
+
+
+{$IFNDEF PS_NOWIDESTRING}
+procedure TPSStack.SetUnicodeString(ItemNo: Integer;
+ const Data: tbtunicodestring);
+var
+ val: PPSVariant;
+ ok: Boolean;
+begin
+ if ItemNo < 0 then
+ val := items[Longint(ItemNo) + Longint(Count)]
+ else
+ val := items[ItemNo];
+ ok := true;
+ PSSetUnicodeString(@PPSVariantData(val).Data, val.FType, ok, Data);
+end;
+
+procedure TPSStack.SetWideString(ItemNo: Longint;
+ const Data: tbtWideString);
+var
+ val: PPSVariant;
+ ok: Boolean;
+begin
+ if ItemNo < 0 then
+ val := items[Longint(ItemNo) + Longint(Count)]
+ else
+ val := items[ItemNo];
+ ok := true;
+ PSSetWideString(@PPSVariantData(val).Data, val.FType, ok, Data);
+ if not ok then raise Exception.Create(RPS_TypeMismatch);
+end;
+{$ENDIF}
+
+
+{$IFNDEF PS_NOIDISPATCH}
+var
+ DispPropertyPut: Integer = DISPID_PROPERTYPUT;
+const
+ LOCALE_SYSTEM_DEFAULT = 2 shl 10; // Delphi 2 doesn't define this
+
+function IDispatchInvoke(Self: IDispatch; PropertySet: Boolean; const Name: tbtString; const Par: array of Variant): Variant;
+var
+ Param: Word;
+ i, ArgErr: Longint;
+ DispatchId: Longint;
+ DispParam: TDispParams;
+ ExceptInfo: TExcepInfo;
+ aName: PWideChar;
+ WSFreeList: TPSList;
+begin
+ FillChar(ExceptInfo, SizeOf(ExceptInfo), 0);
+ if Name='' then begin
+ DispatchId:=0;
+ end else begin
+ aName := StringToOleStr(Name);
+ try
+ if Self = nil then
+ raise Exception.Create(RPS_NILInterfaceException);
+ if Self.GetIDsOfNames(GUID_NULL, @aName, 1, LOCALE_SYSTEM_DEFAULT, @DispatchId) <> S_OK then
+ raise Exception.Create(RPS_UnknownMethod);
+ finally
+ SysFreeString(aName);
+ end;
+ end;
+ DispParam.cNamedArgs := 0;
+ DispParam.rgdispidNamedArgs := nil;
+ DispParam.cArgs := (High(Par) + 1);
+
+ if PropertySet then
+ begin
+ Param := DISPATCH_PROPERTYPUT;
+ DispParam.cNamedArgs := 1;
+ DispParam.rgdispidNamedArgs := @DispPropertyPut;
+ end else
+ Param := DISPATCH_METHOD or DISPATCH_PROPERTYGET;
+
+ WSFreeList := TPSList.Create;
+ try
+ GetMem(DispParam.rgvarg, sizeof(TVariantArg) * (High(Par) + 1));
+ FillCHar(DispParam.rgvarg^, sizeof(TVariantArg) * (High(Par) + 1), 0);
+ try
+ for i := 0 to High(Par) do
+ begin
+ if PVarData(@Par[High(Par)-i]).VType = varString then
+ begin
+ DispParam.rgvarg[i].vt := VT_BSTR;
+ DispParam.rgvarg[i].bstrVal := StringToOleStr(AnsiString(Par[High(Par)-i]));
+ WSFreeList.Add(DispParam.rgvarg[i].bstrVal);
+ {$IFDEF UNICODE}
+ end else if (PVarData(@Par[High(Par)-i]).VType = varOleStr) or (PVarData(@Par[High(Par)-i]).VType = varUString) then
+ begin
+ DispParam.rgvarg[i].vt := VT_BSTR;
+ DispParam.rgvarg[i].bstrVal := StringToOleStr(UnicodeString(Par[High(Par)-i]));
+ WSFreeList.Add(DispParam.rgvarg[i].bstrVal);
+ {$ENDIF}
+ end else
+ begin
+ DispParam.rgvarg[i].vt := VT_VARIANT or VT_BYREF;
+ New(
+ {$IFDEF DELPHI4UP}
+ POleVariant
+ {$ELSE}
+ PVariant{$ENDIF}
+ (DispParam.rgvarg[i].pvarVal));
+
+ (*
+ {$IFDEF DELPHI4UP}
+ POleVariant
+ {$ELSE}
+ PVariant
+ {$ENDIF}
+ (DispParam.rgvarg[i].pvarVal)^ := Par[High(Par)-i];
+ *)
+ Move(Par[High(Par)-i],Pointer(DispParam.rgvarg[i].pvarVal)^,
+ Sizeof({$IFDEF DELPHI4UP}OleVariant{$ELSE}Variant{$ENDIF}));
+
+ end;
+ end;
+ i :=Self.Invoke(DispatchId, GUID_NULL, LOCALE_SYSTEM_DEFAULT, Param, DispParam, @Result, @ExceptInfo, @ArgErr);
+ {$IFNDEF Delphi3UP}
+ try
+ if not Succeeded(i) then
+ begin
+ if i = DISP_E_EXCEPTION then
+ raise Exception.Create(OleStrToString(ExceptInfo.bstrSource)+': '+OleStrToString(ExceptInfo.bstrDescription))
+ else
+ raise Exception.Create(SysErrorMessage(i));
+ end;
+ finally
+ SysFreeString(ExceptInfo.bstrSource);
+ SysFreeString(ExceptInfo.bstrDescription);
+ SysFreeString(ExceptInfo.bstrHelpFile);
+ end;
+ {$ELSE}
+ if not Succeeded(i) then
+ begin
+ if i = DISP_E_EXCEPTION then
+ raise Exception.Create(ExceptInfo.bstrSource+': '+ExceptInfo.bstrDescription)
+ else
+ raise Exception.Create(SysErrorMessage(i));
+ end;
+ {$ENDIF}
+ finally
+ for i := 0 to High(Par) do
+ begin
+ if DispParam.rgvarg[i].vt = (VT_VARIANT or VT_BYREF) then
+ begin
+ if{$IFDEF DELPHI4UP}POleVariant{$ELSE}PVariant{$ENDIF}
+ (DispParam.rgvarg[i].pvarVal) <> nil then
+ Dispose(
+ {$IFDEF DELPHI4UP}
+ POleVariant
+ {$ELSE}
+ PVariant
+ {$ENDIF}
+ (DispParam.rgvarg[i].pvarVal));
+ end;
+ end;
+ FreeMem(DispParam.rgvarg, sizeof(TVariantArg) * (High(Par) + 1));
+ end;
+ finally
+ for i := WSFreeList.Count -1 downto 0 do
+ SysFreeString(WSFreeList[i]);
+ WSFreeList.Free;
+ end;
+end;
+{$ENDIF}
+
+
+{ TPSTypeRec_ProcPtr }
+
+procedure TPSTypeRec_ProcPtr.CalcSize;
+begin
+ FRealSize := 2 * sizeof(Pointer) + Sizeof(Cardinal);
+end;
+
+end.
+
diff --git a/Units/PascalScript/uPSUtils.pas b/Units/PascalScript/uPSUtils.pas
new file mode 100644
index 0000000..76f2d48
--- /dev/null
+++ b/Units/PascalScript/uPSUtils.pas
@@ -0,0 +1,1592 @@
+unit uPSUtils;
+{$I PascalScript.inc}
+
+interface
+uses
+ Classes, SysUtils {$IFDEF VER130}, Windows {$ENDIF};
+
+const
+
+ PSMainProcName = '!MAIN';
+
+ PSMainProcNameOrg = 'Main Proc';
+
+ PSLowBuildSupport = 12;
+
+ PSCurrentBuildNo = 23;
+
+ PSCurrentversion = '1.31';
+
+ PSValidHeader = 1397769801;
+
+ PSAddrStackStart = 1610612736;
+
+ PSAddrNegativeStackStart = 1073741824;
+type
+ TbtString = {$IFDEF DELPHI2009UP}AnsiString{$ELSE}String{$ENDIF};
+
+ TPSBaseType = Byte;
+
+ TPSVariableType = (ivtGlobal, ivtParam, ivtVariable);
+
+const
+
+ btReturnAddress = 0;
+
+ btU8 = 1;
+
+ btS8 = 2;
+
+ btU16 = 3;
+
+ btS16 = 4;
+
+ btU32 = 5;
+
+ btS32 = 6;
+
+ btSingle = 7;
+
+ btDouble = 8;
+
+ btExtended = 9;
+
+ btString = 10;
+
+ btRecord = 11;
+
+ btArray = 12;
+
+ btPointer = 13;
+
+ btPChar = 14;
+
+ btResourcePointer = 15;
+
+ btVariant = 16;
+
+{$IFNDEF PS_NOINT64}
+ btS64 = 17;
+{$ENDIF}
+
+ btChar = 18;
+
+{$IFNDEF PS_NOWIDESTRING}
+ btWideString = 19;
+
+ btWideChar = 20;
+{$ENDIF}
+
+ btProcPtr = 21;
+
+ btStaticArray = 22;
+
+ btSet = 23;
+
+ btCurrency = 24;
+
+ btClass = 25;
+
+ btInterface = 26;
+
+ btNotificationVariant = 27;
+
+ btUnicodeString = 28;
+
+ btType = 130;
+
+ btEnum = 129;
+
+ btExtClass = 131;
+
+function MakeHash(const s: TbtString): Longint;
+
+const
+{ Script internal command: Assign command
+ 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;
+
+{$IFNDEF PS_NOINT64}
+
+ tbts64 = int64;
+{$ENDIF}
+
+ tbtchar = {$IFDEF DELPHI4UP}AnsiChar{$ELSE}CHAR{$ENDIF};
+{$IFNDEF PS_NOWIDESTRING}
+
+ tbtwidestring = widestring;
+ tbtunicodestring = {$IFDEF DELPHI2009UP}UnicodeString{$ELSE}widestring{$ENDIF};
+
+ tbtwidechar = widechar;
+ tbtNativeString = {$IFDEF DELPHI2009UP}tbtUnicodeString{$ELSE}tbtString{$ENDIF};
+{$ENDIF}
+{$IFDEF FPC}
+ IPointer = PtrUInt;
+{$ELSE}
+ {$IFDEF CPU64} IPointer = LongWord;{$ELSE} IPointer = Cardinal;{$ENDIF}
+{$ENDIF}
+ TPSCallingConvention = (cdRegister, cdPascal, cdCdecl, cdStdCall, cdSafeCall);
+
+
+const
+
+ PointerSize = IPointer({$IFDEF CPU64}8{$ELSE}4{$ENDIF});
+ PointerSize2 = IPointer(2*PointerSize);
+ MaxListSize = Maxint div 16;
+
+type
+
+ PPointerList = ^TPointerList;
+
+ TPointerList = array[0..MaxListSize - 1] of Pointer;
+
+
+ TPSList = class(TObject)
+ protected
+
+ FData: PPointerList;
+
+ FCapacity: Cardinal;
+
+ FCount: Cardinal;
+
+ FCheckCount: Cardinal;
+ private
+ function GetItem(Nr: Cardinal): Pointer;
+ procedure SetItem(Nr: Cardinal; P: Pointer);
+ public
+ {$IFNDEF PS_NOSMARTLIST}
+
+ procedure Recreate;
+ {$ENDIF}
+
+ property Data: PPointerList read FData;
+
+ constructor Create;
+
+ function IndexOf(P: Pointer): Longint;
+
+ destructor Destroy; override;
+
+ property Count: Cardinal read FCount;
+
+ property Items[nr: Cardinal]: Pointer read GetItem write SetItem; default;
+
+ function Add(P: Pointer): Longint;
+
+ procedure AddBlock(List: PPointerList; Count: Longint);
+
+ procedure Remove(P: Pointer);
+
+ procedure Delete(Nr: Cardinal);
+
+ procedure DeleteLast;
+
+ procedure Clear; virtual;
+ end;
+ TIFList = TPSList;
+
+ TPSStringList = class(TObject)
+ private
+ List: TPSList;
+ function GetItem(Nr: LongInt): TbtString;
+ procedure SetItem(Nr: LongInt; const s: TbtString);
+ public
+
+ function Count: LongInt;
+
+ property Items[Nr: Longint]: TbtString read GetItem write SetItem; default;
+
+
+ procedure Add(const P: TbtString);
+
+ procedure Delete(NR: LongInt);
+
+ procedure Clear;
+
+ constructor Create;
+
+ destructor Destroy; override;
+ end;
+ TIFStringList = TPsStringList;
+
+
+type
+
+ TPSPasToken = (
+ CSTI_EOF,
+
+ CSTIINT_Comment,
+ CSTIINT_WhiteSpace,
+
+ CSTI_Identifier,
+ CSTI_SemiColon,
+ CSTI_Comma,
+ CSTI_Period,
+ CSTI_Colon,
+ CSTI_OpenRound,
+ CSTI_CloseRound,
+ CSTI_OpenBlock,
+ CSTI_CloseBlock,
+ CSTI_Assignment,
+ CSTI_Equal,
+ CSTI_NotEqual,
+ CSTI_Greater,
+ CSTI_GreaterEqual,
+ CSTI_Less,
+ CSTI_LessEqual,
+ CSTI_Plus,
+ CSTI_Minus,
+ CSTI_Divide,
+ CSTI_Multiply,
+ CSTI_Integer,
+ CSTI_Real,
+ CSTI_String,
+ CSTI_Char,
+ CSTI_HexInt,
+ CSTI_AddressOf,
+ CSTI_Dereference,
+ CSTI_TwoDots,
+
+ CSTII_and,
+ CSTII_array,
+ CSTII_begin,
+ CSTII_case,
+ CSTII_const,
+ CSTII_div,
+ CSTII_do,
+ CSTII_downto,
+ CSTII_else,
+ CSTII_end,
+ CSTII_for,
+ CSTII_function,
+ CSTII_if,
+ CSTII_in,
+ CSTII_mod,
+ CSTII_not,
+ CSTII_of,
+ CSTII_or,
+ CSTII_procedure,
+ CSTII_program,
+ CSTII_repeat,
+ CSTII_record,
+ CSTII_set,
+ CSTII_shl,
+ CSTII_shr,
+ CSTII_then,
+ CSTII_to,
+ CSTII_type,
+ CSTII_until,
+ CSTII_uses,
+ CSTII_var,
+ CSTII_while,
+ CSTII_with,
+ CSTII_xor,
+ CSTII_exit,
+ CSTII_class,
+ CSTII_constructor,
+ CSTII_destructor,
+ CSTII_inherited,
+ CSTII_private,
+ CSTII_public,
+ CSTII_published,
+ CSTII_protected,
+ CSTII_property,
+ CSTII_virtual,
+ CSTII_override,
+ //CSTII_default, //Birb
+ CSTII_As,
+ CSTII_Is,
+ CSTII_Unit,
+ CSTII_Try,
+ CSTII_Except,
+ CSTII_Finally,
+ CSTII_External,
+ CSTII_Forward,
+ CSTII_Export,
+ CSTII_Label,
+ CSTII_Goto,
+ CSTII_Chr,
+ CSTII_Ord,
+ CSTII_Interface,
+ CSTII_Implementation,
+ CSTII_initialization, //* Nvds
+ CSTII_finalization, //* Nvds
+ CSTII_out,
+ CSTII_nil
+ );
+
+ TPSParserErrorKind = (iNoError
+ , iCommentError
+ , iStringError
+ , iCharError
+ , iSyntaxError
+ );
+ TPSParserErrorEvent = procedure (Parser: TObject; Kind: TPSParserErrorKind) of object;
+
+
+ TPSPascalParser = class(TObject)
+ protected
+ FData: TbtString;
+ FText: {$IFDEF DELPHI4UP}PAnsiChar{$ELSE}PChar{$ENDIF};
+ FLastEnterPos, FRow, FRealPosition, FTokenLength: Cardinal;
+ FTokenId: TPSPasToken;
+ FToken: TbtString;
+ FOriginalToken: TbtString;
+ FParserError: TPSParserErrorEvent;
+ FEnableComments: Boolean;
+ FEnableWhitespaces: Boolean;
+ function GetCol: Cardinal;
+ // only applicable when Token in [CSTI_Identifier, CSTI_Integer, CSTI_Real, CSTI_String, CSTI_Char, CSTI_HexInt]
+ public
+
+ property EnableComments: Boolean read FEnableComments write FEnableComments;
+
+ property EnableWhitespaces: Boolean read FEnableWhitespaces write FEnableWhitespaces;
+
+ procedure Next; virtual;
+
+ property GetToken: TbtString read FToken;
+
+ property OriginalToken: TbtString read FOriginalToken;
+
+ property CurrTokenPos: Cardinal read FRealPosition;
+
+ property CurrTokenID: TPSPasToken read FTokenId;
+
+ property Row: Cardinal read FRow;
+
+ property Col: Cardinal read GetCol;
+
+ procedure SetText(const Data: TbtString); virtual;
+
+ property OnParserError: TPSParserErrorEvent read FParserError write FParserError;
+ end;
+
+function FloatToStr(E: Extended): TbtString;
+
+function FastLowerCase(const s: TbtString): TbtString;
+
+function Fw(const S: TbtString): TbtString;
+
+function IntToStr(I: LongInt): TbtString;
+
+function StrToIntDef(const S: TbtString; Def: LongInt): LongInt;
+
+function StrToInt(const S: TbtString): LongInt;
+function StrToFloat(const s: TbtString): Extended;
+
+function FastUpperCase(const s: TbtString): TbtString;
+
+function GRFW(var s: TbtString): TbtString;
+function GRLW(var s: TbtString): TbtString;
+
+const
+
+ FCapacityInc = 32;
+{$IFNDEF PS_NOSMARTLIST}
+
+ FMaxCheckCount = (FCapacityInc div 4) * 64;
+{$ENDIF}
+
+{$IFDEF VER130}
+function WideUpperCase(const S: WideString): WideString;
+function WideLowerCase(const S: WideString): WideString;
+{$ENDIF}
+implementation
+
+{$IFDEF DELPHI3UP }
+resourceString
+{$ELSE }
+const
+{$ENDIF }
+ RPS_InvalidFloat = 'Invalid float';
+
+{$IFDEF VER130}
+
+function WideUpperCase(const S: WideString): WideString;
+var
+ Len: Integer;
+begin
+ // CharUpperBuffW is stubbed out on Win9x platofmrs
+ if Win32Platform = VER_PLATFORM_WIN32_NT then
+ begin
+ Len := Length(S);
+ SetString(Result, PWideChar(S), Len);
+ if Len > 0 then CharUpperBuffW(Pointer(Result), Len);
+ end
+ else
+ Result := AnsiUpperCase(S);
+end;
+
+function WideLowerCase(const S: WideString): WideString;
+var
+ Len: Integer;
+begin
+ // CharLowerBuffW is stubbed out on Win9x platofmrs
+ if Win32Platform = VER_PLATFORM_WIN32_NT then
+ begin
+ Len := Length(S);
+ SetString(Result, PWideChar(S), Len);
+ if Len > 0 then CharLowerBuffW(Pointer(Result), Len);
+ end
+ else
+ Result := AnsiLowerCase(S);
+end;
+
+{$ENDIF}
+
+
+function MakeHash(const s: TbtString): Longint;
+{small hash maker}
+var
+ I: Integer;
+begin
+ Result := 0;
+ for I := 1 to Length(s) do
+ Result := ((Result shl 7) or (Result shr 25)) + Ord(s[I]);
+end;
+
+function GRFW(var s: TbtString): TbtString;
+var
+ l: Longint;
+begin
+ l := 1;
+ while l <= Length(s) do
+ begin
+ if s[l] = ' ' then
+ begin
+ Result := copy(s, 1, l - 1);
+ Delete(s, 1, l);
+ exit;
+ end;
+ l := l + 1;
+ end;
+ Result := s;
+ s := '';
+end;
+
+function GRLW(var s: TbtString): TbtString;
+var
+ l: Longint;
+begin
+ l := Length(s);
+ while l >= 1 do
+ begin
+ if s[l] = ' ' then
+ begin
+ Result := copy(s, l+1, MaxInt);
+ Delete(s, l, MaxInt);
+ exit;
+ end;
+ Dec(l);
+ end;
+ Result := s;
+ s := '';
+end;
+
+function StrToFloat(const s: TbtString): Extended;
+var
+ i: longint;
+begin
+ Val(string(s), Result, i);
+ if i <> 0 then raise Exception.Create(RPS_InvalidFloat);
+end;
+//-------------------------------------------------------------------
+
+function IntToStr(I: LongInt): TbtString;
+var
+ s: tbtstring;
+begin
+ Str(i, s);
+ IntToStr := s;
+end;
+//-------------------------------------------------------------------
+
+function FloatToStr(E: Extended): TbtString;
+var
+ s: tbtstring;
+begin
+ Str(e:0:12, s);
+ result := s;
+end;
+
+function StrToInt(const S: TbtString): LongInt;
+var
+ e: Integer;
+ Res: LongInt;
+begin
+ Val(string(S), Res, e);
+ if e <> 0 then
+ StrToInt := -1
+ else
+ StrToInt := Res;
+end;
+//-------------------------------------------------------------------
+
+function StrToIntDef(const S: TbtString; Def: LongInt): LongInt;
+var
+ e: Integer;
+ Res: LongInt;
+begin
+ Val(string(S), Res, e);
+ if e <> 0 then
+ StrToIntDef := Def
+ else
+ StrToIntDef := Res;
+end;
+//-------------------------------------------------------------------
+
+constructor TPSList.Create;
+begin
+ inherited Create;
+ FCount := 0;
+ FCapacity := 16;
+ {$IFNDEF PS_NOSMARTLIST}
+ FCheckCount := 0;
+ {$ENDIF}
+ GetMem(FData, FCapacity * PointerSize);
+end;
+
+
+function MM(i1,i2: Integer): Integer;
+begin
+ if ((i1 div i2) * i2) < i1 then
+ mm := (i1 div i2 + 1) * i2
+ else
+ mm := (i1 div i2) * i2;
+end;
+
+{$IFNDEF PS_NOSMARTLIST}
+procedure TPSList.Recreate;
+var
+ NewData: PPointerList;
+ NewCapacity: Cardinal;
+ I: Longint;
+
+begin
+
+ FCheckCount := 0;
+ NewCapacity := mm(FCount, FCapacityInc);
+ if NewCapacity < 64 then NewCapacity := 64;
+ GetMem(NewData, NewCapacity * PointerSize);
+ for I := 0 to Longint(FCount) -1 do
+ begin
+ NewData^[i] := FData^[I];
+ end;
+ FreeMem(FData, FCapacity * PointerSize);
+ FData := NewData;
+ FCapacity := NewCapacity;
+end;
+{$ENDIF}
+
+//-------------------------------------------------------------------
+
+function TPSList.Add(P: Pointer): Longint;
+begin
+ if FCount >= FCapacity then
+ begin
+ Inc(FCapacity, FCapacityInc);// := FCount + 1;
+ ReAllocMem(FData, FCapacity * PointerSize);
+ end;
+ FData[FCount] := P; // Instead of SetItem
+ Result := FCount;
+ Inc(FCount);
+{$IFNDEF PS_NOSMARTLIST}
+ Inc(FCheckCount);
+ if FCheckCount > FMaxCheckCount then Recreate;
+{$ENDIF}
+end;
+
+procedure TPSList.AddBlock(List: PPointerList; Count: Longint);
+var
+ L: Longint;
+
+begin
+ if Longint(FCount) + Count > Longint(FCapacity) then
+ begin
+ Inc(FCapacity, mm(Count, FCapacityInc));
+ ReAllocMem(FData, FCapacity *PointerSize);
+ end;
+ for L := 0 to Count -1 do
+ begin
+ FData^[FCount] := List^[L];
+ Inc(FCount);
+ end;
+{$IFNDEF PS_NOSMARTLIST}
+ Inc(FCheckCount);
+ if FCheckCount > FMaxCheckCount then Recreate;
+{$ENDIF}
+end;
+
+
+//-------------------------------------------------------------------
+
+procedure TPSList.DeleteLast;
+begin
+ if FCount = 0 then Exit;
+ Dec(FCount);
+{$IFNDEF PS_NOSMARTLIST}
+ Inc(FCheckCount);
+ if FCheckCount > FMaxCheckCount then Recreate;
+{$ENDIF}
+end;
+
+
+
+procedure TPSList.Delete(Nr: Cardinal);
+begin
+ if FCount = 0 then Exit;
+ if Nr < FCount then
+ begin
+ Move(FData[Nr + 1], FData[Nr], (FCount - Nr) * PointerSize);
+ Dec(FCount);
+{$IFNDEF PS_NOSMARTLIST}
+ Inc(FCheckCount);
+ if FCheckCount > FMaxCheckCount then Recreate;
+{$ENDIF}
+ end;
+end;
+//-------------------------------------------------------------------
+
+procedure TPSList.Remove(P: Pointer);
+var
+ I: Cardinal;
+begin
+ if FCount = 0 then Exit;
+ I := 0;
+ while I < FCount do
+ begin
+ if FData[I] = P then
+ begin
+ Delete(I);
+ Exit;
+ end;
+ Inc(I);
+ end;
+end;
+//-------------------------------------------------------------------
+
+procedure TPSList.Clear;
+begin
+ FCount := 0;
+{$IFNDEF PS_NOSMARTLIST}
+ Recreate;
+{$ENDIF}
+end;
+//-------------------------------------------------------------------
+
+destructor TPSList.Destroy;
+begin
+ FreeMem(FData, FCapacity * PointerSize);
+ inherited Destroy;
+end;
+//-------------------------------------------------------------------
+
+procedure TPSList.SetItem(Nr: Cardinal; P: Pointer);
+begin
+ if (FCount = 0) or (Nr >= FCount) then
+ Exit;
+ FData[Nr] := P;
+end;
+//-------------------------------------------------------------------
+
+function TPSList.GetItem(Nr: Cardinal): Pointer; {12}
+begin
+ if Nr < FCount then
+ GetItem := FData[Nr]
+ else
+ GetItem := nil;
+end;
+
+
+
+//-------------------------------------------------------------------
+
+function TPSStringList.Count: LongInt;
+begin
+ count := List.count;
+end;
+type pStr = ^TbtString;
+
+//-------------------------------------------------------------------
+
+function TPSStringList.GetItem(Nr: LongInt): TbtString;
+var
+ S: PStr;
+begin
+ s := List.GetItem(Nr);
+ if s = nil then
+ Result := ''
+ else
+
+ Result := s^;
+end;
+//-------------------------------------------------------------------
+
+
+procedure TPSStringList.SetItem(Nr: LongInt; const s: TbtString);
+var
+ p: PStr;
+begin
+ p := List.GetItem(Nr);
+ if p = nil
+ then
+ Exit;
+ p^ := s;
+end;
+//-------------------------------------------------------------------
+
+procedure TPSStringList.Add(const P: TbtString);
+var
+ w: PStr;
+begin
+ new(w);
+ w^ := p;
+ List.Add(w);
+end;
+//-------------------------------------------------------------------
+
+procedure TPSStringList.Delete(NR: LongInt);
+var
+ W: PStr;
+begin
+ W := list.getitem(nr);
+ if w<>nil then
+ begin
+ dispose(w);
+ end;
+ list.Delete(Nr);
+end;
+
+procedure TPSStringList.Clear;
+begin
+ while List.Count > 0 do Delete(0);
+end;
+
+constructor TPSStringList.Create;
+begin
+ inherited Create;
+ List := TPSList.Create;
+end;
+
+destructor TPSStringList.Destroy;
+begin
+ while List.Count > 0 do
+ Delete(0);
+ List.Destroy;
+ inherited Destroy;
+end;
+
+//-------------------------------------------------------------------
+
+
+function Fw(const S: TbtString): TbtString; // First word
+var
+ x: integer;
+begin
+ x := pos(tbtstring(' '), s);
+ if x > 0
+ then Fw := Copy(S, 1, x - 1)
+ else Fw := S;
+end;
+//-------------------------------------------------------------------
+function FastUpperCase(const s: TbtString): TbtString;
+{Fast uppercase}
+var
+ I: Integer;
+ C: tbtChar;
+begin
+ Result := S;
+ I := Length(Result);
+ while I > 0 do
+ begin
+ C := Result[I];
+ if c in [#97..#122] then
+ Result[I] := tbtchar(Ord(Result[I]) -32);
+ Dec(I);
+ end;
+end;
+function FastLowerCase(const s: TbtString): TbtString;
+{Fast lowercase}
+var
+ I: Integer;
+ C: tbtChar;
+begin
+ Result := S;
+ I := Length(Result);
+ while I > 0 do
+ begin
+ C := Result[I];
+ if C in [#65..#90] then
+ Result[I] := tbtchar(Ord(Result[I]) + 32);
+ Dec(I);
+ end;
+end;
+//-------------------------------------------------------------------
+
+type
+ TRTab = record
+ name: TbtString;
+ c: TPSPasToken;
+ end;
+
+
+const
+ KEYWORD_COUNT = 65; //*NVDS
+ LookupTable: array[0..KEYWORD_COUNT - 1] of TRTab = (
+ (name: 'AND'; c: CSTII_and),
+ (name: 'ARRAY'; c: CSTII_array),
+ (name: 'AS'; c: CSTII_as),
+ (name: 'BEGIN'; c: CSTII_begin),
+ (name: 'CASE'; c: CSTII_case),
+ (name: 'CHR'; c: CSTII_chr),
+ (name: 'CLASS'; c: CSTII_class),
+ (name: 'CONST'; c: CSTII_const),
+ (name: 'CONSTRUCTOR'; c: CSTII_constructor),
+ (name: 'DESTRUCTOR'; c: CSTII_destructor),
+ (name: 'DIV'; c: CSTII_div),
+ (name: 'DO'; c: CSTII_do),
+ (name: 'DOWNTO'; c: CSTII_downto),
+ (name: 'ELSE'; c: CSTII_else),
+ (name: 'END'; c: CSTII_end),
+ (name: 'EXCEPT'; c: CSTII_except),
+ (name: 'EXIT'; c: CSTII_exit),
+ (name: 'EXPORT'; c: CSTII_Export),
+ (name: 'EXTERNAL'; c: CSTII_External),
+ (Name: 'FINALIZATION'; c : CSTII_finalization),//* Nvds
+ (name: 'FINALLY'; c: CSTII_finally),
+ (name: 'FOR'; c: CSTII_for),
+ (name: 'FORWARD'; c: CSTII_Forward),
+ (name: 'FUNCTION'; c: CSTII_function),
+ (name: 'GOTO'; c: CSTII_Goto),
+ (name: 'IF'; c: CSTII_if),
+ (name: 'IMPLEMENTATION'; c: CSTII_Implementation),
+ (name: 'IN'; c: CSTII_in),
+ (name: 'INHERITED'; c: CSTII_inherited),
+ (Name: 'INITIALIZATION'; c: CSTII_initialization), //* Nvds
+ (name: 'INTERFACE'; c: CSTII_Interface),
+ (name: 'IS'; c: CSTII_is),
+ (name: 'LABEL'; c: CSTII_Label),
+ (name: 'MOD'; c: CSTII_mod),
+ (name: 'NIL'; c: CSTII_nil),
+ (name: 'NOT'; c: CSTII_not),
+ (name: 'OF'; c: CSTII_of),
+ (name: 'OR'; c: CSTII_or),
+ (name: 'ORD'; c: CSTII_ord),
+ (name: 'OUT'; c: CSTII_Out),
+ (name: 'OVERRIDE'; c: CSTII_override),
+ //(name: 'DEFAULT'; c: CSTII_default), //Birb (if added, don't forget to increase KEYWORD_COUNT)
+ (name: 'PRIVATE'; c: CSTII_private),
+ (name: 'PROCEDURE'; c: CSTII_procedure),
+ (name: 'PROGRAM'; c: CSTII_program),
+ (name: 'PROPERTY'; c: CSTII_property),
+ (name: 'PROTECTED'; c: CSTII_protected),
+ (name: 'PUBLIC'; c: CSTII_public),
+ (name: 'PUBLISHED'; c: CSTII_published),
+ (name: 'RECORD'; c: CSTII_record),
+ (name: 'REPEAT'; c: CSTII_repeat),
+ (name: 'SET'; c: CSTII_set),
+ (name: 'SHL'; c: CSTII_shl),
+ (name: 'SHR'; c: CSTII_shr),
+ (name: 'THEN'; c: CSTII_then),
+ (name: 'TO'; c: CSTII_to),
+ (name: 'TRY'; c: CSTII_try),
+ (name: 'TYPE'; c: CSTII_type),
+ (name: 'UNIT'; c: CSTII_Unit),
+ (name: 'UNTIL'; c: CSTII_until),
+ (name: 'USES'; c: CSTII_uses),
+ (name: 'VAR'; c: CSTII_var),
+ (name: 'VIRTUAL'; c: CSTII_virtual),
+ (name: 'WHILE'; c: CSTII_while),
+ (name: 'WITH'; c: CSTII_with),
+ (name: 'XOR'; c: CSTII_xor));
+
+function TPSPascalParser.GetCol: Cardinal;
+begin
+ Result := FRealPosition - FLastEnterPos + 1;
+end;
+
+procedure TPSPascalParser.Next;
+var
+ Err: TPSParserErrorKind;
+ FLastUpToken: TbtString;
+ function CheckReserved(Const S: ShortString; var CurrTokenId: TPSPasToken): Boolean;
+ var
+ L, H, I: LongInt;
+ J: tbtChar;
+ SName: ShortString;
+ begin
+ L := 0;
+ J := S[0];
+ H := KEYWORD_COUNT-1;
+ while L <= H do
+ begin
+ I := (L + H) shr 1;
+ SName := LookupTable[i].Name;
+ if J = SName[0] then
+ begin
+ if S = SName then
+ begin
+ CheckReserved := True;
+ CurrTokenId := LookupTable[I].c;
+ Exit;
+ end;
+ if S > SName then
+ L := I + 1
+ else
+ H := I - 1;
+ end else
+ if S > SName then
+ L := I + 1
+ else
+ H := I - 1;
+ end;
+ CheckReserved := False;
+ end;
+ //-------------------------------------------------------------------
+
+ function _GetToken(CurrTokenPos, CurrTokenLen: Cardinal): TbtString;
+ var
+ s: tbtString;
+ begin
+ SetLength(s, CurrTokenLen);
+ Move(FText[CurrTokenPos], S[1], CurrtokenLen);
+ Result := s;
+ end;
+
+ function ParseToken(var CurrTokenPos, CurrTokenLen: Cardinal; var CurrTokenId: TPSPasToken): TPSParserErrorKind;
+ {Parse the token}
+ var
+ ct, ci: Cardinal;
+ hs: Boolean;
+ p: {$IFDEF DELPHI4UP}PAnsiChar{$ELSE}PChar{$ENDIF};
+ begin
+ ParseToken := iNoError;
+ ct := CurrTokenPos;
+ case FText[ct] of
+ #0:
+ begin
+ CurrTokenId := CSTI_EOF;
+ CurrTokenLen := 0;
+ end;
+ 'A'..'Z', 'a'..'z', '_':
+ begin
+ ci := ct + 1;
+ while (FText[ci] in ['_', '0'..'9', 'a'..'z', 'A'..'Z']) do begin
+ Inc(ci);
+ end;
+ CurrTokenLen := ci - ct;
+
+ FLastUpToken := _GetToken(CurrTokenPos, CurrtokenLen);
+ p := {$IFDEF DELPHI4UP}PAnsiChar{$ELSE}pchar{$ENDIF}(FLastUpToken);
+ while p^<>#0 do
+ begin
+ if p^ in [#97..#122] then
+ Dec(Byte(p^), 32);
+ inc(p);
+ end;
+ if not CheckReserved(FLastUpToken, CurrTokenId) then
+ begin
+ CurrTokenId := CSTI_Identifier;
+ end;
+ end;
+ '$':
+ begin
+ ci := ct + 1;
+
+ while (FText[ci] in ['0'..'9', 'a'..'f', 'A'..'F'])
+ do Inc(ci);
+
+ CurrTokenId := CSTI_HexInt;
+ CurrTokenLen := ci - ct;
+ end;
+
+ '0'..'9':
+ begin
+ hs := False;
+ ci := ct;
+ while (FText[ci] in ['0'..'9']) do
+ begin
+ Inc(ci);
+ if (FText[ci] = '.') and (not hs) then
+ begin
+ if FText[ci+1] = '.' then break;
+ hs := True;
+ Inc(ci);
+ end;
+ end;
+ if (FText[ci] in ['E','e']) and ((FText[ci+1] in ['0'..'9'])
+ or ((FText[ci+1] in ['+','-']) and (FText[ci+2] in ['0'..'9']))) then
+ begin
+ hs := True;
+ Inc(ci);
+ if FText[ci] in ['+','-'] then
+ Inc(ci);
+ repeat
+ Inc(ci);
+ until not (FText[ci] in ['0'..'9']);
+ end;
+
+ if hs
+ then CurrTokenId := CSTI_Real
+ else CurrTokenId := CSTI_Integer;
+
+ CurrTokenLen := ci - ct;
+ end;
+
+
+ #39:
+ begin
+ ci := ct + 1;
+ while true do
+ begin
+ if (FText[ci] = #0) or (FText[ci] = #13) or (FText[ci] = #10) then Break;
+ if (FText[ci] = #39) then
+ begin
+ if FText[ci+1] = #39 then
+ Inc(ci)
+ else
+ Break;
+ end;
+ Inc(ci);
+ end;
+ if FText[ci] = #39 then
+ CurrTokenId := CSTI_String
+ else
+ begin
+ CurrTokenId := CSTI_String;
+ ParseToken := iStringError;
+ end;
+ CurrTokenLen := ci - ct + 1;
+ end;
+ '#':
+ begin
+ ci := ct + 1;
+ if FText[ci] = '$' then
+ begin
+ inc(ci);
+ while (FText[ci] in ['A'..'F', 'a'..'f', '0'..'9']) do begin
+ Inc(ci);
+ end;
+ CurrTokenId := CSTI_Char;
+ CurrTokenLen := ci - ct;
+ end else
+ begin
+ while (FText[ci] in ['0'..'9']) do begin
+ Inc(ci);
+ end;
+ if FText[ci] in ['A'..'Z', 'a'..'z', '_'] then
+ begin
+ ParseToken := iCharError;
+ CurrTokenId := CSTI_Char;
+ end else
+ CurrTokenId := CSTI_Char;
+ CurrTokenLen := ci - ct;
+ end;
+ end;
+ '=':
+ begin
+ CurrTokenId := CSTI_Equal;
+ CurrTokenLen := 1;
+ end;
+ '>':
+ begin
+ if FText[ct + 1] = '=' then
+ begin
+ CurrTokenid := CSTI_GreaterEqual;
+ CurrTokenLen := 2;
+ end else
+ begin
+ CurrTokenid := CSTI_Greater;
+ CurrTokenLen := 1;
+ end;
+ end;
+ '<':
+ begin
+ if FText[ct + 1] = '=' then
+ begin
+ CurrTokenId := CSTI_LessEqual;
+ CurrTokenLen := 2;
+ end else
+ if FText[ct + 1] = '>' then
+ begin
+ CurrTokenId := CSTI_NotEqual;
+ CurrTokenLen := 2;
+ end else
+ begin
+ CurrTokenId := CSTI_Less;
+ CurrTokenLen := 1;
+ end;
+ end;
+ ')':
+ begin
+ CurrTokenId := CSTI_CloseRound;
+ CurrTokenLen := 1;
+ end;
+ '(':
+ begin
+ if FText[ct + 1] = '*' then
+ begin
+ ci := ct + 1;
+ while (FText[ci] <> #0) do begin
+ if (FText[ci] = '*') and (FText[ci + 1] = ')') then
+ Break;
+ if FText[ci] = #13 then
+ begin
+ inc(FRow);
+ if FText[ci+1] = #10 then
+ inc(ci);
+ FLastEnterPos := ci +1;
+ end else if FText[ci] = #10 then
+ begin
+ inc(FRow);
+ FLastEnterPos := ci +1;
+ end;
+ Inc(ci);
+ end;
+ if (FText[ci] = #0) then
+ begin
+ CurrTokenId := CSTIINT_Comment;
+ ParseToken := iCommentError;
+ end else
+ begin
+ CurrTokenId := CSTIINT_Comment;
+ Inc(ci, 2);
+ end;
+ CurrTokenLen := ci - ct;
+ end
+ else
+ begin
+ CurrTokenId := CSTI_OpenRound;
+ CurrTokenLen := 1;
+ end;
+ end;
+ '[':
+ begin
+ CurrTokenId := CSTI_OpenBlock;
+ CurrTokenLen := 1;
+ end;
+ ']':
+ begin
+ CurrTokenId := CSTI_CloseBlock;
+ CurrTokenLen := 1;
+ end;
+ ',':
+ begin
+ CurrTokenId := CSTI_Comma;
+ CurrTokenLen := 1;
+ end;
+ '.':
+ begin
+ if FText[ct + 1] = '.' then
+ begin
+ CurrTokenLen := 2;
+ CurrTokenId := CSTI_TwoDots;
+ end else
+ begin
+ CurrTokenId := CSTI_Period;
+ CurrTokenLen := 1;
+ end;
+ end;
+ '@':
+ begin
+ CurrTokenId := CSTI_AddressOf;
+ CurrTokenLen := 1;
+ end;
+ '^':
+ begin
+ CurrTokenId := CSTI_Dereference;
+ CurrTokenLen := 1;
+ end;
+ ';':
+ begin
+ CurrTokenId := CSTI_Semicolon;
+ CurrTokenLen := 1;
+ end;
+ ':':
+ begin
+ if FText[ct + 1] = '=' then
+ begin
+ CurrTokenId := CSTI_Assignment;
+ CurrTokenLen := 2;
+ end else
+ begin
+ CurrTokenId := CSTI_Colon;
+ CurrTokenLen := 1;
+ end;
+ end;
+ '+':
+ begin
+ CurrTokenId := CSTI_Plus;
+ CurrTokenLen := 1;
+ end;
+ '-':
+ begin
+ CurrTokenId := CSTI_Minus;
+ CurrTokenLen := 1;
+ end;
+ '*':
+ begin
+ CurrTokenId := CSTI_Multiply;
+ CurrTokenLen := 1;
+ end;
+ '/':
+ begin
+ if FText[ct + 1] = '/' then
+ begin
+ ci := ct + 1;
+ while (FText[ci] <> #0) and (FText[ci] <> #13) and
+ (FText[ci] <> #10) do begin
+ Inc(ci);
+ end;
+ if (FText[ci] = #0) then
+ begin
+ CurrTokenId := CSTIINT_Comment;
+ end else
+ begin
+ CurrTokenId := CSTIINT_Comment;
+ end;
+ CurrTokenLen := ci - ct;
+ end else
+ begin
+ CurrTokenId := CSTI_Divide;
+ CurrTokenLen := 1;
+ end;
+ end;
+ #32, #9, #13, #10:
+ begin
+ ci := ct;
+ while (FText[ci] in [#32, #9, #13, #10]) do
+ begin
+ if FText[ci] = #13 then
+ begin
+ inc(FRow);
+ if FText[ci+1] = #10 then
+ inc(ci);
+ FLastEnterPos := ci +1;
+ end else if FText[ci] = #10 then
+ begin
+ inc(FRow);
+ FLastEnterPos := ci +1;
+ end;
+ Inc(ci);
+ end;
+ CurrTokenId := CSTIINT_WhiteSpace;
+ CurrTokenLen := ci - ct;
+ end;
+ '{':
+ begin
+ ci := ct + 1;
+ while (FText[ci] <> #0) and (FText[ci] <> '}') do begin
+ if FText[ci] = #13 then
+ begin
+ inc(FRow);
+ if FText[ci+1] = #10 then
+ inc(ci);
+ FLastEnterPos := ci + 1;
+ end else if FText[ci] = #10 then
+ begin
+ inc(FRow);
+ FLastEnterPos := ci + 1;
+ end;
+ Inc(ci);
+ end;
+ if (FText[ci] = #0) then
+ begin
+ CurrTokenId := CSTIINT_Comment;
+ ParseToken := iCommentError;
+ end else
+ CurrTokenId := CSTIINT_Comment;
+ CurrTokenLen := ci - ct + 1;
+ end;
+ else
+ begin
+ ParseToken := iSyntaxError;
+ CurrTokenId := CSTIINT_Comment;
+ CurrTokenLen := 1;
+ end;
+ end;
+ end;
+ //-------------------------------------------------------------------
+begin
+ if FText = nil then
+ begin
+ FTokenLength := 0;
+ FRealPosition := 0;
+ FTokenId := CSTI_EOF;
+ Exit;
+ end;
+ repeat
+ FRealPosition := FRealPosition + Cardinal(FTokenLength);
+ Err := ParseToken(FRealPosition, Cardinal(FTokenLength), FTokenID);
+ if Err <> iNoError then
+ begin
+ FTokenLength := 0;
+ FTokenId := CSTI_EOF;
+ FToken := '';
+ FOriginalToken := '';
+ if @FParserError <> nil then FParserError(Self, Err);
+ exit;
+ end;
+
+ case FTokenID of
+ CSTIINT_Comment: if not FEnableComments then Continue else
+ begin
+ SetLength(FOriginalToken, FTokenLength);
+ Move(FText[CurrTokenPos], FOriginalToken[1], FTokenLength);
+ FToken := FOriginalToken;
+ end;
+ CSTIINT_WhiteSpace: if not FEnableWhitespaces then Continue else
+ begin
+ SetLength(FOriginalToken, FTokenLength);
+ Move(FText[CurrTokenPos], FOriginalToken[1], FTokenLength);
+ FToken := FOriginalToken;
+ end;
+ CSTI_Integer, CSTI_Real, CSTI_String, CSTI_Char, CSTI_HexInt:
+ begin
+ SetLength(FOriginalToken, FTokenLength);
+ Move(FText[CurrTokenPos], FOriginalToken[1], FTokenLength);
+ FToken := FOriginalToken;
+ end;
+ CSTI_Identifier:
+ begin
+ SetLength(FOriginalToken, FTokenLength);
+ Move(FText[CurrTokenPos], FOriginalToken[1], FTokenLength);
+ FToken := FLastUpToken;
+ end;
+ else
+ begin
+ FOriginalToken := '';
+ FToken := '';
+ end;
+ end;
+ Break;
+ until False;
+end;
+
+procedure TPSPascalParser.SetText(const Data: TbtString);
+begin
+ FData := Data;
+ FText := Pointer(FData);
+ FTokenLength := 0;
+ FRealPosition := 0;
+ FTokenId := CSTI_EOF;
+ FLastEnterPos := 0;
+ FRow := 1;
+ Next;
+end;
+
+function TPSList.IndexOf(P: Pointer): Longint;
+var
+ i: Integer;
+begin
+ for i := FCount -1 downto 0 do
+ begin
+ if FData[i] = p then
+ begin
+ result := i;
+ exit;
+ end;
+ end;
+ result := -1;
+end;
+
+end.
+
+
diff --git a/Units/PascalScript/uPS_ExtReg.pas b/Units/PascalScript/uPS_ExtReg.pas
new file mode 100644
index 0000000..b0dec7a
--- /dev/null
+++ b/Units/PascalScript/uPS_ExtReg.pas
@@ -0,0 +1,17 @@
+unit uPS_ExtReg;
+
+interface
+
+procedure Register;
+
+implementation
+
+uses classes, uPSI_IBX, uPSI_Mask, upSI_JvMail, uPSI_Dialogs, uPSI_Registry;
+
+procedure Register;
+begin
+ RegisterComponents('Pascal Script', [TPSImport_IBX, TPSImport_Mask, TPSImport_JvMail,
+ TPSImport_Dialogs, TPSImport_Registry]);
+end;
+
+end.
diff --git a/Units/PascalScript/uROPSImports.pas b/Units/PascalScript/uROPSImports.pas
new file mode 100644
index 0000000..da70685
--- /dev/null
+++ b/Units/PascalScript/uROPSImports.pas
@@ -0,0 +1,366 @@
+unit uROPSImports;
+
+interface
+
+uses
+ uPSCompiler, uPSRuntime, uROBINMessage, uROIndyHTTPChannel,
+ uROXMLSerializer, uROIndyTCPChannel, idTcpClient,
+ uROPSServerLink, uROWinInetHttpChannel;
+
+
+procedure SIRegisterTROBINMESSAGE(CL: TIFPSPascalCompiler);
+procedure SIRegisterTROINDYHTTPCHANNEL(CL: TIFPSPascalCompiler);
+procedure SIRegisterTROINDYTCPCHANNEL(CL: TIFPSPascalCompiler);
+procedure SIRegisterTIDTCPCLIENT(CL: TIFPSPascalCompiler);
+procedure SIRegisterRODLImports(Cl: TIFPSPascalCompiler);
+
+
+
+procedure RIRegisterTROBINMESSAGE(Cl: TIFPSRuntimeClassImporter);
+procedure RIRegisterTROINDYHTTPCHANNEL(Cl: TIFPSRuntimeClassImporter);
+procedure RIRegisterTROINDYTCPCHANNEL(Cl: TIFPSRuntimeClassImporter);
+procedure RIRegisterTIDTCPCLIENT(Cl: TIFPSRuntimeClassImporter);
+procedure RIRegisterRODLImports(CL: TIFPSRuntimeClassImporter);
+(*
+Todo:
+ TROWinInetHTTPChannel = class(TROTransportChannel, IROTransport, IROTCPTransport, IROHTTPTransport)
+ published
+ property UserAgent:string read GetUserAgent write SetUserAgent;
+ property TargetURL : string read fTargetURL write SetTargetURL;
+ property StoreConnected:boolean read fStoreConnected write fStoreConnected default false;
+ property KeepConnection:boolean read fKeepConnection write fKeepConnection default false;
+ end;
+*)
+type
+
+ TPSROIndyTCPModule = class(TPSROModule)
+ protected
+ class procedure ExecImp(exec: TIFPSExec; ri: TIFPSRuntimeClassImporter); override;
+ class procedure CompImp(comp: TIFPSPascalCompiler); override;
+ end;
+
+ TPSROIndyHTTPModule = class(TPSROModule)
+ protected
+ class procedure ExecImp(exec: TIFPSExec; ri: TIFPSRuntimeClassImporter); override;
+ class procedure CompImp(comp: TIFPSPascalCompiler); override;
+ end;
+
+ TPSROBinModule = class(TPSROModule)
+ protected
+ class procedure ExecImp(exec: TIFPSExec; ri: TIFPSRuntimeClassImporter); override;
+ class procedure CompImp(comp: TIFPSPascalCompiler); override;
+ end;
+
+
+implementation
+
+{procedure TROSOAPMESSAGESERIALIZATIONOPTIONS_W(Self: TROSOAPMESSAGE;
+ const T: TXMLSERIALIZATIONOPTIONS);
+begin
+ Self.SERIALIZATIONOPTIONS := T;
+end;
+
+procedure TROSOAPMESSAGESERIALIZATIONOPTIONS_R(Self: TROSOAPMESSAGE;
+ var T: TXMLSERIALIZATIONOPTIONS);
+begin
+ T := Self.SERIALIZATIONOPTIONS;
+end;
+
+procedure TROSOAPMESSAGECUSTOMLOCATION_W(Self: TROSOAPMESSAGE; const T: string);
+begin
+ Self.CUSTOMLOCATION := T;
+end;
+
+procedure TROSOAPMESSAGECUSTOMLOCATION_R(Self: TROSOAPMESSAGE; var T: string);
+begin
+ T := Self.CUSTOMLOCATION;
+end;
+
+procedure TROSOAPMESSAGELIBRARYNAME_W(Self: TROSOAPMESSAGE; const T: string);
+begin
+ Self.LIBRARYNAME := T;
+end;
+
+procedure TROSOAPMESSAGELIBRARYNAME_R(Self: TROSOAPMESSAGE; var T: string);
+begin
+ T := Self.LIBRARYNAME;
+end; }
+
+procedure TROBINMESSAGEUSECOMPRESSION_W(Self: TROBINMESSAGE; const T: boolean);
+begin
+ Self.USECOMPRESSION := T;
+end;
+
+procedure TROBINMESSAGEUSECOMPRESSION_R(Self: TROBINMESSAGE; var T: boolean);
+begin
+ T := Self.USECOMPRESSION;
+end;
+
+procedure TROINDYHTTPCHANNELTARGETURL_W(Self: TROINDYHTTPCHANNEL; const T: string);
+begin
+ Self.TARGETURL := T;
+end;
+
+procedure TROINDYHTTPCHANNELTARGETURL_R(Self: TROINDYHTTPCHANNEL; var T: string);
+begin
+ T := Self.TARGETURL;
+end;
+
+procedure TROINDYTCPCHANNELINDYCLIENT_R(Self: TROINDYTCPCHANNEL; var T: TIdTCPClientBaseClass);
+begin
+ T := Self.INDYCLIENT;
+end;
+
+procedure TIDTCPCLIENTPORT_W(Self: TIDTCPCLIENT; const T: integer);
+begin
+ Self.PORT := T;
+end;
+
+procedure TIDTCPCLIENTPORT_R(Self: TIdTCPClientBaseClass; var T: integer);
+begin
+ T := TIdIndy10HackClient(Self).PORT;
+end;
+
+procedure TIDTCPCLIENTHOST_W(Self: TIdTCPClientBaseClass; const T: string);
+begin
+ TIdIndy10HackClient(Self).HOST := T;
+end;
+
+procedure TIDTCPCLIENTHOST_R(Self: TIdTCPClientBaseClass; var T: string);
+begin
+ T := TIdIndy10HackClient(Self).HOST;
+end;
+
+{procedure TIDTCPCLIENTBOUNDPORT_W(Self: TIdTCPClientBaseClass; const T: integer);
+begin
+ Self.BOUNDPORT := T;
+end;
+
+procedure TIDTCPCLIENTBOUNDPORT_R(Self: TIdTCPClientBaseClass; var T: integer);
+begin
+ T := Self.BOUNDPORT;
+end;
+
+procedure TIDTCPCLIENTBOUNDIP_W(Self: TIdTCPClientBaseClass; const T: string);
+begin
+ Self.BOUNDIP := T;
+end;
+
+procedure TIDTCPCLIENTBOUNDIP_R(Self: TIdTCPClientBaseClass; var T: string);
+begin
+ T := Self.BOUNDIP;
+end;]
+
+procedure TIDTCPCLIENTBOUNDPORTMIN_W(Self: TIdTCPClientBaseClass; const T: integer);
+begin
+ Self.BOUNDPORTMIN := T;
+end;
+
+procedure TIDTCPCLIENTBOUNDPORTMIN_R(Self: TIdTCPClientBaseClass; var T: integer);
+begin
+ T := Self.BOUNDPORTMIN;
+end;
+
+procedure TIDTCPCLIENTBOUNDPORTMAX_W(Self: TIdTCPClientBaseClass; const T: integer);
+begin
+ Self.BOUNDPORTMAX := T;
+end;
+
+procedure TIDTCPCLIENTBOUNDPORTMAX_R(Self: TIdTCPClientBaseClass; var T: integer);
+begin
+ T := Self.BOUNDPORTMAX;
+end;
+
+{procedure RIRegisterTROSOAPMESSAGE(Cl: TIFPSRuntimeClassImporter);
+begin
+ with Cl.Add(TROSOAPMESSAGE) do
+ begin
+ RegisterPropertyHelper(@TROSOAPMESSAGELIBRARYNAME_R, @TROSOAPMESSAGELIBRARYNAME_W,
+ 'LIBRARYNAME');
+ RegisterPropertyHelper(@TROSOAPMESSAGECUSTOMLOCATION_R,
+ @TROSOAPMESSAGECUSTOMLOCATION_W, 'CUSTOMLOCATION');
+ RegisterPropertyHelper(@TROSOAPMESSAGESERIALIZATIONOPTIONS_R,
+ @TROSOAPMESSAGESERIALIZATIONOPTIONS_W, 'SERIALIZATIONOPTIONS');
+ end;
+end; }
+
+procedure RIRegisterTROBINMESSAGE(Cl: TIFPSRuntimeClassImporter);
+begin
+ with Cl.Add(TROBINMESSAGE) do
+ begin
+ RegisterPropertyHelper(@TROBINMESSAGEUSECOMPRESSION_R,
+ @TROBINMESSAGEUSECOMPRESSION_W, 'USECOMPRESSION');
+ end;
+end;
+
+procedure RIRegisterTROINDYHTTPCHANNEL(Cl: TIFPSRuntimeClassImporter);
+begin
+ with Cl.Add(TROINDYHTTPCHANNEL) do
+ begin
+ RegisterPropertyHelper(@TROINDYHTTPCHANNELTARGETURL_R,
+ @TROINDYHTTPCHANNELTARGETURL_W, 'TARGETURL');
+ end;
+end;
+
+procedure RIRegisterTROINDYTCPCHANNEL(Cl: TIFPSRuntimeClassImporter);
+begin
+ with Cl.Add(TROINDYTCPCHANNEL) do
+ begin
+ RegisterPropertyHelper(@TROINDYTCPCHANNELINDYCLIENT_R, nil, 'INDYCLIENT');
+ end;
+end;
+
+procedure RIRegisterTIDTCPCLIENT(Cl: TIFPSRuntimeClassImporter);
+begin
+ with Cl.Add(TIdTCPClientBaseClass) do
+ begin
+ {RegisterPropertyHelper(@TIDTCPCLIENTBOUNDPORTMAX_R, @TIDTCPCLIENTBOUNDPORTMAX_W,
+ 'BOUNDPORTMAX');
+ RegisterPropertyHelper(@TIDTCPCLIENTBOUNDPORTMIN_R, @TIDTCPCLIENTBOUNDPORTMIN_W,
+ 'BOUNDPORTMIN');
+ RegisterPropertyHelper(@TIDTCPCLIENTBOUNDIP_R, @TIDTCPCLIENTBOUNDIP_W, 'BOUNDIP');
+ RegisterPropertyHelper(@TIDTCPCLIENTBOUNDPORT_R, @TIDTCPCLIENTBOUNDPORT_W,
+ 'BOUNDPORT');}
+ RegisterPropertyHelper(@TIDTCPCLIENTHOST_R, @TIDTCPCLIENTHOST_W, 'HOST');
+ RegisterPropertyHelper(@TIDTCPCLIENTPORT_R, @TIDTCPCLIENTPORT_W, 'PORT');
+ end;
+end;
+
+procedure RIRegisterRODLImports(CL: TIFPSRuntimeClassImporter);
+begin
+ RIRegisterTIDTCPCLIENT(Cl);
+ RIRegisterTROINDYTCPCHANNEL(Cl);
+ RIRegisterTROINDYHTTPCHANNEL(Cl);
+ RIRegisterTROBINMESSAGE(Cl);
+ //RIRegisterTROSOAPMESSAGE(Cl);
+end;
+
+function RegClassS(cl: TIFPSPascalCompiler; const InheritsFrom,
+ ClassName: string): TPSCompileTimeClass;
+begin
+ Result := cl.FindClass(ClassName);
+ if Result = nil then
+ Result := cl.AddClassN(cl.FindClass(InheritsFrom), ClassName)
+ else
+ Result.ClassInheritsFrom := cl.FindClass(InheritsFrom);
+end;
+
+{procedure SIRegisterTROSOAPMESSAGE(CL: TIFPSPascalCompiler);
+begin
+ Cl.addTypeS('TXMLSERIALIZATIONOPTIONS', 'BYTE');
+ Cl.AddConstantN('XSOWRITEMULTIREFARRAY', 'BYTE').SetInt(1);
+ Cl.AddConstantN('XSOWRITEMULTIREFOBJECT', 'BYTE').SetInt(2);
+ Cl.AddConstantN('XSOSENDUNTYPED', 'BYTE').SetInt(4);
+ with RegClassS(cl, 'TROMESSAGE', 'TROSOAPMESSAGE') do
+ begin
+ RegisterProperty('LIBRARYNAME', 'STRING', iptrw);
+ RegisterProperty('CUSTOMLOCATION', 'STRING', iptrw);
+ RegisterProperty('SERIALIZATIONOPTIONS', 'TXMLSERIALIZATIONOPTIONS', iptrw);
+ end;
+end;}
+
+procedure SIRegisterTROBINMESSAGE(CL: TIFPSPascalCompiler);
+begin
+ with RegClassS(cl, 'TROMESSAGE', 'TROBINMESSAGE') do
+ begin
+ RegisterProperty('USECOMPRESSION', 'BOOLEAN', iptrw);
+ end;
+end;
+
+procedure SIRegisterTROINDYHTTPCHANNEL(CL: TIFPSPascalCompiler);
+begin
+ with RegClassS(cl, 'TROINDYTCPCHANNEL', 'TROINDYHTTPCHANNEL') do
+ begin
+ RegisterProperty('TARGETURL', 'STRING', iptrw);
+ end;
+end;
+
+procedure SIRegisterTROINDYTCPCHANNEL(CL: TIFPSPascalCompiler);
+begin
+ with RegClassS(cl, 'TROTRANSPORTCHANNEL', 'TROINDYTCPCHANNEL') do
+ begin
+ RegisterProperty('INDYCLIENT', 'TIdTCPClientBaseClass', iptr);
+ end;
+end;
+
+procedure SIRegisterTIDTCPCLIENT(CL: TIFPSPascalCompiler);
+begin
+ with RegClassS(cl, 'TCOMPONENT', 'TIdTCPClientBaseClass') do
+ begin
+ RegisterProperty('BOUNDPORTMAX', 'INTEGER', iptrw);
+ RegisterProperty('BOUNDPORTMIN', 'INTEGER', iptrw);
+ RegisterProperty('BOUNDIP', 'STRING', iptrw);
+ RegisterProperty('BOUNDPORT', 'INTEGER', iptrw);
+ RegisterProperty('HOST', 'STRING', iptrw);
+ RegisterProperty('PORT', 'INTEGER', iptrw);
+ end;
+end;
+
+procedure SIRegisterRODLImports(Cl: TIFPSPascalCompiler);
+begin
+ SIRegisterTIDTCPCLIENT(Cl);
+ SIRegisterTROINDYTCPCHANNEL(Cl);
+ SIRegisterTROINDYHTTPCHANNEL(Cl);
+ SIRegisterTROBINMESSAGE(Cl);
+ //SIRegisterTROSOAPMESSAGE(Cl);
+end;
+
+{ TPSROIndyTCPModule }
+
+class procedure TPSROIndyTCPModule.CompImp(comp: TIFPSPascalCompiler);
+begin
+ SIRegisterTIDTCPCLIENT(Comp);
+ SIRegisterTROINDYTCPCHANNEL(Comp);
+end;
+
+class procedure TPSROIndyTCPModule.ExecImp(exec: TIFPSExec;
+ ri: TIFPSRuntimeClassImporter);
+begin
+ RIRegisterTIDTCPCLIENT(ri);
+ RIRegisterTROINDYTCPCHANNEL(ri);
+end;
+
+{ TPSROIndyHTTPModule }
+
+class procedure TPSROIndyHTTPModule.CompImp(comp: TIFPSPascalCompiler);
+begin
+ if Comp.FindClass('TROINDYTCPCHANNEL') = nil then
+ TPSROIndyTCPModule.CompImp(Comp);
+ SIRegisterTROINDYHTTPCHANNEL(Comp);
+end;
+
+class procedure TPSROIndyHTTPModule.ExecImp(exec: TIFPSExec;
+ ri: TIFPSRuntimeClassImporter);
+begin
+ if ri.FindClass('TROINDYTCPCHANNEL') = nil then
+ TPSROIndyTCPModule.ExecImp(exec, ri);
+ RIRegisterTROINDYHTTPCHANNEL(ri);
+end;
+
+{ TPSROSoapModule }
+
+{class procedure TPSROSoapModule.CompImp(comp: TIFPSPascalCompiler);
+begin
+ SIRegisterTROSOAPMESSAGE(comp);
+end;
+
+class procedure TPSROSoapModule.ExecImp(exec: TIFPSExec;
+ ri: TIFPSRuntimeClassImporter);
+begin
+ RIRegisterTROSOAPMESSAGE(ri);
+end;}
+
+{ TPSROBinModule }
+
+class procedure TPSROBinModule.CompImp(comp: TIFPSPascalCompiler);
+begin
+ SIRegisterTROBINMESSAGE(Comp);
+end;
+
+class procedure TPSROBinModule.ExecImp(exec: TIFPSExec;
+ ri: TIFPSRuntimeClassImporter);
+begin
+ RIRegisterTROBINMESSAGE(ri);
+end;
+
+end.
diff --git a/Units/PascalScript/uROPSServerLink.pas b/Units/PascalScript/uROPSServerLink.pas
new file mode 100644
index 0000000..9501a29
--- /dev/null
+++ b/Units/PascalScript/uROPSServerLink.pas
@@ -0,0 +1,1231 @@
+unit uROPSServerLink;
+
+interface
+uses
+ SysUtils, Classes, uPSCompiler, uPSUtils, uPSRuntime,
+ uROServer, uROClient, uRODL{$IFDEF WIN32},
+ Windows{$ELSE}, Types{$ENDIF}, uROTypes, uROClientIntf,
+ uROSerializer, uPSComponent;
+
+type
+
+ TPSROModule = class
+ protected
+ class procedure ExecImp(exec: TPSExec; ri: TPSRuntimeClassImporter); virtual;
+ class procedure CompImp(comp: TPSPascalCompiler); virtual;
+ end;
+ TPSROModuleClass = class of TPSROModule;
+ TPSRemObjectsSdkPlugin = class;
+ TPSROModuleLoadEvent = procedure (Sender: TPSRemObjectsSdkPlugin) of object;
+
+ TPSRemObjectsSdkPlugin = class(TPSPlugin)
+ private
+ FRodl: TRODLLibrary;
+ FModules: TList;
+ FOnLoadModule: TPSROModuleLoadEvent;
+
+ FEnableIndyTCP: Boolean;
+ FEnableIndyHTTP: Boolean;
+ FEnableBinary: Boolean;
+ function GetHaveRodl: Boolean;
+ function MkStructName(Struct: TRODLStruct): string;
+ public
+ procedure CompileImport1(CompExec: TPSScript); override;
+ procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
+ protected
+ procedure Loaded; override;
+ public
+
+ procedure RODLLoadFromFile(const FileName: string);
+
+ procedure RODLLoadFromResource;
+
+ procedure RODLLoadFromStream(S: TStream);
+
+ procedure ClearRodl;
+
+ property HaveRodl: Boolean read GetHaveRodl;
+
+ constructor Create(AOwner: TComponent); override;
+
+ destructor Destroy; override;
+
+
+ procedure ReloadModules;
+
+ procedure RegisterModule(Module: TPSROModuleClass);
+ published
+ property OnLoadModule: TPSROModuleLoadEvent read FOnLoadModule write FOnLoadModule;
+
+ property EnableIndyTCP: Boolean read FEnableIndyTCP write FEnableIndyTCP default true;
+
+ property EnableIndyHTTP: Boolean read FEnableIndyHTTP write FEnableIndyHTTP default true;
+
+ property EnableBinary: Boolean read FEnableBinary write FEnableBinary default true;
+ end;
+
+implementation
+uses
+ uRODLToXML, uROPSImports;
+
+procedure SIRegisterTROTRANSPORTCHANNEL(CL: TPSPascalCompiler);
+Begin
+With cl.AddClassN(cl.FindClass('TComponent'), 'TROTRANSPORTCHANNEL') do
+ begin
+ end;
+end;
+
+procedure SIRegisterTROMESSAGE(CL: TPSPascalCompiler);
+Begin
+With cl.AddClassN(cl.FindClass('TComponent'),'TROMESSAGE') do
+ begin
+ RegisterProperty('MESSAGENAME', 'STRING', iptrw);
+ RegisterProperty('INTERFACENAME', 'STRING', iptrw);
+ end;
+end;
+
+procedure TROMESSAGEINTERFACENAME_W(Self: TROMESSAGE; const T: STRING);
+begin Self.INTERFACENAME := T; end;
+
+procedure TROMESSAGEINTERFACENAME_R(Self: TROMESSAGE; var T: STRING);
+begin T := Self.INTERFACENAME; end;
+
+procedure TROMESSAGEMESSAGENAME_W(Self: TROMESSAGE; const T: STRING);
+begin Self.MESSAGENAME := T; end;
+
+procedure TROMESSAGEMESSAGENAME_R(Self: TROMESSAGE; var T: STRING);
+begin T := Self.MESSAGENAME; end;
+
+procedure RIRegisterTROTRANSPORTCHANNEL(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TROTRANSPORTCHANNEL) do
+ begin
+ RegisterVirtualConstructor(@TROTRANSPORTCHANNEL.CREATE, 'CREATE');
+ end;
+end;
+
+procedure RIRegisterTROMESSAGE(Cl: TPSRuntimeClassImporter);
+Begin
+with Cl.Add(TROMESSAGE) do
+ begin
+ RegisterVirtualConstructor(@TROMESSAGE.CREATE, 'CREATE');
+ RegisterPropertyHelper(@TROMESSAGEMESSAGENAME_R,@TROMESSAGEMESSAGENAME_W,'MESSAGENAME');
+ RegisterPropertyHelper(@TROMESSAGEINTERFACENAME_R,@TROMESSAGEINTERFACENAME_W,'INTERFACENAME');
+ end;
+end;
+
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_TROBinaryMemoryStream(CL: TPSPascalCompiler);
+begin
+ //with RegClassS(CL,'TMemoryStream', 'TROBinaryMemoryStream') do
+ with CL.AddClassN(CL.FindClass('TMemoryStream'),'TROBinaryMemoryStream') do
+ begin
+ RegisterMethod('Constructor Create2( const iString : Ansistring);');
+ RegisterMethod('Constructor Create;');
+ RegisterMethod('Procedure Assign( iSource : TStream)');
+ RegisterMethod('Function Clone : TROBinaryMemoryStream');
+ RegisterMethod('Procedure LoadFromString( const iString : Ansistring)');
+ RegisterMethod('Procedure LoadFromHexString( const iString : Ansistring)');
+ RegisterMethod('Function ToString : AnsiString');
+ RegisterMethod('Function ToHexString : Ansistring');
+ RegisterMethod('Function ToReadableString : Ansistring');
+ RegisterMethod('Function WriteAnsiString( AString : AnsiString) : integer');
+ RegisterProperty('CapacityIncrement', 'integer', iptrw);
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure SIRegister_uROClasses(CL: TPSPascalCompiler);
+begin
+ SIRegister_TROBinaryMemoryStream(CL);
+end;
+
+(* === run-time registration functions === *)
+(*----------------------------------------------------------------------------*)
+procedure TROBinaryMemoryStreamCapacityIncrement_W(Self: TROBinaryMemoryStream; const T: integer);
+begin Self.CapacityIncrement := T; end;
+
+(*----------------------------------------------------------------------------*)
+procedure TROBinaryMemoryStreamCapacityIncrement_R(Self: TROBinaryMemoryStream; var T: integer);
+begin T := Self.CapacityIncrement; end;
+
+(*----------------------------------------------------------------------------*)
+Function TROBinaryMemoryStreamCreate_P(Self: TClass; CreateNewInstance: Boolean):TObject;
+Begin Result := TROBinaryMemoryStream.Create; END;
+
+(*----------------------------------------------------------------------------*)
+Function TROBinaryMemoryStreamCreate2_P(Self: TClass; CreateNewInstance: Boolean; const iString : Ansistring):TObject;
+Begin Result := TROBinaryMemoryStream.Create(iString); END;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_TROBinaryMemoryStream(CL: TPSRuntimeClassImporter);
+begin
+ with CL.Add(TROBinaryMemoryStream) do
+ begin
+ RegisterConstructor(@TROBinaryMemoryStreamCreate2_P, 'Create2');
+ RegisterConstructor(@TROBinaryMemoryStreamCreate_P, 'Create');
+ RegisterMethod(@TROBinaryMemoryStream.Assign, 'Assign');
+ RegisterMethod(@TROBinaryMemoryStream.Clone, 'Clone');
+ RegisterMethod(@TROBinaryMemoryStream.LoadFromString, 'LoadFromString');
+ RegisterMethod(@TROBinaryMemoryStream.LoadFromHexString, 'LoadFromHexString');
+ RegisterMethod(@TROBinaryMemoryStream.ToString, 'ToString');
+ RegisterMethod(@TROBinaryMemoryStream.ToHexString, 'ToHexString');
+ RegisterMethod(@TROBinaryMemoryStream.ToReadableString, 'ToReadableString');
+ RegisterMethod(@TROBinaryMemoryStream.WriteAnsiString, 'WriteAnsiString');
+ RegisterPropertyHelper(@TROBinaryMemoryStreamCapacityIncrement_R,@TROBinaryMemoryStreamCapacityIncrement_W,'CapacityIncrement');
+ end;
+end;
+
+(*----------------------------------------------------------------------------*)
+procedure RIRegister_uROClasses(CL: TPSRuntimeClassImporter);
+begin
+ RIRegister_TROBinaryMemoryStream(CL);
+end;
+
+
+
+(*----------------------------------------------------------------------------*)
+
+type
+ TRoObjectInstance = class;
+ { }
+ IROClass = interface
+ ['{246B5804-461F-48EC-B2CA-FBB7B69B0D64}']
+ function SLF: TRoObjectInstance;
+ end;
+ TRoObjectInstance = class(TInterfacedObject, IROClass)
+ private
+ FMessage: IROMessage;
+ FChannel: IROTransportChannel;
+ public
+ constructor Create;
+ function SLF: TRoObjectInstance;
+ property Message: IROMessage read FMessage write FMessage;
+ property Channel: IROTransportChannel read FChannel write FChannel;
+ end;
+
+
+
+function CreateProc(Caller: TPSExec; p: PIFProcRec; Global, Stack: TPSStack): Boolean;
+var
+ temp, res: TPSVariantIFC;
+ Chan: TROTransportChannel;
+ Msg: TROMessage;
+ NewRes: TRoObjectInstance;
+begin
+ res := NewTPSVariantIFC(Stack[Stack.count -1], True);
+ if (Res.Dta = nil) or (res.aType.BaseType <> btInterface) then
+ begin
+ Caller.CMD_Err2(erCustomError, 'RO Invoker: Invalid Parameters');
+ Result := False;
+ exit;
+ end;
+ IUnknown(Res.Dta^) := nil;
+
+ NewRes := TRoObjectInstance.Create;
+
+ temp := NewTPSVariantIFC(Stack[Stack.Count -4], True);
+
+ if (temp.aType <> nil) and (temp.Dta <> nil) and (Temp.aType.BaseType = btClass) and (TObject(Temp.Dta^) is TROTransportChannel) then
+ Chan := TROTransportChannel(temp.dta^)
+ else
+ Chan := nil;
+ temp := NewTPSVariantIFC(Stack[Stack.Count -3], True);
+ if (temp.aType <> nil) and (temp.Dta <> nil) and (Temp.aType.BaseType = btClass) and (TObject(Temp.Dta^) is TROMessage) then
+ Msg := TROMessage(temp.dta^)
+ else
+ Msg := nil;
+ if (msg = nil) or (chan = nil) then
+ begin
+ Chan.free;
+ msg.Free;
+
+ NewRes.Free;
+ Result := false;
+ Caller.CMD_Err2(erCustomError, 'Could not create message');
+ exit;
+ end;
+
+ IRoClass(Res.Dta^) := NewRes;
+
+ NewRes.Message := Msg;
+ NewRes.Channel := Chan;
+ Result := True;
+end;
+
+function NilProc(Caller: TPSExec; p: PIFProcRec; Global, Stack: TPSStack): Boolean;
+var
+ n: TPSVariantIFC;
+begin
+ n := NewTPSVariantIFC(Stack[Stack.count -1], True);
+ if (n.Dta = nil) or (n.aType = nil) or (n.aType.BaseType <> btInterface) then
+ begin
+ Caller.CMD_Err2(erCustomError, 'RO Invoker: Cannot free');
+ Result := False;
+ exit;
+ end;
+ IUnknown(n.Dta^) := nil;
+ Result := True;
+end;
+
+type
+ TROStructure = class(TPersistent, IROCustomStreamableType, IROCustomStreamableStruct)
+ private
+ FVar: TPSVariantIFC;
+ FExec: TPSExec;
+ protected
+ function GetTypeName: string;
+ procedure SetTypeName(const s: string);
+ procedure Write(Serializer: TROSerializer; const Name: string);
+ procedure Read(Serializer: TROSerializer; const Name: string);
+ function _AddRef: Integer; stdcall;
+ function _Release: Integer; stdcall;
+ function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
+ function CanImplementType(const aName: string):boolean;
+ procedure SetNull(b: Boolean);
+ function IsNull: Boolean;
+ public
+ constructor Create(aVar: TPSVariantIfc; Exec: TPSExec);
+ end;
+ TROArray = class(TROStructure, IROCustomStreamableType, IROCustomStreamableStruct, IROCustomStreamableArray)
+ protected
+ function GetCount: Longint;
+ procedure SetCount(l: Longint);
+ end;
+
+procedure WriteUserDefined(Exec: TPSExec; const Msg: IROMessage; const Name: string; const n: TPSVariantIfc);
+var
+ obj: TROStructure;
+begin
+ if n.aType.BaseType = btArray then
+ obj := TROArray.Create(n, exec)
+ else if n.aType.BaseType = btRecord then
+ obj := TROStructure.Create(n, exec)
+ else
+ raise Exception.Create('Unknown custom type');
+ try
+ Msg.Write(Name, obj.ClassInfo, obj, []);
+ finally
+ obj.Free;
+ end;
+end;
+
+procedure ReadUserDefined(Exec: TPSExec; const Msg: IROMessage; const Name: string; const n: TPSVariantIfc);
+var
+ obj: TROStructure;
+begin
+ if n.aType.BaseType = btArray then
+ obj := TROArray.Create(n, exec)
+ else if n.aType.BaseType = btRecord then
+ obj := TROStructure.Create(n, exec)
+ else
+ raise Exception.Create('Unknown custom type');
+ try
+ Msg.Read(Name, obj.ClassInfo, obj, []);
+ finally
+ obj.Free;
+ end;
+end;
+
+function RoProc(Caller: TPSExec; p: TIFExternalProcRec; Global, Stack: TIfList): Boolean;
+var
+ s, s2: string;
+ res, n: TPSVariantIFC;
+ aType: TRODataType;
+ aMode: TRODLParamFlag;
+ StartOffset, I: Longint;
+ __request, __response : TMemoryStream;
+ Inst: TRoObjectInstance;
+
+begin
+ s := p.Decl;
+
+ if s[1] = #255 then
+ begin
+ n := NewTPSVariantIFC(Stack[Stack.Count -1], True);
+ res.Dta := nil;
+ res.aType := nil;
+ StartOffset := Stack.Count -2;
+ end
+ else
+ begin
+ n := NewTPSVariantIFC(Stack[Stack.Count -2], True);
+ res := NewTPSVariantIFC(Stack[Stack.Count -1], True);
+ StartOffset := Stack.Count -3;
+ end;
+
+ if (n.Dta = nil) or (N.aType = nil) or (n.aType.BaseType <> btInterface) or (Longint(n.Dta^) = 0) then
+ begin
+ Caller.CMD_Err2(erCustomError, 'RO Invoker: Invalid Parameters');
+ Result := False;
+ exit;
+ end;
+
+ Inst := IROClass(n.dta^).Slf;
+ Delete(s, 1, 1);
+ i := StartOffset;
+ try
+ Inst.SLF.Message.InitializeRequestMessage(Inst.Channel, '', Copy(p.Name,1,pos('.', p.Name) -1), Copy(p.Name, pos('.', p.Name)+1, MaxInt));
+ while Length(s) > 0 do
+ begin
+ s2 := copy(s, 2, ord(s[1]));
+ aMode := TRODLParamFlag(ord(s[length(s2)+2]));
+ aType := TRODataType(ord(s[length(s2)+3]));
+ Delete(s, 1, length(s2)+3);
+ n := NewTPSVariantIFC(Stack[i], True);
+ Dec(I);
+ if ((aMode = fIn) or (aMode = fInOut)) and (n.Dta <> nil) then
+ begin
+ case aType of
+ rtInteger: Inst.Message.Write(s2, TypeInfo(Integer), Integer(n.Dta^), []);
+ rtDateTime: Inst.Message.Write(s2, TypeInfo(DateTime), Double(n.Dta^), []);
+ rtDouble: Inst.Message.Write(s2, TypeInfo(Double), Double(n.Dta^), []);
+ rtCurrency: Inst.Message.Write(s2, TypeInfo(Double), Double(n.Dta^), []);
+ rtWideString: Inst.Message.Write(s2, TypeInfo(WideString), WideString(n.Dta^), []);
+ rtString: Inst.Message.Write(s2, TypeInfo(String), String(n.Dta^), []);
+ rtInt64: Inst.Message.Write(s2, TypeInfo(Int64), Int64(n.Dta^), []);
+ rtBoolean: Inst.Message.Write(s2, TypeInfo(Boolean), Byte(n.Dta^), []);
+ rtUserDefined: WriteUserDefined(Caller, Inst.Message, s2, n);
+ end;
+ end;
+ end;
+ __request := TMemoryStream.Create;
+ __response := TMemoryStream.Create;
+ try
+ Inst.Message.WriteToStream(__request);
+ Inst.Channel.Dispatch(__request, __response);
+ Inst.Message.ReadFromStream(__response);
+ finally
+ __request.Free;
+ __response.Free;
+ end;
+ s := p.Decl;
+ Delete(s, 1, 1);
+ i := StartOffset;
+ while Length(s) > 0 do
+ begin
+ s2 := copy(s, 2, ord(s[1]));
+ aMode := TRODLParamFlag(ord(s[length(s2)+2]));
+ aType := TRODataType(ord(s[length(s2)+3]));
+ Delete(s, 1, length(s2)+3);
+ n := NewTPSVariantIFC(Stack[i], True);
+ Dec(I);
+ if ((aMode = fOut) or (aMode = fInOut)) and (n.Dta <> nil) then
+ begin
+ case aType of
+ rtInteger: Inst.Message.Read(s2, TypeInfo(Integer), Longint(n.Dta^), []);
+ rtDateTime: Inst.Message.Read(s2, TypeInfo(DateTime), double(n.dta^), []);
+ rtDouble: Inst.Message.Read(s2, TypeInfo(Double), double(n.dta^), []);
+ rtCurrency: Inst.Message.Read(s2, TypeInfo(Double), double(n.dta^), []);
+ rtWideString: Inst.Message.Read(s2, TypeInfo(WideString), widestring(n.Dta^), []);
+ rtString: Inst.Message.Read(s2, TypeInfo(String), string(n.dta^), []);
+ rtInt64: Inst.Message.Read(s2, TypeInfo(Int64), Int64(n.Dta^), []);
+ rtBoolean: Inst.Message.Read(s2, TypeInfo(Boolean), Boolean(n.Dta^), []);
+ rtUserDefined: ReadUserDefined(Caller, Inst.Message, s2, n);
+ end;
+ end;
+ end;
+ aType := TRODataType(p.Decl[1]);
+ case aType of
+ rtInteger: Inst.Message.Read('Result', TypeInfo(Integer), Longint(res.Dta^), []);
+ rtDateTime: Inst.Message.Read('Result', TypeInfo(DateTime), Double(res.dta^), []);
+ rtDouble: Inst.Message.Read('Result', TypeInfo(Double), Double(res.Dta^), []);
+ rtCurrency: Inst.Message.Read('Result', TypeInfo(Double), double(res.Dta^), []);
+ rtWideString: Inst.Message.Read('Result', TypeInfo(WideString), WideString(res.Dta^), []);
+ rtString: Inst.Message.Read('Result', TypeInfo(String), String(res.Dta^), []);
+ rtInt64: Inst.Message.Read('Result', TypeInfo(Int64), Int64(res.dta^), []);
+ rtBoolean: Inst.Message.Read('Result', TypeInfo(Boolean), Boolean(res.dta^), []);
+ rtUserDefined: ReadUserDefined(Caller, Inst.Message, 'Result', res);
+ end;
+ except
+ on e: Exception do
+ begin
+ Caller.CMD_Err2(erCustomError, e.Message);
+ Result := False;
+ exit;
+ end;
+ end;
+ Result := True;
+end;
+
+function SProcImport(Sender: TPSExec; p: TIFExternalProcRec; Tag: Pointer): Boolean;
+var
+ s: string;
+begin
+ s := p.Decl;
+ Delete(s, 1, pos(':', s));
+ if s[1] = '-' then
+ p.ProcPtr := @NilProc
+ else if s[1] = '!' then
+ begin
+ P.ProcPtr := @CreateProc;
+ p.Decl := Copy(s, 2, MaxInt);
+ end else
+ begin
+ Delete(s, 1, 1);
+ p.Name := Copy(S,1,pos('!', s)-1);
+ Delete(s, 1, pos('!', s));
+ p.Decl := s;
+ p.ProcPtr := @RoProc;
+ end;
+ Result := True;
+end;
+
+
+type
+ TMYComp = class(TPSPascalCompiler);
+ TRoClass = class(TPSExternalClass)
+ private
+ FService: TRODLService;
+ FNilProcNo: Cardinal;
+ FCompProcno: Cardinal;
+ function CreateParameterString(l: TRODLOperation): string;
+ function GetDT(DataType: string): TRODataType;
+ procedure MakeDeclFor(Dest: TPSParametersDecl; l: TRODLOperation);
+ public
+ constructor Create(Se: TPSPascalCompiler; Service: TRODLService; Const Typeno: TPSType);
+
+ function SelfType: TPSType; override;
+ function Func_Find(const Name: tbtstring; var Index: Cardinal): Boolean; override;
+ function Func_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; override;
+ function SetNil(var ProcNo: Cardinal): Boolean; override;
+
+ function ClassFunc_Find(const Name: tbtstring; var Index: Cardinal): Boolean; override;
+ function ClassFunc_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; override;
+ function IsCompatibleWith(Cl: TPSExternalClass): Boolean; override;
+ end;
+
+{ TROPSLink }
+procedure TPSRemObjectsSdkPlugin.RODLLoadFromFile(const FileName: string);
+var
+ f: TFileStream;
+begin
+ f := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone);
+ try
+ RODLLoadFromStream(f);
+ finally
+ f.Free;
+ end;
+end;
+
+procedure TPSRemObjectsSdkPlugin.RODLLoadFromResource;
+var
+ rs: TResourceStream;
+begin
+ rs := TResourceStream.Create(HInstance, 'RODLFILE', RT_RCDATA);
+ try
+ RODLLoadFromStream(rs);
+ finally
+ rs.Free;
+ end;
+end;
+
+procedure TPSRemObjectsSdkPlugin.RODLLoadFromStream(S: TStream);
+begin
+ FreeAndNil(FRodl);
+ with TXMLToRODL.Create do
+ begin
+ try
+ FRodl := Read(S);
+ finally
+ Free;
+ end;
+ end;
+end;
+
+
+destructor TPSRemObjectsSdkPlugin.Destroy;
+begin
+ FreeAndNil(FRodl);
+ FModules.Free;
+ inherited Destroy;
+end;
+
+{ TRoClass }
+
+constructor TRoClass.Create(Se: TPSPascalCompiler; Service: TRODLService; Const Typeno: TPSType);
+begin
+ inherited Create(SE, TypeNo);
+ FService := Service;
+ FNilProcNo := Cardinal(-1);
+ FCompProcNo := Cardinal(-1);
+end;
+
+function TRoClass.GetDT(DataType: string): TRODataType;
+begin
+ DataType := LowerCase(DataType);
+ if DataType = 'integer' then
+ Result := rtInteger
+ else if DataType = 'datetime' then
+ Result := rtDateTime
+ else if DataType = 'double' then
+ Result := rtDouble
+ else if DataType = 'currency' then
+ Result := rtCurrency
+ else if DataType = 'widestring' then
+ Result := rtWidestring
+ else if DataType = 'string' then
+ Result := rtString
+ else if DataType = 'int64' then
+ Result := rtInt64
+ else if DataType = 'boolean' then
+ Result := rtBoolean
+ else if DataType = 'variant' then
+ Result := rtVariant
+ else if DataType = 'binary' then
+ Result := rtBinary
+ else
+ Result := rtUserDefined;
+end;
+
+function TRoClass.CreateParameterString(l: TRODLOperation): string;
+var
+ i: Longint;
+begin
+ if L.Result = nil then
+ begin
+ Result := #$FF;
+ end else
+ begin
+ Result := Chr(Ord(GetDT(l.Result.DataType)));
+ end;
+ for i := 0 to l.Count -1 do
+ begin
+ if l.Items[i].Flag = fResult then Continue;
+ Result := Result + Chr(Length(l.Items[i].Info.Name))+ l.Items[i].Info.Name + Chr(Ord(l.Items[i].Flag)) + Chr(Ord(GetDT(l.Items[i].DataType)));
+ end;
+end;
+
+procedure TRoClass.MakeDeclFor(Dest: TPSParametersDecl; l: TRODLOperation);
+var
+ i: Longint;
+ dd: TPSParameterDecl;
+begin
+ if l.Result <> nil then
+ begin
+ Dest.Result := TMyComp(SE).at2ut(SE.FindType(l.Result.DataType));
+ end;
+ for i := 0 to l.Count -1 do
+ begin
+ if l.Items[i].Flag = fResult then Continue;
+ dd := Dest.AddParam;
+ if l.Items[i].Flag = fIn then
+ dd.mode := pmIn
+ else
+ dd.Mode := pmInOut;
+ dd.OrgName := l.Items[i].Info.Name;
+ dd.aType := TMyComp(SE).at2ut(SE.FindType(l.Items[i].DataType));
+ end;
+end;
+
+function TRoClass.Func_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean;
+var
+ h, i: Longint;
+ s, e: string;
+ P: TPSProcedure;
+ p2: TPSExternalProcedure;
+begin
+ s := 'roclass:_'+FService.Info.Name + '.' + FService.Default.Items[Index].Info.Name;
+ h := MakeHash(s);
+ for i := 0 to TMyComp(SE).FProcs.Count -1 do
+ begin
+ P := TMyComp(SE).FProcs[i];
+ if (p is TPSExternalProcedure) then
+ begin
+ p2 := TPSExternalProcedure(p);
+ if (p2.RegProc.NameHash = h) and (Copy(p2.RegProc.ImportDecl, 1, pos(tbtchar('!'), p2.RegProc.ImportDecl)) = s) then
+ begin
+ Procno := I;
+ Result := True;
+ Exit;
+ end;
+ end;
+ end;
+ e := CreateParameterString(FService.Default.Items[Index]);
+ s := s + '!' + e;
+ ProcNo := TMyComp(SE).AddUsedFunction2(P2);
+ p2.RegProc := TPSRegProc.Create;
+ TMYComp(SE).FRegProcs.Add(p2.RegProc);
+ p2.RegProc.Name := '';
+ p2.RegProc.ExportName := True;
+ MakeDeclFor(p2.RegProc.Decl, FService.Default.Items[Index]);
+ p2.RegProc.ImportDecl := s;
+ Result := True;
+end;
+
+function TRoClass.Func_Find(const Name: tbtstring; var Index: Cardinal): Boolean;
+var
+ i: Longint;
+begin
+ for i := 0 to FService.Default.Count -1 do
+ begin
+ if CompareText(FService.Default.Items[i].Info.Name, Name) = 0 then
+ begin
+ Index := i;
+ Result := True;
+ Exit;
+ end;
+ end;
+ Result := False;
+end;
+
+const
+ PSClassType = '!ROClass';
+ MyGuid: TGuid = '{CADCCF37-7FA0-452E-971D-65DA691F7648}';
+
+function TRoClass.SelfType: TPSType;
+begin
+ Result := SE.FindType(PSClassType);
+ if Result = nil then
+ begin
+ Result := se.AddInterface(se.FindInterface('IUnknown'), MyGuid, PSClassType).aType;
+ end;
+end;
+
+function TRoClass.SetNil(var ProcNo: Cardinal): Boolean;
+var
+ P: TPSExternalProcedure;
+begin
+ if FNilProcNo <> Cardinal(-1) then
+ ProcNo:= FNilProcNo
+ else
+ begin
+ ProcNo := TMyComp(SE).AddUsedFunction2(P);
+ p.RegProc := TPSRegProc.Create;
+ TMyComp(SE).FRegProcs.Add(p.RegProc);
+ p.RegProc.Name := '';
+ p.RegProc.ExportName := True;
+ with p.RegProc.Decl.AddParam do
+ begin
+ OrgName := 'VarNo';
+ aType := TMYComp(Se).at2ut(SelfType);
+ end;
+ p.RegProc.ImportDecl := 'roclass:-';
+ FNilProcNo := Procno;
+ end;
+ Result := True;
+end;
+
+function TRoClass.ClassFunc_Call(Index: Cardinal;
+ var ProcNo: Cardinal): Boolean;
+var
+ P: TPSExternalProcedure;
+begin
+ if FCompProcNo <> Cardinal(-1) then
+ begin
+ Procno := FCompProcNo;
+ Result := True;
+ Exit;
+ end;
+ ProcNo := TMyComp(SE).AddUsedFunction2(P);
+ p.RegProc := TPSRegProc.Create;
+ TMyComp(SE).FRegProcs.Add(p.RegProc);
+ p.RegProc.ExportName := True;
+ p.RegProc.Decl.Result := TMyComp(SE).at2ut(SelfType);
+ with p.RegProc.Decl.AddParam do
+ begin
+ Orgname := 'Message';
+ aType :=TMyComp(SE).at2ut(SE.FindType('TROMESSAGE'));
+ end;
+ with p.RegProc.Decl.AddParam do
+ begin
+ Orgname := 'Channel';
+ aType :=TMyComp(SE).at2ut(SE.FindType('TROTRANSPORTCHANNEL'));
+ end;
+ p.RegProc.ImportDecl := 'roclass:!';
+ FCompProcNo := Procno;
+ Result := True;
+end;
+
+function TRoClass.ClassFunc_Find(const Name: tbtstring;
+ var Index: Cardinal): Boolean;
+begin
+ if Name = 'CREATE' then
+ begin
+ Result := True;
+ Index := 0;
+ end else
+ result := False;
+end;
+
+function TRoClass.IsCompatibleWith(Cl: TPSExternalClass): Boolean;
+begin
+ Result := Cl is TRoClass;
+end;
+
+{ TRoObjectInstance }
+
+function TRoObjectInstance.SLF: TRoObjectInstance;
+begin
+ Result := Self;
+end;
+
+constructor TRoObjectInstance.Create;
+begin
+ FRefCount := 1;
+end;
+
+
+function TPSRemObjectsSdkPlugin.MkStructName(Struct: TRODLStruct): string;
+var
+ i: Longint;
+begin
+ Result := '!ROStruct!'+Struct.Info.Name+ ',';
+ for i := 0 to Struct.Count -1 do
+ begin
+ Result := Result + Struct.Items[i].Info.Name+ ',';
+ end;
+end;
+
+function CompareStructItem(const S1, S2: TRODLTypedEntity): Integer;
+begin
+ Result := CompareText(S1.Info.Name, S2.Info.Name);
+end;
+
+procedure SortStruct(struct: TRODLStruct; First, Last: Longint);
+var
+ l, r, Pivot: Integer;
+begin
+ while First < Last do
+ begin
+ Pivot := (First + Last) div 2;
+ l := First - 1;
+ r := Last + 1;
+ repeat
+ repeat inc(l); until CompareStructItem(Struct.Items[l], Struct.Items[Pivot]) >= 0;
+ repeat dec(r); until CompareStructItem(Struct.Items[r], Struct.Items[Pivot]) <= 0;
+ if l >= r then break;
+ Struct.Exchange(l, r);
+ until false;
+ if First < r then SortStruct(Struct, First, r);
+ First := r+1;
+ end;
+end;
+
+procedure TPSRemObjectsSdkPlugin.CompileImport1(CompExec: TPSScript);
+var
+ i, i1: Longint;
+ Enum: TRODLEnum;
+ TempType: TPSType;
+ Struct: TRODLStruct;
+ Arr: TRODLArray;
+ RecType: TPSRecordFieldTypeDef;
+ Service: TRODLService;
+begin
+ if FRODL = nil then exit;
+ if CompExec.Comp.FindType('TDateTime') = nil then
+ raise Exception.Create('Please register the DateUtils library first');
+ if CompExec.Comp.FindType('TStream') = nil then
+ raise Exception.Create('Please register the sysutils/classes library first');
+ SIRegisterTROTRANSPORTCHANNEL(CompExec.Comp);
+ SIRegisterTROMESSAGE(CompExec.Comp);
+ SIRegister_uROClasses(CompExec.Comp);
+ CompExec.Comp.AddTypeCopyN('Binary', 'TROBinaryMemoryStream');
+ if CompExec.Comp.FindType('DateTime') = nil then
+ CompExec.Comp.AddTypeCopyN('DateTime', 'TDateTime');
+ if CompExec.Comp.FindType('Currency') = nil then
+ CompExec.Comp.AddTypeCopyN('Currency', 'Double'); // for now
+ for i := 0 to FRodl.EnumCount -1 do
+ begin
+ Enum := FRodl.Enums[i];
+ TempType := CompExec.Comp.AddType(Enum.Info.Name, btEnum);
+ for i1 := 0 to Enum.Count -1 do
+ begin
+ CompExec.Comp.AddConstant(Enum.Items[i1].Info.Name, TempType).SetUInt(i1);
+ end;
+ end;
+ for i := 0 to FRodl.StructCount -1 do
+ begin
+ Struct := FRodl.Structs[i];
+ SortStruct(Struct, 0, Struct.Count-1);
+ TempType := CompExec.Comp.AddType('', btRecord);
+ TempType.ExportName := True;
+ TempType.Name := MkStructName(Struct);
+ for i1 := 0 to Struct.Count -1 do
+ begin
+ RecType := TPSRecordType(TempType).AddRecVal;
+ RecType.FieldOrgName := Struct.Items[i1].Info.Name;
+ RecType.aType := CompExec.Comp.FindType(Struct.Items[i1].DataType);
+ if RecType.aType = nil then begin
+ Arr := fRodl.FindArray(Struct.Items[i1].DataType);
+ if Arr <> nil then begin
+ RecType.aType := CompExec.Comp.AddType(Arr.Info.Name, btArray);
+ TPSArrayType(RecType.aType).ArrayTypeNo := CompExec.Comp.FindType(Arr.ElementType);
+ end;
+ end;
+ end;
+ CompExec.Comp.AddTypeCopy(Struct.Info.Name, TempType);
+ end;
+ for i := 0 to FRodl.ArrayCount -1 do
+ begin
+ Arr := FRodl.Arrays[i];
+ TempType := CompExec.Comp.FindType(Arr.Info.Name);
+ if TempType <> nil then begin
+ if not (TempType is TPSArrayType) then begin
+ CompExec.Comp.MakeError('ROPS', ecDuplicateIdentifier, Arr.Info.Name);
+ end;
+ end else begin
+ TempType := CompExec.Comp.AddType(Arr.Info.Name, btArray);
+ end;
+ TPSArrayType(TempType).ArrayTypeNo := CompExec.Comp.FindType(Arr.ElementType);
+ end;
+ for i := 0 to FRodl.ServiceCount -1 do
+ begin
+ Service := FRodl.Services[i];
+ TempType := CompExec.Comp.AddType(Service.Info.Name, btExtClass);
+ TPSUndefinedClassType(TempType).ExtClass := TRoClass.Create(CompExec.Comp, Service, TempType);
+ end;
+ for i := 0 to FModules.Count -1 do
+ TPSROModuleClass(FModules[i]).CompImp(CompExec.Comp);
+end;
+
+function TPSRemObjectsSdkPlugin.GetHaveRodl: Boolean;
+begin
+ Result := FRodl <> nil;
+end;
+
+procedure TPSRemObjectsSdkPlugin.ClearRodl;
+begin
+ FRodl.Free;
+ FRodl := nil;
+end;
+
+procedure TPSRemObjectsSdkPlugin.ExecImport1(CompExec: TPSScript;
+ const ri: TPSRuntimeClassImporter);
+var
+ i: Longint;
+begin
+ if FRODL = nil then exit;
+ CompExec.Exec.AddSpecialProcImport('roclass', SProcImport, nil);
+ RIRegisterTROTRANSPORTCHANNEL(ri);
+ RIRegisterTROMESSAGE(ri);
+ RIRegister_TROBinaryMemoryStream(ri);
+ for i := 0 to FModules.Count -1 do
+ TPSROModuleClass(FModules[i]).ExecImp(CompExec.Exec, ri);
+end;
+
+constructor TPSRemObjectsSdkPlugin.Create(AOwner: TComponent);
+begin
+ inherited Create(AOwner);
+ FModules := TList.Create;
+ //FEnableSOAP := True;
+ FEnableBinary := True;
+ FEnableIndyTCP := True;
+ FEnableIndyHTTP := True;
+end;
+
+procedure TPSRemObjectsSdkPlugin.Loaded;
+begin
+ inherited Loaded;
+ ReloadModules;
+end;
+
+procedure TPSRemObjectsSdkPlugin.RegisterModule(
+ Module: TPSROModuleClass);
+begin
+ FModules.Add(Module);
+end;
+
+procedure TPSRemObjectsSdkPlugin.ReloadModules;
+begin
+ FModules.Clear;
+ if FEnableIndyTCP then RegisterModule(TPSROIndyTCPModule);
+ if FEnableIndyHTTP then RegisterModule(TPSROIndyHTTPModule);
+ //if FEnableSOAP then RegisterModule(TPSROSoapModule);
+ if FEnableBinary then RegisterModule(TPSROBinModule);
+ if assigned(FOnLoadModule) then
+ FOnLoadModule(Self);
+end;
+
+{ TPSROModule }
+
+class procedure TPSROModule.CompImp(comp: TPSPascalCompiler);
+begin
+ // do nothing
+end;
+
+class procedure TPSROModule.ExecImp(exec: TPSExec;
+ ri: TPSRuntimeClassImporter);
+begin
+ // do nothing
+end;
+
+procedure IntRead(Exec: TPSExec; Serializer: TROSerializer;
+ const Name: string; aVar: TPSVariantIFC; arridx: Longint);
+var
+ i: Longint;
+ s, s2: string;
+ r: TROStructure;
+begin
+ case aVar.aType.BaseType of
+ btS64: Serializer.Read(Name, TypeInfo(int64), Int64(avar.Dta^), arridx);
+ btu32: Serializer.Read(Name, TypeInfo(cardinal), Cardinal(avar.Dta^), arridx);
+ bts32: Serializer.Read(Name, TypeInfo(longint), Longint(avar.Dta^), arridx);
+ btu16: Serializer.Read(Name, TypeInfo(word), Word(aVar.Dta^), arridx);
+ btS16: Serializer.Read(Name, TypeInfo(smallint), Smallint(aVar.Dta^), arridx);
+ btu8: Serializer.Read(Name, TypeInfo(byte), Byte(aVar.Dta^), arridx);
+ btS8: Serializer.Read(Name, TypeInfo(shortint), Shortint(aVar.Dta^), arridx);
+ btDouble:
+ begin
+ if aVar.aType.ExportName = 'TDATETIME' then
+ Serializer.Read(Name, TypeInfo(datetime), Double(avar.Dta^), arridx)
+ else
+ Serializer.Read(Name, TypeInfo(double), Double(aVar.Dta^), arridx);
+ end;
+ btSingle: Serializer.Read(Name, TypeInfo(single), Single(avar.Dta^), arridx);
+ btExtended: Serializer.Read(Name, TypeInfo(extended), Extended(avar.dta^), arridx);
+ btWideString: Serializer.Read(Name, TypeInfo(widestring), widestring(avar.dta^), arridx);
+ btString: Serializer.Read(Name, TypeInfo(string), string(avar.dta^), arridx);
+ btArray:
+ begin
+ if (TPSTypeRec_Array(avar.aType).ArrayType.BaseType = btRecord) then
+ begin
+ for i := 0 to PSDynArrayGetLength(Pointer(aVar.Dta^), aVar.aType) -1 do
+ begin
+ r := TROStructure.Create(PSGetArrayField(avar, i), Exec);
+ try
+ Serializer.Read(Name, typeinfo(TROArray), r, i);
+ finally
+ r.Free;
+ end;
+ end;
+ end else if (TPSTypeRec_Array(avar.aType).ArrayType.BaseType = btArray) then
+ begin
+ for i := 0 to PSDynArrayGetLength(Pointer(aVar.Dta^), aVar.aType) -1 do
+ begin
+ r := TROArray.Create(PSGetArrayField(avar, i), Exec);
+ try
+ Serializer.Read(Name, typeinfo(TROArray), r, i);
+ finally
+ r.Free;
+ end;
+ end;
+ end else begin
+ for i := 0 to PSDynArrayGetLength(Pointer(aVar.Dta^), aVar.aType) -1 do
+ begin
+ IntRead(Exec, Serializer, Name, PSGetArrayField(avar, i), i);
+ end;
+ end;
+ end;
+ btRecord:
+ begin
+ s := avar.aType.ExportName;
+ if copy(s,1, 10) <> '!ROStruct!' then
+ raise Exception.Create('Invalid structure: '+s);
+ Delete(s,1,pos(',',s));
+ for i := 0 to TPSTypeRec_Record(aVar.aType).FieldTypes.Count -1 do
+ begin
+ s2 := copy(s,1,pos(',',s)-1);
+ delete(s,1,pos(',',s));
+ if (TPSTypeRec(TPSTypeRec_Record(aVar.aType).FieldTypes[i]).BaseType = btRecord) then
+ begin
+
+ r := TROStructure.Create(PSGetRecField(aVar, i), Exec);
+ try
+ Serializer.Read(s2, typeinfo(TROStructure), r, -1);
+ finally
+ r.Free;
+ end;
+ end else if (TPSTypeRec(TPSTypeRec_Record(aVar.aType).FieldTypes[i]).BaseType = btArray) then
+ begin
+ r := TROArray.Create(PSGetRecField(aVar, i), Exec);
+ try
+ Serializer.Read(s2, typeinfo(TROArray), r, -1);
+ finally
+ r.Free;
+ end;
+ end else
+ IntRead(Exec, Serializer, s2, PSGetRecField(aVar, i), -1);
+ end;
+ end;
+ else
+ raise Exception.Create('Unable to read type');
+
+ end;
+end;
+
+procedure IntWrite(Exec: TPSExec; Serializer: TROSerializer;
+ const Name: string; aVar: TPSVariantIFC; arridx: Longint);
+var
+ i: Longint;
+ s, s2: string;
+ r: TROStructure;
+begin
+ case aVar.aType.BaseType of
+ btS64: Serializer.Write(Name, TypeInfo(int64), Int64(avar.Dta^), arridx);
+ btu32: Serializer.Write(Name, TypeInfo(cardinal), Cardinal(avar.Dta^), arridx);
+ bts32: Serializer.Write(Name, TypeInfo(longint), Longint(avar.Dta^), arridx);
+ btu16: Serializer.Write(Name, TypeInfo(word), Word(avar.Dta^), arridx);
+ btS16: Serializer.Write(Name, TypeInfo(smallint), Smallint(aVar.Dta^), arridx);
+ btu8: Serializer.Write(Name, TypeInfo(byte), Byte(aVar.Dta^), arridx);
+ btS8: Serializer.Write(Name, TypeInfo(shortint), ShortInt(aVar.Dta^), arridx);
+ btDouble:
+ begin
+ if aVar.aType.ExportName = 'TDATETIME' then
+ Serializer.Write(Name, TypeInfo(datetime), Double(aVar.Dta^), arridx)
+ else
+ Serializer.Write(Name, TypeInfo(double), Double(aVar.Dta^), arridx);
+ end;
+ btSingle: Serializer.Write(Name, TypeInfo(single), Single(aVar.Dta^), arridx);
+ btExtended: Serializer.Write(Name, TypeInfo(extended), Extended(aVar.Dta^), arridx);
+ btWideString: Serializer.Write(Name, TypeInfo(widestring), WideString(aVar.Dta^), arridx);
+ btString: Serializer.Write(Name, TypeInfo(string), String(aVar.Dta^), arridx);
+ btArray:
+ begin
+ if (TPSTypeRec_Array(avar.aType).ArrayType.BaseType = btRecord) then
+ begin
+ for i := 0 to PSDynArrayGetLength(Pointer(aVar.Dta^), aVar.aType) -1 do
+ begin
+ r := TROStructure.Create(PSGetArrayField(aVar, i), Exec);
+ try
+ Serializer.Write(Name, typeinfo(TROArray), r, i);
+ finally
+ r.Free;
+ end;
+ end;
+ end else if (TPSTypeRec_Array(avar.aType).ArrayType.BaseType = btArray) then
+ begin
+ for i := 0 to PSDynArrayGetLength(Pointer(aVar.Dta^), aVar.aType) -1 do
+ begin
+ r := TROArray.Create(PSGetArrayField(aVar, i), Exec);
+ try
+ Serializer.Write(Name, typeinfo(TROArray), r, i);
+ finally
+ r.Free;
+ end;
+ end;
+ end else begin
+ for i := 0 to PSDynArrayGetLength(Pointer(aVar.Dta^), aVar.aType) -1 do
+ begin
+ IntWrite(Exec, Serializer, Name, PSGetArrayField(aVar, i), i);
+ end;
+ end;
+ end;
+ btRecord:
+ begin
+ s := avar.aType.ExportName;
+ if copy(s,1, 10) <> '!ROStruct!' then
+ raise Exception.Create('Invalid structure: '+s);
+ Delete(s,1,pos(',',s));
+ for i := 0 to TPSTypeRec_Record(aVar.aType).FieldTypes.Count -1 do
+ begin
+ s2 := copy(s,1,pos(',',s)-1);
+ delete(s,1,pos(',',s));
+ if (TPSTypeRec(TPSTypeRec_Record(aVar.aType).FieldTypes[i]).BaseType = btRecord) then
+ begin
+ r := TROStructure.Create(PSGetRecField(aVar, i), Exec);
+ try
+ Serializer.Write(s2, typeinfo(TROStructure), r, -1);
+ finally
+ r.Free;
+ end;
+ end else if (TPSTypeRec(TPSTypeRec_Record(aVar.aType).FieldTypes[i]).BaseType = btArray) then
+ begin
+ r := TROArray.Create(PSGetRecField(aVar, i), Exec);
+ try
+ Serializer.Write(s2, typeinfo(TROArray), r, -1);
+ finally
+ r.Free;
+ end;
+ end else
+ IntWrite(Exec, Serializer, s2, PSGetRecField(aVar, i), -1);
+ end;
+ end;
+ else
+ raise Exception.Create('Unable to read type');
+
+ end;
+end;
+
+{ TROStructure }
+
+constructor TROStructure.Create(aVar: TPSVariantIfc; Exec: TPSExec);
+begin
+ inherited Create;
+ FVar := aVar;
+ FExec := Exec;
+end;
+
+function TROStructure.IsNull: Boolean;
+begin
+ Result := False;
+end;
+
+function TROStructure.QueryInterface(const IID: TGUID;
+ out Obj): HResult;
+begin
+ if GetInterface(IID, Obj) then
+ Result := 0
+ else
+ Result := E_NOINTERFACE;
+end;
+
+procedure TROStructure.Read(Serializer: TROSerializer;
+ const Name: string);
+begin
+ IntRead(FExec, Serializer, Name, FVar, -1);
+end;
+
+procedure TROStructure.SetNull(b: Boolean);
+begin
+ // null not supported
+end;
+
+function TROStructure.GetTypeName: string;
+var
+ s: string;
+begin
+ s := fvar.atype.ExportName;
+ delete(s,1,1);
+ delete(s,1,pos('!', s));
+ result := copy(s,1,pos(',',s)-1);
+end;
+
+procedure TROStructure.Write(Serializer: TROSerializer;
+ const Name: string);
+begin
+ IntWrite(FExec, Serializer, Name, FVar, -1);
+end;
+
+
+function TROStructure._AddRef: Integer;
+begin
+ // do nothing
+ Result := 1;
+end;
+
+function TROStructure._Release: Integer;
+begin
+ // do nothing
+ Result := 1;
+end;
+
+function TROStructure.CanImplementType(const aName: string): boolean;
+begin
+ if SameText(aName, Self.GetTypeName) then
+ Result := True
+ else
+ Result := False;
+end;
+
+procedure TROStructure.SetTypeName(const s: string);
+begin
+ // Do nothing
+end;
+
+{ TROArray }
+
+function TROArray.GetCount: Longint;
+begin
+
+ // we should have an array in pVar now so assume that's true
+ Result := PSDynArrayGetLength(Pointer(fVar.Dta^), fvar.aType);
+end;
+
+procedure TROArray.SetCount(l: Integer);
+begin
+ PSDynArraySetLength(Pointer(fVAr.Dta^), fVar.aType, l);
+end;
+
+end.
diff --git a/Units/PascalScript/x64.inc b/Units/PascalScript/x64.inc
new file mode 100644
index 0000000..5150142
--- /dev/null
+++ b/Units/PascalScript/x64.inc
@@ -0,0 +1,513 @@
+{ implementation of x64 abi }
+//procedure DebugBreak; external 'Kernel32.dll';
+const
+ EmptyPchar: array[0..0] of char = #0;
+{$ASMMODE INTEL}
+
+{$IFDEF WINDOWS}
+procedure x64call(
+ Address: Pointer;
+ out _RAX: IPointer;
+ _RCX, _RDX, _R8, _R9: IPointer;
+ var _XMM0: Double;
+ _XMM1, _XMM2, _XMM3: Double;
+ aStack: Pointer; aItems: Integer); assembler; nostackframe;
+asm
+(* Registers:
+ RCX: Address
+ RDX: *_RAX
+ R8: _RCX
+ R9: _RDX
+
+ fpc inserts an 20h emty space
+*)
+ push ebp
+ mov ebp,esp
+// call debugbreak
+ push rcx // address
+ push rdx // _rax
+ push r8 // _rcx
+ push r9 // _rdx
+ mov rcx, aItems
+ mov rdx, aStack
+ jmp @compareitems
+@work:
+ push [rdx]
+ dec rcx
+ sub rdx,8
+@compareitems:
+ or rcx, rcx
+ jnz @work
+
+ // copy registers
+ movd xmm0,[_XMM0]
+ movd xmm1,_XMM1
+ movd xmm2,_XMM2
+ movd xmm3,_XMM3
+ mov RAX, [rbp-8]
+ mov RCX, [rbp-24]
+ mov RDX, [rbp-32]
+ mov R8, _R8
+ mov R9, _R9
+
+ // weird thing on windows, it needs 32 bytes in the CALLEE side to do whatever in
+ sub RSP, 32
+
+ call RAX
+
+ add RSP, 32 // undo the damage done earlier
+
+ // copy result back
+ mov RDX, [rbp-16]
+ mov [RDX], RAX
+ movd [_XMM0],xmm0
+
+ pop r9
+ pop r8
+ pop rdx
+ pop rcx
+ leave
+ ret
+end;
+{$ELSE}
+procedure x64call(
+ Address: Pointer;
+ out _RAX: IPointer;
+ _RDI, _RSI, _RDX, _RCX, _R8, _R9: IPointer;
+ var _XMM0: Double;
+ _XMM1, _XMM2, _XMM3, _XMM4, _XMM5, _XMM6, _XMM7: Double;
+ aStack: Pointer; aItems: Integer); assembler; nostackframe;
+
+
+asm
+(* Registers:
+ RDI: Address
+ RSI: _RAX
+ RDX: _RDI
+ RCX: _RSI
+ R8: _RDX
+ R9: _RCX
+
+
+*)
+ push ebp
+ mov ebp,esp
+ push rdi // address
+ push rsi // _rax
+ push rdx // _rdi
+ push rcx // _rsi
+ push r8 // _rdx
+ push r9 // _rcx
+ mov rcx, aItems
+ mov rdx, aStack
+ jmp @compareitems
+@work:
+ push [rdx]
+ dec rcx
+ sub rdx,8
+@compareitems:
+ or rcx, rcx
+ jnz @work
+
+ // copy registers
+ movd xmm0,[_XMM0]
+ movd xmm1,_XMM1
+ movd xmm2,_XMM2
+ movd xmm3,_XMM3
+ movd xmm4,_XMM4
+ movd xmm5,_XMM5
+ movd xmm6,_XMM6
+ movd xmm7,_XMM7
+ mov RAX, [rbp-8]
+ mov RDI, [rbp-24]
+ mov RSI, [rbp-32]
+ mov RDX, [rbp-40]
+ mov RCX, [rbp-48]
+ mov R8, _R8
+ mov R9, _R9
+
+ // weird thing on windows, it needs 32 bytes in the CALLEE side to do whatever in; not sure about linux
+ //sub RSP, 32
+
+ call RAX
+
+ // add RSP, 32 // undo the damage done earlier
+
+ // copy result back
+ mov RDX, [rbp-16]
+ mov [RDX], RAX
+ movd [_XMM0],xmm0
+
+ pop r9
+ pop r8
+ pop rdx
+ pop rcx
+ pop rsi
+ pop rdi
+ leave
+ ret
+end;
+{$ENDIF}
+
+function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean;
+var
+ Stack: array of Byte;
+ _RAX,
+{$IFDEF WINDOWS}
+ _RCX, _RDX, _R8, _R9: IPointer;
+ _XMM0, _XMM1, _XMM2, _XMM3: Double;
+{$ELSE}
+ _RDI, _RSI, _RDX, _RCX, _R8, _R9: IPointer;
+ _XMM0, _XMM1, _XMM2, _XMM3, _XMM4, _XMM5, _XMM6, _XMM7: Double;
+ RegUsageFloat: Byte;
+{$ENDIF}
+ RegUsage: Byte;
+ CallData: TPSList;
+ I: Integer;
+ pp: ^Byte;
+
+ function rp(p: PPSVariantIFC): PPSVariantIFC;
+ begin
+ if p = nil then
+ begin
+ result := nil;
+ exit;
+ end;
+ if p.aType.BaseType = btPointer then
+ begin
+ p^.aType := Pointer(Pointer(IPointer(p^.dta) + PointerSize)^);
+ p^.Dta := Pointer(p^.dta^);
+ end;
+ Result := p;
+ end;
+{$IFDEF WINDOWS}
+ procedure StoreReg(data: IPointer); overload;
+ var p: Pointer;
+ begin
+ case RegUsage of
+ 0: begin inc(RegUsage); _RCX:=Data; end;
+ 1: begin inc(RegUsage); _RDX:=Data; end;
+ 2: begin inc(RegUsage); _R8:=Data; end;
+ 3: begin inc(RegUsage); _R9:=Data; end;
+ else begin
+ SetLength(Stack, Length(Stack)+8);
+ p := @Stack[LEngth(Stack)-8];
+ IPointer(p^) := data;
+ end;
+ end;
+ end;
+ {$ELSE}
+ procedure StoreReg(data: IPointer); overload;
+ var p: Pointer;
+ begin
+ case RegUsage of
+ 0: begin inc(RegUsage); _RDI:=Data; end;
+ 1: begin inc(RegUsage); _RSI:=Data; end;
+ 2: begin inc(RegUsage); _RDX:=Data; end;
+ 3: begin inc(RegUsage); _RCX:=Data; end;
+ 4: begin inc(RegUsage); _R8:=Data; end;
+ 5: begin inc(RegUsage); _R9:=Data; end;
+ else begin
+ SetLength(Stack, Length(Stack)+8);
+ p := @Stack[LEngth(Stack)-8];
+ IPointer(p^) := data;
+ end;
+ end;
+ end;
+{$ENDIF}
+
+ procedure StoreStack(const aData; Len: Integer);
+ var
+ p: Pointer;
+ begin
+ if Len > 8 then
+ if Length(Stack) mod 16 <> 0 then begin
+ SetLength(Stack, Length(Stack)+ (16-(Length(Stack) mod 16)));
+ end;
+ SetLength(Stack, Length(Stack)+Len);
+ p := @Stack[Length(Stack)-Len];
+ Move(aData, p^, Len);
+ end;
+
+{$IFDEF WINDOWS}
+ procedure StoreReg(data: Double); overload;
+ var p: Pointer;
+ begin
+ case RegUsage of
+ 0: begin inc(RegUsage); _XMM0:=Data; end;
+ 1: begin inc(RegUsage); _XMM1:=Data; end;
+ 2: begin inc(RegUsage); _XMM2:=Data; end;
+ 3: begin inc(RegUsage); _XMM3:=Data; end;
+ else begin
+ SetLength(Stack, Length(Stack)+8);
+ p := @Stack[LEngth(Stack)-8];
+ Double(p^) := data;
+ end;
+ end;
+ end;
+ {$ELSE}
+ procedure StoreReg(data: Double); overload;
+ var p: Pointer;
+ begin
+ case RegUsageFloat of
+ 0: begin inc(RegUsageFloat); _XMM0:=Data; end;
+ 1: begin inc(RegUsageFloat); _XMM1:=Data; end;
+ 2: begin inc(RegUsageFloat); _XMM2:=Data; end;
+ 3: begin inc(RegUsageFloat); _XMM3:=Data; end;
+ 4: begin inc(RegUsageFloat); _XMM4:=Data; end;
+ 5: begin inc(RegUsageFloat); _XMM5:=Data; end;
+ 6: begin inc(RegUsageFloat); _XMM6:=Data; end;
+ 7: begin inc(RegUsageFloat); _XMM7:=Data; end;
+ else begin
+ SetLength(Stack, Length(Stack)+8);
+ p := @Stack[LEngth(Stack)-8];
+ Double(p^) := data;
+ end;
+ end;
+ end;
+ {$ENDIF}
+ function GetPtr(fVar: PPSVariantIFC): Boolean;
+ var
+ varPtr: Pointer;
+ //UseReg: Boolean;
+ //tempstr: tbtstring;
+ p: Pointer;
+ begin
+ Result := False;
+ if FVar = nil then exit;
+ if fVar.VarParam then
+ begin
+ case fvar.aType.BaseType of
+ btArray:
+ begin
+ if Copy(fvar.aType.ExportName, 1, 10) = '!OPENARRAY' then
+ begin
+ p := CreateOpenArray(True, Self, FVar);
+ if p = nil then exit;
+ CallData.Add(p);
+ StoreReg(IPointer(POpenArray(p)^.Data));
+ StoreReg(IPointer(POpenArray(p)^.ItemCount -1));
+ Result := True;
+ Exit;
+ end else begin
+ varptr := fvar.Dta;
+// Exit;
+ end;
+ end;
+ btVariant,
+ btSet,
+ btStaticArray,
+ btRecord,
+ btInterface,
+ btClass,
+ {$IFNDEF PS_NOWIDESTRING} btUnicodeString, btWideString, btWideChar, {$ENDIF} btU8, btS8, btU16,
+ btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency
+ {$IFNDEF PS_NOINT64}, bts64{$ENDIF}:
+ begin
+ Varptr := fvar.Dta;
+ end;
+ else begin
+ exit; //invalid type
+ end;
+ end; {case}
+
+ StoreReg(IPointer(VarPtr));
+ end else begin
+// UseReg := True;
+ case fVar^.aType.BaseType of
+ btSet:
+ begin
+ case TPSTypeRec_Set(fvar.aType).aByteSize of
+ 1: StoreReg(IPointer(byte(fvar.dta^)));
+ 2: StoreReg(IPointer(word(fvar.dta^)));
+ 3, 4: StoreReg(IPointer(cardinal(fvar.dta^)));
+ 5,6,7,8: StoreReg(IPointer(fVar.Dta^));
+ else
+ StoreReg(IPointer(fvar.Dta));
+ end;
+ end;
+ btArray:
+ begin
+ if Copy(fvar^.aType.ExportName, 1, 10) = '!OPENARRAY' then
+ begin
+ p := CreateOpenArray(False, SElf, FVar);
+ if p =nil then exit;
+ CallData.Add(p);
+ StoreReg(IPointer(POpenArray(p)^.Data));
+ StoreReg(IPointer(POpenArray(p)^.ItemCount -1));
+ Result := True;
+ exit;
+ end else begin
+ StoreReg(IPointer(FVar.Dta^));
+ end;
+ end;
+ btVariant
+ , btStaticArray, btRecord:
+ begin
+ StoreReg(IPointer(fVar.Dta));
+ end;
+ btExtended, btDouble: {8 bytes} begin
+ StoreReg(double(fvar.dta^));
+ end;
+ btCurrency: {8 bytes} begin
+ StoreReg(IPointer(fvar.dta^));
+ end;
+ btSingle: {4 bytes} begin
+ StoreReg(single(fvar.dta^));
+ end;
+
+ btChar,
+ btU8,
+ btS8: begin
+ StoreReg(IPointer(byte(fVar^.dta^)));
+ end;
+ btWideChar,
+ btu16, btS16: begin
+ StoreReg(IPointer(word(fVar^.dta^)));
+ end;
+ btu32, bts32: begin
+ StoreReg(IPointer(cardinal(fVar^.dta^)));
+ end;
+ btPchar:
+ begin
+ if pointer(fvar^.dta^) = nil then
+ StoreReg(IPointer(@EmptyPchar))
+ else
+ StoreReg(IPointer(fvar^.dta^));
+ end;
+ btclass, btinterface, btString:
+ begin
+ StoreReg(IPointer(fvar^.dta^));
+ end;
+ btWideString: begin
+ StoreReg(IPointer(fvar^.dta^));
+ end;
+ btUnicodeString: begin
+ StoreReg(IPointer(fvar^.dta^));
+ end;
+
+ btProcPtr:
+ begin
+ GetMem(p, PointerSize2);
+ TMethod(p^) := MKMethod(Self, Longint(FVar.Dta^));
+ StoreStack(p^, Pointersize2);
+ FreeMem(p);
+ end;
+
+ bts64:
+ begin
+ StoreReg(IPointer(int64(fvar^.dta^)));
+ end;
+ end; {case}
+ end;
+ Result := True;
+ end;
+begin
+ InnerfuseCall := False;
+ if Address = nil then
+ exit; // need address
+ SetLength(Stack, 0);
+ CallData := TPSList.Create;
+ res := rp(res);
+ if res <> nil then
+ res.VarParam := true;
+ try
+{$IFNDEF WINDOWS}
+ _RSI := 0;
+ _RDI := 0;
+ _XMM4 := 0;
+ _XMM5 := 0;
+ _XMM6 := 0;
+ _XMM7 := 0;
+ RegUsageFloat := 0;
+{$ENDIF}
+ _RCX := 0;
+ _RDX := 0;
+ _R8 := 0;
+ _R9 := 0;
+ _XMM0 := 0;
+ _XMM1 := 0;
+ _XMM2 := 0;
+ _XMM3 := 0;
+ RegUsage := 0;
+ if assigned(_Self) then begin
+ RegUsage := 1;
+ _RCX := IPointer(_Self);
+ end;
+ for I := 0 to Params.Count - 1 do
+ begin
+ if not GetPtr(rp(Params[I])) then Exit;
+ end;
+
+ if assigned(res) then begin
+ case res^.aType.BaseType of
+ {$IFDEF x64_string_result_as_varparameter}
+ btstring, btWideString, btUnicodeString,
+ {$ENDIF}
+ btInterface, btArray, btrecord, btVariant, btStaticArray: GetPtr(res);
+ btSet:
+ begin
+ if TPSTypeRec_Set(res.aType).aByteSize > PointerSize then GetPtr(res);
+ end;
+ end;
+ if Stack = nil then pp := nil else pp := @Stack[Length(Stack) -8];
+{$IFDEF WINDOWS}
+ x64call(Address, _RAX, _RCX, _RDX, _R8, _R9, _XMM0, _XMM1, _XMM2, _XMM3, pp, Length(Stack) div 8);
+{$ELSE}
+ x64call(Address, _RAX, _RDI, _RSI, _RDX, _RCX, _R8, _R9,_XMM0,_XMM1, _XMM2, _XMM3, _XMM4, _XMM5, _XMM6, _XMM7, pp, Length(Stack) div 8);
+{$ENDIF}
+ case res^.aType.BaseType of
+ btSet:
+ begin
+ case TPSTypeRec_Set(res.aType).aByteSize of
+ 1: byte(res.Dta^) := _RAX;
+ 2: word(res.Dta^) := _RAX;
+ 3,
+ 4: Longint(res.Dta^) := _RAX;
+ 5,6,7,8: IPointer(res.dta^) := _RAX;
+ end;
+ end;
+ btSingle: tbtsingle(res.Dta^) := _XMM0;
+ btDouble: tbtdouble(res.Dta^) := _XMM0;
+ btExtended: tbtextended(res.Dta^) := _XMM0;
+ btchar,btU8, btS8: tbtu8(res.dta^) := _RAX;
+ btWideChar, btu16, bts16: tbtu16(res.dta^) := _RAX;
+ btClass : IPointer(res.dta^) := _RAX;
+ btu32,bts32: tbtu32(res.dta^) := _RAX;
+ btPChar: pansichar(res.dta^) := Pansichar(_RAX);
+ bts64: tbts64(res.dta^) := Int64(_RAX);
+ btCurrency: tbtCurrency(res.Dta^) := Int64(_RAX);
+ btInterface,
+ btVariant,
+ {$IFDEF x64_string_result_as_varparameter}
+ btWidestring,btUnicodestring, btstring ,
+ {$ENDIF}
+ btStaticArray, btArray, btrecord:;
+ {$IFNDEF x64_string_result_as_varparameter}
+ btUnicodeString, btWideString, btstring: Int64(res.dta^) := _RAX;
+ {$ENDIF}
+ else
+ exit;
+ end;
+ end else begin
+ if Stack = nil then pp := nil else pp := @Stack[Length(Stack) -8];
+{$IFDEF WINDOWS}
+ x64call(Address, _RAX, _RCX, _RDX, _R8, _R9, _XMM0, _XMM1, _XMM2, _XMM3, pp, Length(Stack) div 8);
+{$ELSE}
+ x64call(Address, _RAX, _RDI, _RSI, _RDX, _RCX, _R8, _R9,_XMM0,_XMM1, _XMM2, _XMM3, _XMM4, _XMM5, _XMM6, _XMM7, pp, Length(Stack) div 8);
+{$ENDIF}
+ end;
+ Result := True;
+ finally
+ for i := CallData.Count -1 downto 0 do
+ begin
+ pp := CallData[i];
+ case pp^ of
+ 0: DestroyOpenArray(Self, Pointer(pp));
+ end;
+ end;
+ CallData.Free;
+ end;
+end;
+
+
diff --git a/Units/PascalScript/x86.inc b/Units/PascalScript/x86.inc
new file mode 100644
index 0000000..baa7641
--- /dev/null
+++ b/Units/PascalScript/x86.inc
@@ -0,0 +1,739 @@
+{ implementation of x86 abi }
+{$ifdef FPC}
+{$define PS_ARRAY_ON_STACK}
+{$endif}
+function RealFloatCall_Register(p: Pointer;
+ _EAX, _EDX, _ECX: Cardinal;
+ StackData: Pointer;
+ StackDataLen: Longint // stack length are in 4 bytes. (so 1 = 4 bytes)
+ ): Extended; Stdcall; // make sure all things are on stack
+var
+ E: Extended;
+begin
+ asm
+ mov ecx, stackdatalen
+ jecxz @@2
+ mov eax, stackdata
+ @@1:
+ mov edx, [eax]
+ push edx
+ sub eax, 4
+ dec ecx
+ or ecx, ecx
+ jnz @@1
+ @@2:
+ mov eax,_EAX
+ mov edx,_EDX
+ mov ecx,_ECX
+ call p
+ fstp tbyte ptr [e]
+ end;
+ Result := E;
+end;
+
+function RealFloatCall_Other(p: Pointer;
+ StackData: Pointer;
+ StackDataLen: Longint // stack length are in 4 bytes. (so 1 = 4 bytes)
+ ): Extended; Stdcall; // make sure all things are on stack
+var
+ E: Extended;
+begin
+ asm
+ mov ecx, stackdatalen
+ jecxz @@2
+ mov eax, stackdata
+ @@1:
+ mov edx, [eax]
+ push edx
+ sub eax, 4
+ dec ecx
+ or ecx, ecx
+ jnz @@1
+ @@2:
+ call p
+ fstp tbyte ptr [e]
+ end;
+ Result := E;
+end;
+
+function RealFloatCall_CDecl(p: Pointer;
+ StackData: Pointer;
+ StackDataLen: Longint // stack length are in 4 bytes. (so 1 = 4 bytes)
+ ): Extended; Stdcall; // make sure all things are on stack
+var
+ E: Extended;
+begin
+ asm
+ mov ecx, stackdatalen
+ jecxz @@2
+ mov eax, stackdata
+ @@1:
+ mov edx, [eax]
+ push edx
+ sub eax, 4
+ dec ecx
+ or ecx, ecx
+ jnz @@1
+ @@2:
+ call p
+ fstp tbyte ptr [e]
+ @@5:
+ mov ecx, stackdatalen
+ jecxz @@2
+ @@6:
+ pop edx
+ dec ecx
+ or ecx, ecx
+ jnz @@6
+ end;
+ Result := E;
+end;
+
+function RealCall_Register(p: Pointer;
+ _EAX, _EDX, _ECX: Cardinal;
+ StackData: Pointer;
+ StackDataLen: Longint; // stack length are in 4 bytes. (so 1 = 4 bytes)
+ ResultLength: Longint; ResEDX: Pointer): Longint; Stdcall; // make sure all things are on stack
+var
+ r: Longint;
+begin
+ asm
+ mov ecx, stackdatalen
+ jecxz @@2
+ mov eax, stackdata
+ @@1:
+ mov edx, [eax]
+ push edx
+ sub eax, 4
+ dec ecx
+ or ecx, ecx
+ jnz @@1
+ @@2:
+ mov eax,_EAX
+ mov edx,_EDX
+ mov ecx,_ECX
+ call p
+ mov ecx, resultlength
+ cmp ecx, 0
+ je @@5
+ cmp ecx, 1
+ je @@3
+ cmp ecx, 2
+ je @@4
+ mov r, eax
+ jmp @@5
+ @@3:
+ xor ecx, ecx
+ mov cl, al
+ mov r, ecx
+ jmp @@5
+ @@4:
+ xor ecx, ecx
+ mov cx, ax
+ mov r, ecx
+ @@5:
+ mov ecx, resedx
+ jecxz @@6
+ mov [ecx], edx
+ @@6:
+ end;
+ Result := r;
+end;
+
+function RealCall_Other(p: Pointer;
+ StackData: Pointer;
+ StackDataLen: Longint; // stack length are in 4 bytes. (so 1 = 4 bytes)
+ ResultLength: Longint; ResEDX: Pointer): Longint; Stdcall; // make sure all things are on stack
+var
+ r: Longint;
+begin
+ asm
+ mov ecx, stackdatalen
+ jecxz @@2
+ mov eax, stackdata
+ @@1:
+ mov edx, [eax]
+ push edx
+ sub eax, 4
+ dec ecx
+ or ecx, ecx
+ jnz @@1
+ @@2:
+ call p
+ mov ecx, resultlength
+ cmp ecx, 0
+ je @@5
+ cmp ecx, 1
+ je @@3
+ cmp ecx, 2
+ je @@4
+ mov r, eax
+ jmp @@5
+ @@3:
+ xor ecx, ecx
+ mov cl, al
+ mov r, ecx
+ jmp @@5
+ @@4:
+ xor ecx, ecx
+ mov cx, ax
+ mov r, ecx
+ @@5:
+ mov ecx, resedx
+ jecxz @@6
+ mov [ecx], edx
+ @@6:
+ end;
+ Result := r;
+end;
+
+function RealCall_CDecl(p: Pointer;
+ StackData: Pointer;
+ StackDataLen: Longint; // stack length are in 4 bytes. (so 1 = 4 bytes)
+ ResultLength: Longint; ResEDX: Pointer): Longint; Stdcall; // make sure all things are on stack
+var
+ r: Longint;
+begin
+ asm
+ mov ecx, stackdatalen
+ jecxz @@2
+ mov eax, stackdata
+ @@1:
+ mov edx, [eax]
+ push edx
+ sub eax, 4
+ dec ecx
+ or ecx, ecx
+ jnz @@1
+ @@2:
+ call p
+ mov ecx, resultlength
+ cmp ecx, 0
+ je @@5
+ cmp ecx, 1
+ je @@3
+ cmp ecx, 2
+ je @@4
+ mov r, eax
+ jmp @@5
+ @@3:
+ xor ecx, ecx
+ mov cl, al
+ mov r, ecx
+ jmp @@5
+ @@4:
+ xor ecx, ecx
+ mov cx, ax
+ mov r, ecx
+ @@5:
+ mov ecx, stackdatalen
+ jecxz @@7
+ @@6:
+ pop eax
+ dec ecx
+ or ecx, ecx
+ jnz @@6
+ mov ecx, resedx
+ jecxz @@7
+ mov [ecx], edx
+ @@7:
+ end;
+ Result := r;
+end;
+
+const
+ EmptyPchar: array[0..0] of char = #0;
+
+function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean;
+var
+ Stack: ansistring;
+ I: Longint;
+ RegUsage: Byte;
+ CallData: TPSList;
+ pp: ^Byte;
+ IsConstructor: Boolean;
+
+ EAX, EDX, ECX: Longint;
+
+ function rp(p: PPSVariantIFC): PPSVariantIFC;
+ begin
+ if p = nil then
+ begin
+ result := nil;
+ exit;
+ end;
+ if p.aType.BaseType = btPointer then
+ begin
+ p^.aType := Pointer(Pointer(IPointer(p^.dta) + 4)^);
+ p^.Dta := Pointer(p^.dta^);
+ end;
+ Result := p;
+ end;
+
+ function GetPtr(fVar: PPSVariantIFC): Boolean;
+ var
+ varPtr: Pointer;
+ UseReg: Boolean;
+ tempstr: tbtstring;
+ p: Pointer;
+ begin
+ Result := False;
+ if FVar = nil then exit;
+ if fVar.VarParam then
+ begin
+ case fvar.aType.BaseType of
+ btArray:
+ begin
+ if Copy(fvar.aType.ExportName, 1, 10) = '!OPENARRAY' then
+ begin
+ p := CreateOpenArray(True, Self, FVar);
+ if p = nil then exit;
+ CallData.Add(p);
+ case RegUsage of
+ 0: begin EAX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end;
+ 1: begin EDX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end;
+ 2: begin ECX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end;
+ else begin
+ Stack := StringOfChar(AnsiChar(#0),4) + Stack;
+ Pointer((@Stack[1])^) := POpenArray(p)^.Data;
+ end;
+ end;
+ case RegUsage of
+ 0: begin EAX := Longint(POpenArray(p)^.ItemCount - 1); Inc(RegUsage); end;
+ 1: begin EDX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end;
+ 2: begin ECX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end;
+ else begin
+ Stack := StringOfChar(AnsiChar(#0),4) + Stack;
+ Longint((@Stack[1])^) := POpenArray(p)^.ItemCount -1;
+ end;
+ end;
+ Result := True;
+ Exit;
+ end else begin
+ {$IFDEF PS_DYNARRAY}
+ varptr := fvar.Dta;
+ {$ELSE}
+ Exit;
+ {$ENDIF}
+ end;
+ end;
+ btVariant,
+ btSet,
+ btStaticArray,
+ btRecord,
+ btInterface,
+ btClass,
+ {$IFNDEF PS_NOWIDESTRING} btUnicodeString, btWideString, btWideChar, {$ENDIF} btU8, btS8, btU16,
+ btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency
+ {$IFNDEF PS_NOINT64}, bts64{$ENDIF}:
+ begin
+ Varptr := fvar.Dta;
+ end;
+ else begin
+ exit; //invalid type
+ end;
+ end; {case}
+ case RegUsage of
+ 0: begin EAX := Longint(VarPtr); Inc(RegUsage); end;
+ 1: begin EDX := Longint(VarPtr); Inc(RegUsage); end;
+ 2: begin ECX := Longint(VarPtr); Inc(RegUsage); end;
+ else begin
+ Stack := StringOfChar(AnsiChar(#0),4) + Stack;
+ Pointer((@Stack[1])^) := VarPtr;
+ end;
+ end;
+ end else begin
+ UseReg := True;
+ case fVar^.aType.BaseType of
+ btSet:
+ begin
+ tempstr := StringOfChar(AnsiChar(#0),4);
+ case TPSTypeRec_Set(fvar.aType).aByteSize of
+ 1: Byte((@tempstr[1])^) := byte(fvar.dta^);
+ 2: word((@tempstr[1])^) := word(fvar.dta^);
+ 3, 4: cardinal((@tempstr[1])^) := cardinal(fvar.dta^);
+ else
+ pointer((@tempstr[1])^) := fvar.dta;
+ end;
+ end;
+ btArray:
+ begin
+ if Copy(fvar^.aType.ExportName, 1, 10) = '!OPENARRAY' then
+ begin
+ p := CreateOpenArray(False, SElf, FVar);
+ if p =nil then exit;
+ CallData.Add(p);
+ case RegUsage of
+ 0: begin EAX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end;
+ 1: begin EDX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end;
+ 2: begin ECX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end;
+ else begin
+ Stack := StringOfChar(AnsiChar(#0),4) + Stack;
+ Pointer((@Stack[1])^) := POpenArray(p)^.Data;
+ end;
+ end;
+ case RegUsage of
+ 0: begin EAX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end;
+ 1: begin EDX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end;
+ 2: begin ECX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end;
+ else begin
+ Stack := StringOfChar(AnsiChar(#0),4) + Stack;
+ Longint((@Stack[1])^) := POpenArray(p)^.ItemCount -1;
+ end;
+ end;
+ Result := True;
+ exit;
+ end else begin
+ {$IFDEF PS_DYNARRAY}
+ TempStr := StringOfChar(AnsiChar(#0),4);
+ Pointer((@TempStr[1])^) := Pointer(fvar.Dta^);
+ {$IFDEF PS_ARRAY_ON_STACK}
+ UseReg := false;
+ {$ENDIF}
+ {$ELSE}
+ Exit;
+ {$ENDIF}
+ end;
+ end;
+ btVariant
+ , btStaticArray, btRecord:
+ begin
+ TempStr := StringOfChar(AnsiChar(#0),4);
+ Pointer((@TempStr[1])^) := Pointer(fvar.Dta);
+ end;
+ btDouble: {8 bytes} begin
+ TempStr := StringOfChar(AnsiChar(#0),8);
+ UseReg := False;
+ double((@TempStr[1])^) := double(fvar.dta^);
+ end;
+ btCurrency: {8 bytes} begin
+ TempStr := StringOfChar(AnsiChar(#0),8);
+ UseReg := False;
+ currency((@TempStr[1])^) := currency(fvar.dta^);
+ end;
+ btSingle: {4 bytes} begin
+ TempStr := StringOfChar(AnsiChar(#0),4);;
+ UseReg := False;
+ Single((@TempStr[1])^) := single(fvar.dta^);
+ end;
+
+ btExtended: {10 bytes} begin
+ UseReg := False;
+ TempStr:= StringOfChar(AnsiChar(#0),12);
+ Extended((@TempStr[1])^) := extended(fvar.dta^);
+ end;
+ btChar,
+ btU8,
+ btS8: begin
+ TempStr := tbtchar(fVar^.dta^) + tbtstring(StringOfChar(AnsiChar(#0),3));
+ end;
+ {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}
+ btu16, btS16: begin
+ TempStr := StringOfChar(AnsiChar(#0),4);
+ Word((@TempStr[1])^) := word(fVar^.dta^);
+ end;
+ btu32, bts32: begin
+ TempStr := StringOfChar(AnsiChar(#0),4);
+ Longint((@TempStr[1])^) := Longint(fVar^.dta^);
+ end;
+ btPchar:
+ begin
+ TempStr := StringOfChar(AnsiChar(#0),4);
+ if pointer(fvar^.dta^) = nil then
+ Pointer((@TempStr[1])^) := @EmptyPchar
+ else
+ Pointer((@TempStr[1])^) := pointer(fvar^.dta^);
+ end;
+ btclass, btinterface, btString:
+ begin
+ TempStr := StringOfChar(AnsiChar(#0),4);
+ Pointer((@TempStr[1])^) := pointer(fvar^.dta^);
+ end;
+ {$IFNDEF PS_NOWIDESTRING}
+ btWideString: begin
+ TempStr := StringOfChar(AnsiChar(#0),4);
+ Pointer((@TempStr[1])^) := pointer(fvar^.dta^);
+ end;
+ btUnicodeString: begin
+ TempStr := StringOfChar(AnsiChar(#0),4);
+ Pointer((@TempStr[1])^) := pointer(fvar^.dta^);
+ end;
+ {$ENDIF}
+
+ btProcPtr:
+ begin
+ tempstr := StringOfChar(AnsiChar(#0),8);
+ TMethod((@TempStr[1])^) := MKMethod(Self, Longint(FVar.Dta^));
+ UseReg := false;
+ end;
+
+ {$IFNDEF PS_NOINT64}bts64:
+ begin
+ TempStr:= StringOfChar(AnsiChar(#0),8);
+ Int64((@TempStr[1])^) := int64(fvar^.dta^);
+ UseReg := False;
+ end;{$ENDIF}
+ end; {case}
+ if UseReg then
+ begin
+ case RegUsage of
+ 0: begin EAX := Longint((@Tempstr[1])^); Inc(RegUsage); end;
+ 1: begin EDX := Longint((@Tempstr[1])^); Inc(RegUsage); end;
+ 2: begin ECX := Longint((@Tempstr[1])^); Inc(RegUsage); end;
+ else begin
+ {$IFDEF FPC_OLD_FIX}
+ if CallingConv = cdRegister then
+ Stack := Stack + TempStr
+ else
+ {$ENDIF}
+ Stack := TempStr + Stack;
+ end;
+ end;
+ end else begin
+ {$IFDEF FPC_OLD_FIX}
+ if CallingConv = cdRegister then
+ Stack := Stack + TempStr
+ else
+ {$ENDIF}
+ Stack := TempStr + Stack;
+ end;
+ end;
+ Result := True;
+ end;
+begin
+ if (Integer(CallingConv) and 64) <> 0 then begin
+ IsConstructor := true;
+ CAllingConv := TPSCallingConvention(Integer(CallingConv) and not 64);
+ end else IsConstructor := false;
+
+ InnerfuseCall := False;
+ if Address = nil then
+ exit; // need address
+ Stack := '';
+ CallData := TPSList.Create;
+ res := rp(res);
+ if res <> nil then
+ res.VarParam := true;
+ try
+ case CallingConv of
+ cdRegister: begin
+ EAX := 0;
+ EDX := 0;
+ ECX := 0;
+ RegUsage := 0;
+
+{$IFDEF FPC} // FIX FOR FPC constructor calls
+ if IsConstructor then begin
+ if not GetPtr(rp(Params[0])) then exit; // this goes first
+ RegUsage := 2;
+ EDX := Longint(_Self);
+ Params.Delete(0);
+ end else
+{$ENDIF}
+ if assigned(_Self) then begin
+ RegUsage := 1;
+ EAX := Longint(_Self);
+ end;
+
+ for I := 0 to Params.Count - 1 do
+ begin
+ if not GetPtr(rp(Params[I])) then Exit;
+ end;
+
+ if assigned(res) then begin
+ case res^.aType.BaseType of
+ {$IFNDEF PS_NOWIDESTRING}btWideString, btUnicodeString, {$ENDIF}
+ btInterface, btArray, btrecord, {$IFNDEF PS_FPCSTRINGWORKAROUND}btstring, {$ENDIF}btVariant, btStaticArray: GetPtr(res);
+ btSet:
+ begin
+ if TPSTypeRec_Set(res.aType).aByteSize >4 then GetPtr(res);
+ end;
+ end;
+ case res^.aType.BaseType of
+ btSet:
+ begin
+ case TPSTypeRec_Set(res.aType).aByteSize of
+ 1: byte(res.Dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil);
+ 2: word(res.Dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil);
+ 3,
+ 4: Longint(res.Dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
+ else RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil)
+ end;
+ end;
+ btSingle: tbtsingle(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4);
+ btDouble: tbtdouble(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4);
+ btExtended: tbtextended(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4);
+ btchar,btU8, btS8: tbtu8(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil);
+ {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil);
+ btClass :
+ {$IFDEF FPC_OLD_FIX}
+ tbtu32(res.dta^) := RealCall_Register(Address, EDX, EAX, ECX,
+ @Stack[Length(Stack) - 3], Length(Stack) div 4, 4, nil);
+ {$ELSE}
+ tbtu32(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX,
+ @Stack[Length(Stack) - 3], Length(Stack) div 4, 4, nil);
+ {$ENDIF}
+
+ btu32,bts32: tbtu32(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
+ btPChar: pansichar(res.dta^) := Pansichar(RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil));
+ {$IFNDEF PS_NOINT64}bts64:
+ begin
+ EAX := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX);
+ tbts64(res.dta^) := Int64(Cardinal(EDX)) shl 32 or Cardinal(EAX);
+ end;
+ {$ENDIF}
+ btCurrency: tbtCurrency(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4) / 10000;
+ btInterface,
+ btVariant,
+ {$IFNDEF PS_NOWIDESTRING}btWidestring,btUnicodestring, {$ENDIF}
+ btStaticArray, btArray, btrecord{$IFNDEF PS_FPCSTRINGWORKAROUND}, btstring {$ENDIF}: RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
+ {$IFDEF PS_FPCSTRINGWORKAROUND}
+ btstring: begin
+ eax := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
+ Longint(res.dta^) := eax;
+ end;
+ {$ENDIF}
+ else
+ exit;
+ end;
+ end else
+ RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
+ Result := True;
+ end;
+ cdPascal: begin
+ RegUsage := 3;
+ for I := 0 to Params.Count - 1 do begin
+ if not GetPtr(Params[i]) then Exit;
+ end;
+ if assigned(res) then begin
+ case res^.aType.BaseType of
+ {$IFNDEF PS_NOWIDESTRING}btWideString, btUnicodeString, {$ENDIF}btInterface, btArray, btrecord, btstring, btVariant: GetPtr(res);
+ end;
+ end;
+ if assigned(_Self) then begin
+ Stack := StringOfChar(AnsiChar(#0),4) +Stack;
+ Pointer((@Stack[1])^) := _Self;
+ end;
+ if assigned(res) then begin
+ case res^.aType.BaseType of
+ btSingle: tbtsingle(res^.Dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
+ btDouble: tbtdouble(res^.Dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
+ btExtended: tbtextended(res^.Dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
+ btChar, btU8, btS8: tbtu8(res^.Dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil);
+ {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res^.Dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil);
+ btClass, btu32, bts32: tbtu32(res^.Dta^):= RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
+ btPChar: TBTSTRING(res^.dta^) := Pansichar(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil));
+ {$IFNDEF PS_NOINT64}bts64:
+ begin
+ EAX := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX);
+ tbts64(res^.dta^) := Int64(EAX) shl 32 or EDX;
+ end;
+ {$ENDIF}
+ btVariant,
+ btInterface, btrecord, btstring: RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
+ else
+ exit;
+ end;
+ end else
+ RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
+ Result := True;
+ end;
+ cdSafeCall: begin
+ RegUsage := 3;
+ if assigned(res) then begin
+ GetPtr(res);
+ end;
+ for I := Params.Count - 1 downto 0 do begin
+ if not GetPtr(Params[i]) then Exit;
+ end;
+ if assigned(_Self) then begin
+ Stack := StringOfChar(AnsiChar(#0),4) +Stack;
+ Pointer((@Stack[1])^) := _Self;
+ end;
+ OleCheck(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil));
+ Result := True;
+ end;
+
+ CdCdecl: begin
+ RegUsage := 3;
+ if assigned(_Self) then begin
+ Stack := StringOfChar(AnsiChar(#0),4);
+ Pointer((@Stack[1])^) := _Self;
+ end;
+ for I := Params.Count - 1 downto 0 do begin
+ if not GetPtr(Params[I]) then Exit;
+ end;
+ if assigned(res) then begin
+ case res^.aType.BaseType of
+ btSingle: tbtsingle(res^.dta^) := RealFloatCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
+ btDouble: tbtdouble(res^.dta^) := RealFloatCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
+ btExtended: tbtextended(res^.dta^) := RealFloatCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
+ btCHar, btU8, btS8: tbtu8(res^.dta^) := RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil);
+ {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res^.dta^) := RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil);
+ btClass, btu32, bts32: tbtu32(res^.dta^) := RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
+ btPChar: TBTSTRING(res^.dta^) := Pansichar(RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil));
+ {$IFNDEF PS_NOINT64}bts64:
+ begin
+ EAX := RealCall_CDecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX);
+ tbts64(res^.Dta^) := Int64(EAX) shl 32 or EDX;
+ end;
+ {$ENDIF}
+ btVariant, {$IFNDEF PS_NOWIDESTRING}btUnicodeString, btWideString, {$ENDIF}
+ btInterface,
+ btArray, btrecord, btstring: begin GetPtr(res); RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); end;
+ else
+ exit;
+ end;
+ end else begin
+ RealCall_CDecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
+ end;
+ Result := True;
+ end;
+ CdStdCall: begin
+ RegUsage := 3;
+ for I := Params.Count - 1 downto 0 do begin
+ if not GetPtr(Params[I]) then exit;
+ end;
+ if assigned(_Self) then begin
+ Stack := StringOfChar(AnsiChar(#0),4) + Stack;
+ Pointer((@Stack[1])^) := _Self;
+ end;
+ if assigned(res) then begin
+ case res^.aType.BaseType of
+ btSingle: tbtsingle(res^.dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
+ btDouble: tbtdouble(res^.dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
+ btExtended: tbtextended(res^.dta^):= RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
+ btChar, btU8, btS8: tbtu8(res^.dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil);
+ {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res^.dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil);
+ btclass, btu32, bts32: tbtu32(res^.dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
+ btPChar: TBTSTRING(res^.dta^) := Pansichar(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil));
+ {$IFNDEF PS_NOINT64}bts64:
+ begin
+ EAX := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX);
+ tbts64(res^.dta^) := Int64(EAX) shl 32 or EDX;
+ end;
+ {$ENDIF}
+ btVariant, {$IFNDEF PS_NOWIDESTRING}btUnicodeString, btWideString, {$ENDIF}
+ btInterface, btArray, btrecord, btstring: begin GetPtr(res); RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); end;
+ else
+ exit;
+ end;
+ end else begin
+ RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
+ end;
+ Result := True;
+ end;
+ end;
+ finally
+ for i := CallData.Count -1 downto 0 do
+ begin
+ pp := CallData[i];
+ case pp^ of
+ 0: DestroyOpenArray(Self, Pointer(pp));
+ end;
+ end;
+ CallData.Free;
+ end;
+end;
+
+