1 {
2 This file is part of the Free Pascal run time library.
3 Copyright (c) 2004 Karoly Balogh for Genesi S.a.r.l. <www.genesi.lu>
4
5 utility.library interface unit for MorphOS/PowerPC
6
7 MorphOS port was done on a free Pegasos II/G4 machine
8 provided by Genesi S.a.r.l. <www.genesi.lu>
9
10 See the file COPYING.FPC, included in this distribution,
11 for details about the copyright.
12
13 This program is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
16
17 **********************************************************************}
18 {$inline on}
19 unit utility;
20
21 interface
22
23 uses
24 exec;
25
26 var
27 UtilityBase: Pointer;
28
29 // utility.library date defines
30 type
31 PClockData = ^TClockData;
32 TClockData = packed record
33 Sec: Word;
34 Min: Word;
35 Hour: Word;
36 MDay: Word;
37 Month: Word;
38 Year: Word;
39 WDay: Word;
40 end;
41
42
43 // utility.library tagitem defines
44 type
45 Tag = LongWord;
46 PTag = ^Tag;
47
48 PPTagItem = ^PTagItem;
49 PTagItem = ^TTagItem;
50 TTagItem = packed record
51 ti_Tag : Tag;
52 ti_Data: LongWord;
53 end;
54
55
56 const
57 TAG_DONE = 0;
58 TAG_END = 0;
59 TAG_IGNORE = 1;
60 TAG_MORE = 2;
61 TAG_SKIP = 3;
62
63 TAG_USER = DWord(1 Shl 31);
64
65 TAGFILTER_AND = 0;
66 TAGFILTER_NOT = 1;
67
68 MAP_REMOVE_NOT_FOUND = 0;
69 MAP_KEEP_NOT_FOUND = 1;
70
71 // utility.library namespace defines
72 type
73 PNamedObject = ^TNamedObject;
74 TNamedObject = packed record
75 no_Object: APTR;
76 end;
77
78 const
79 ANO_NameSpace = 4000;
80 ANO_UserSpace = 4001;
81 ANO_Priority = 4002;
82 ANO_Flags = 4003;
83
84 NSB_NODUPS = 0;
85 NSB_CASE = 1;
86
87 NSF_NODUPS = 1 Shl NSB_NODUPS;
88 NSF_CASE = 1 Shl NSB_CASE;
89
90 // utility.library pack attributes and macros
91 const
92 PSTB_SIGNED = 31;
93 PSTB_UNPACK = 30;
94 PSTB_PACK = 29;
95 PSTB_EXISTS = 26;
96
97 PSTF_SIGNED = 1 Shl PSTB_SIGNED;
98 PSTF_UNPACK = 1 Shl PSTB_UNPACK;
99 PSTF_PACK = 1 Shl PSTB_PACK;
100 PSTF_EXISTS = 1 Shl PSTB_EXISTS;
101
102 const
103 PKCTRL_PACKUNPACK = $00000000;
104 PKCTRL_PACKONLY = $40000000;
105 PKCTRL_UNPACKONLY = $20000000;
106
107 PKCTRL_BYTE = $80000000;
108 PKCTRL_WORD = $88000000;
109 PKCTRL_LONG = $90000000;
110
111 PKCTRL_UBYTE = $00000000;
112 PKCTRL_UWORD = $08000000;
113 PKCTRL_ULONG = $10000000;
114
115 PKCTRL_BIT = $18000000;
116 PKCTRL_FLIPBIT = $98000000;
117
118 {$WARNING FIX ME!!! Some macros to convert}
119 {
120 PK_BITNUM1(flg) ((flg) == 0x01 ? 0 : (flg) == 0x02 ? 1 : (flg) == 0x04 ? 2 : (flg) == 0x08 ? 3 : (flg) == 0x10 ? 4 : (flg) == 0x20 ? 5 : (flg) == 0x40 ? 6 : 7)
121 PK_BITNUM2(flg) ((flg < 0x100 ? PK_BITNUM1(flg) : 8 + PK_BITNUM1(flg >> 8)))
122 PK_BITNUM(flg) ((flg < 0x10000 ? PK_BITNUM2(flg) : 16 + PK_BITNUM2(flg >> 16)))
123 PK_WORDOFFSET(flg) ((flg) < 0x100 ? 1 : 0)
124 PK_LONGOFFSET(flg) ((flg) < 0x100 ? 3 : (flg) < 0x10000 ? 2 : (flg) < 0x1000000 ? 1 : 0)
125 PK_CALCOFFSET(type,field) ((ULONG)(&((struct type *)0)->field))
126
127
128 PACK_STARTTABLE(tagbase) (tagbase)
129 PACK_NEWOFFSET(tagbase) (-1L),(tagbase)
130 PACK_ENDTABLE 0
131 PACK_ENTRY(tagbase,tag,type,field,control) (control | ((tag-tagbase) << 16L) | PK_CALCOFFSET(type,field))
132 PACK_BYTEBIT(tagbase,tag,type,field,control,flags) (control | ((tag-tagbase) << 16L) | PK_CALCOFFSET(type,field) | (PK_BITNUM(flags) << 13L))
133 PACK_WORDBIT(tagbase,tag,type,field,control,flags) (control | ((tag-tagbase) << 16L) | (PK_CALCOFFSET(type,field) + PK_WORDOFFSET(flags)) | ((PK_BITNUM(flags) & 7) << 13L))
134 PACK_LONGBIT(tagbase,tag,type,field,control,flags) (control | ((tag-tagbase) << 16L) | (PK_CALCOFFSET(type,field) + PK_LONGOFFSET(flags)) | ((PK_BITNUM(flags) & 7) << 13L))
135 }
136
137 // utility.library include
138 const
139 UtilityName = 'utility.library';
140
141
142 type
143 PUtilityBase = ^TUtilityBase;
144 TUtilityBase = packed record
145 ub_LibNode : TLibrary;
146 ub_Language: Byte;
147 ub_Reserved: Byte;
148 end;
149
150 // utility.library hook defines
151 type
152 PHook = ^THook;
153 THook = packed record
154 h_MinNode : TMinNode;
155 h_Entry : Pointer;
156 h_SubEntry: Pointer;
157 h_Data : APTR;
158 end;
159
160
FindTagItemnull161 function FindTagItem(TagVal: Tag location 'd0'; TagList: PTagItem location 'a0'): PTagItem; SysCall MOS_UtilityBase 030;
GetTagDatanull162 function GetTagData(TagValue: Tag location 'd0'; DefaultVal: LongWord location 'd1'; TagList: PTagItem location 'a0'): LongWord; SysCall MOS_UtilityBase 036;
PackBoolTagsnull163 function PackBoolTags(InitialFlags: LongWord location 'd0'; TagList: PTagItem location 'a0'; BoolMap: PTagItem location 'a1'): LongWord; SysCall MOS_UtilityBase 042;
NextTagItemnull164 function NextTagItem(TagListPtr: PPTagItem location 'a0'): PTagItem; overload; SysCall MOS_UtilityBase 048;
NextTagItemnull165 function NextTagItem(var TagList: PTagItem location 'a0'): PTagItem; overload; SysCall MOS_UtilityBase 048;
166 procedure FilterTagChanges(ChangeList: PTagItem location 'a0'; OriginalList: PTagItem location 'a1'; Apply: LongWord location 'd0'); SysCall MOS_UtilityBase 054;
167 procedure MapTags(TagList: PTagItem location 'a0'; MapList: PTagItem location 'a1'; MapType: Cardinal location 'd0'); SysCall MOS_UtilityBase 060;
AllocateTagItemsnull168 function AllocateTagItems(NumTags: Cardinal location 'd0'): PTagItem; SysCall MOS_UtilityBase 066;
CloneTagItemsnull169 function CloneTagItems(TagList: PTagItem location 'a0'): PTagItem; SysCall MOS_UtilityBase 072;
170 procedure FreeTagItems(TagList: PTagItem location 'a0'); SysCall MOS_UtilityBase 078;
171 procedure RefreshTagItemClones(Clone: PTagItem location 'a0'; Original: PTagItem location 'a1'); SysCall MOS_UtilityBase 084;
TagInArraynull172 function TagInArray(TagValue: Tag location 'd0'; TagArray: PTag location 'a0'): LongBool; SysCall MOS_UtilityBase 090;
FilterTagItemsnull173 function FilterTagItems(TagList: PTagItem location 'a0'; FilterArray: PTag location 'a1'; Logic: LongWord location 'd0'): LongWord; SysCall MOS_UtilityBase 096;
174
CallHookPktnull175 function CallHookPkt(Hook: PHook location 'a0'; HObject: APTR location 'a2'; ParamPacket: APTR location 'a1'): LongWord; SysCall MOS_UtilityBase 102;
176
177 procedure Amiga2Date(Seconds: LongWord location 'd0'; Result: PClockData location 'a0'); SysCall MOS_UtilityBase 120;
Date2Amiganull178 function Date2Amiga(Date: PClockData location 'a0'): LongWord; SysCall MOS_UtilityBase 126;
CheckDatenull179 function CheckDate(Date: PClockData location 'a0'): LongWord; SysCall MOS_UtilityBase 132;
180
SMult32null181 function SMult32(Arg1: LongInt location 'd0'; Arg2: LongInt location 'd1'): LongInt; SysCall MOS_UtilityBase 138;
UMult32null182 function UMult32(Arg1: LongWord location 'd0'; Arg2: LongWord location 'd1'): LongWord; SysCall MOS_UtilityBase 144;
183
SDivMod32null184 function SDivMod32(Dividend: LongInt location 'd0'; Divisor: LongInt location 'd1'): LongInt; SysCall MOS_UtilityBase 150;
UDivMod32null185 function UDivMod32(Dividend: LongWord location 'd0'; Divisor: LongWord location 'd1'): LongWord; SysCall MOS_UtilityBase 156;
186
Stricmpnull187 function Stricmp(String1: STRPTR location 'a0'; String2: STRPTR location 'a1'): LongInt; SysCall MOS_UtilityBase 162;
Strnicmpnull188 function Strnicmp(String1: STRPTR location 'a0'; String2: STRPTR location 'a1'; Length: LongInt location 'd0'): LongInt; SysCall MOS_UtilityBase 168;
ToUppernull189 function ToUpper(Character: LongWord location 'd0'): Char; SysCall MOS_UtilityBase 174;
ToLowernull190 function ToLower(character: LongWord location 'd0'): Char; SysCall MOS_UtilityBase 180;
191
192 procedure ApplyTagChanges(List: PTagItem location 'a0'; ChangeList: PTagItem location 'a1'); SysCall MOS_UtilityBase 186;
193
SMult64null194 function SMult64(Arg1: LongInt location 'd0'; Arg2: LongInt location 'd1'): LongInt; SysCall MOS_UtilityBase 198;
UMult64null195 function UMult64(Arg1: LongWord location 'd0'; Arg2: LongWord location 'd1'): LongWord; SysCall MOS_UtilityBase 204;
196
PackStructureTagsnull197 function PackStructureTags(Pack: APTR location 'a0'; PackTable: PLongWord location 'a1'; TagList: PTagItem location 'a2'): LongWord; SysCall MOS_UtilityBase 210;
UnpackStructureTagsnull198 function UnpackStructureTags(Pack: APTR location 'a0'; PackTable: PLongWord location 'a1'; TagList: PTagItem location 'a2'): LongWord; SysCall MOS_UtilityBase 216;
199
AddNamedObjectnull200 function AddNamedObject(NameSpace: PNamedObject location 'a0'; NObject: PNamedObject location 'a1'): LongBool; SysCall MOS_UtilityBase 222;
AllocNamedObjectAnull201 function AllocNamedObjectA(Name: STRPTR location 'a0'; TagList: PTagItem location 'a1'): PNamedObject; SysCall MOS_UtilityBase 228;
AttemptRemNamedObjectnull202 function AttemptRemNamedObject(NObject: PNamedObject location 'a0'): LongInt; SysCall MOS_UtilityBase 234;
FindNamedObjectnull203 function FindNamedObject(NameSpace: PNamedObject location 'a0'; Name: STRPTR location 'a1'; LastObject: PNamedObject location 'a2'): PNamedObject; SysCall MOS_UtilityBase 240;
204 procedure FreeNamedObject(NObject: PNamedObject location 'a0'); SysCall MOS_UtilityBase 246;
NamedObjectNamenull205 function NamedObjectName(NObject: PNamedObject location 'a0'): STRPTR; SysCall MOS_UtilityBase 252;
206 procedure ReleaseNamedObject(NObject: PNamedObject location 'a0'); SysCall MOS_UtilityBase 258;
207 procedure RemNamedObject(NObject: PNamedObject location 'a0'; Message: PMessage location 'a1'); SysCall MOS_UtilityBase 264;
208
GetUniqueIDnull209 function GetUniqueID: LongWord; SysCall MOS_UtilityBase 270;
210
211 // varargs version
AllocNamedObjectnull212 function AllocNamedObject(Name: STRPTR; const Tags: array of PtrUInt): PNamedObject; inline;
213
TAG_null214 function TAG_(Value: Pointer): PtrUInt; overload; inline;
TAG_null215 function TAG_(Value: PChar): PtrUInt; overload; inline;
TAG_null216 function TAG_(Value: Boolean): PtrUInt; overload; inline;
TAG_null217 function TAG_(Value: LongInt): PtrUInt; overload; inline;
TAG_null218 function TAG_(Value: LongWord): PtrUInt; overload; inline;
219
AsTagnull220 function AsTag(Value: Pointer): PtrUInt; overload; inline;
AsTagnull221 function AsTag(Value: PChar): PtrUInt; overload; inline;
AsTagnull222 function AsTag(Value: Boolean): PtrUInt; overload; inline;
AsTagnull223 function AsTag(Value: LongInt): PtrUInt; overload; inline;
AsTagnull224 function AsTag(Value: LongWord): PtrUInt; overload; inline;
225
226 // Hook and Dispatcher Helper
227 { This procedure is used to pop Dispatcher arguments from the EmulHandle }
228 procedure DISPATCHERARG(var cl; var obj; var msg);
HookEntrynull229 function HookEntry: PtrUInt;
230
231 implementation
232
AllocNamedObjectnull233 function AllocNamedObject(Name: STRPTR; const Tags: array of PtrUInt): PNamedObject; inline;
234 begin
235 AllocNamedObject := AllocNamedObjectA(Name, @Tags);
236 end;
237
TAG_null238 function TAG_(Value: Pointer): PtrUInt; inline;
239 begin
240 TAG_ := PtrUInt(Value);
241 end;
242
TAG_null243 function TAG_(Value: PChar): PtrUInt; inline;
244 begin
245 TAG_ := PtrUInt(Value);
246 end;
247
TAG_null248 function TAG_(Value: Boolean): PtrUInt; inline;
249 begin
250 if Value then
251 TAG_ := LTrue
252 else
253 TAG_ := LFalse;
254 end;
255
TAG_null256 function TAG_(Value: LongInt): PtrUInt; inline;
257 begin
258 TAG_ := PtrUInt(Value);
259 end;
260
TAG_null261 function TAG_(Value: LongWord): PtrUInt; inline;
262 begin
263 TAG_ := PtrUInt(Value);
264 end;
265
AsTagnull266 function AsTag(Value: Pointer): LongWord; inline;
267 begin
268 AsTag := LongWord(Value);
269 end;
270
AsTagnull271 function AsTag(Value: PChar): PtrUInt; inline;
272 begin
273 AsTag := PtrUInt(Value);
274 end;
275
AsTagnull276 function AsTag(Value: Boolean): PtrUInt; inline;
277 begin
278 if Value then
279 AsTag := LTrue
280 else
281 AsTag := LFalse;
282 end;
283
AsTagnull284 function AsTag(Value: LongInt): PtrUInt; inline;
285 begin
286 AsTag := PtrUInt(Value);
287 end;
288
AsTagnull289 function AsTag(Value: LongWord): PtrUInt; inline;
290 begin
291 AsTag := PtrUInt(Value);
292 end;
293
294 { This procedure is used to pop Dispatcher arguments from the EmulHandle }
295 procedure DISPATCHERARG(var cl; var obj; var msg);
296 begin
297 with GetEmulHandle^ do
298 begin
299 PtrUInt(cl) := reg[regA0];
300 PtrUInt(obj) := reg[regA2];
301 PtrUInt(msg) := reg[regA1];
302 end;
303 end;
304 {
305 // assembler implementation, kept for reference
306 asm
307 lwz r6,32(r2) // REG_a0
308 stw r6,(r3) // cl
309 lwz r6,40(r2) // REG_a2
310 stw r6,(r4) // obj
311 lwz r6,36(r2) // REG_a1
312 stw r6,(r5) // msg
313 end;}
314
315 type
316 THookSubEntryFunc = function(a, b, c: Pointer): PtrUInt;
317
HookEntrynull318 function HookEntry: PtrUInt;
319 var
320 hook: PHook;
321 begin
322 hook := REG_A0;
323 HookEntry := THookSubEntryFunc(hook^.h_SubEntry)(hook, REG_A2, REG_A1);
324 end;
325
326 begin
327 UtilityBase := MOS_UtilityBase;
328 end.
329