1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
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.
|
