paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-12-11 12:10:43 +01:00
Code Issues Packages Projects Releases Wiki Activity

AROS: removed readintags and readinlongs (just a bug function), Added missing functions in AmigaDos, GetAttr overloaded with var parameter

Browse Source 
git-svn-id: trunk@31164 -
This commit is contained in:
marcus 2015-06-28 07:20:56 +00:00
parent 4cbf484124
commit 56ae2ad6bc
8 changed files with 444 additions and 481 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

419
packages/arosunits/src/amigados.pas
View File

File diff suppressed because it is too large Load Diff

10
packages/arosunits/src/asl.pas
View File

@ -536,13 +536,19 @@ implementation
function AllocAslRequest(ReqType: LongWord; const Tags: array of const): Pointer;
var
TagList: TTagsList;
begin
AllocAslRequest := AllocAslRequestA(reqType , readintags(tags));
AddTags(TagList, Tags);
AllocAslRequest := AllocAslRequestA(reqType , GetTagPtr(TagList));
end;
function AslRequest(Requester: Pointer; const Tags: array of const): LongBool;
var
TagList: TTagsList;
begin
AslRequest := AslRequestA(Requester , readintags(tags));
AddTags(TagList, Tags);
AslRequest := AslRequestA(Requester , GetTagPtr(TagList));
end;
initialization

315
packages/arosunits/src/intuition.pas
View File

File diff suppressed because it is too large Load Diff

37
packages/arosunits/src/longarray.pas
View File

@ -36,20 +36,12 @@ uses
type
PArgList = ^TArgList;
TArgList = array of IPTR;
function readinlongs(const Args: array of const): Pointer;
procedure AddArguments(var ArgList: TArgList; const Args: array of const);
function GetArgPtr(var ArgList: TArgList): Pointer;
implementation
type
TMyArgs = array of IPTR;
PMyArgs = ^TMyArgs;
var
ArgArray : PMyArgs;
procedure AddArguments(var ArgList: TArgList; const Args: array of const);
var
i: Integer;
@ -80,32 +72,5 @@ begin
Result := @(ArgList[0]);
end;
function ReadInLongs(const Args: array of const): Pointer;
var
i: Integer;
begin
for i := 0 to High(Args) do begin
case args[i].vtype of
vtinteger: ArgArray^[i] := IPTR(Args[i].vinteger);
vtpchar: ArgArray^[i] := IPTR(Args[i].vpchar);
vtchar: ArgArray^[i] := IPTR(Args[i].vchar);
vtpointer: ArgArray^[i] := IPTR(Args[i].vpointer);
vtstring: ArgArray^[i] := IPTR(PChar(string(Args[i].vstring^)));
vtboolean: ArgArray^[i] := IPTR(byte(Args[i].vboolean));
end;
end;
readinlongs := @(argarray^[0]);
end;
initialization
New(argarray);
SetLength(argarray^, 200);
finalization
SetLength(argarray^, 0);
Dispose(argarray);
end.

25
packages/arosunits/src/mui.pas
View File

@ -3859,28 +3859,43 @@ end;
Functions and procedures with array of const go here
}
function MUI_AllocAslRequestTags(_type : longword; const tags : Array Of Const) : Pointer;
var
TagList: TTagsList;
begin
MUI_AllocAslRequestTags := MUI_AllocAslRequest(_type , readintags(tags));
AddTags(TagList, Tags);
MUI_AllocAslRequestTags := MUI_AllocAslRequest(_type, GetTagPtr(TagList));
end;
function MUI_AslRequestTags(req : Pointer; const tags : Array Of Const) : LongBool;
var
TagList: TTagsList;
begin
MUI_AslRequestTags := MUI_AslRequest(req , readintags(tags));
AddTags(TagList, Tags);
MUI_AslRequestTags := MUI_AslRequest(req, GetTagPtr(TagList));
end;
function MUI_MakeObject(_type : LongInt; const params : Array Of Const) : pLongWord;
var
Args: TArgList;
begin
MUI_MakeObject := MUI_MakeObjectA(_type , readinlongs(params));
AddArguments(Args, params);
MUI_MakeObject := MUI_MakeObjectA(_type, GetArgPtr(Args));
end;
function MUI_NewObject(a0arg : pCHAR; const tags : Array Of Const) : pLongWord;
var
TagList: TTagsList;
begin
MUI_NewObject := MUI_NewObjectA(a0arg , readintags(tags));
AddTags(TagList, Tags);
MUI_NewObject := MUI_NewObjectA(a0arg , GetTagPtr(TagList));
end;
function MUI_Request(app : Pointer; win : Pointer; flags : longword; title : pCHAR; gadgets : pCHAR; format : pCHAR; const params : Array Of Const) : LongInt;
var
Args: TArgList;
begin
MUI_Request := MUI_RequestA(app , win , flags , title , gadgets , format , readintags(params));
AddArguments(Args, params);
MUI_Request := MUI_RequestA(app , win , flags , title , gadgets , format , GetArgPtr(Args));
end;
const

43
packages/arosunits/src/tagsarray.pas
View File

@ -24,18 +24,12 @@ uses
type
TTagsList = array of ttagitem;
PMyTags = ^TTagsList;
function ReadInTags(const Args: array of const): PTagItem;
procedure AddTags(var Taglist: TTagsList; const Args: array of const);
function GetTagPtr(var TagList: TTagsList): PTagItem;
implementation
var
MyTags: PMyTags;
procedure AddTags(var Taglist: TTagsList; const Args: array of const);
var
i: IPTR;
@ -69,43 +63,6 @@ begin
GetTagPtr := @(TagList[0]);
end;
function ReadInTags(const Args: array of const): PTagItem;
var
i: IPTR;
ii: IPTR;
begin
ii := 0;
SetLength(MyTags^, (Length(Args) div 2) + 4); // some more at the end
for i := 0 to High(Args) do
begin
if not Odd(i) then
begin
mytags^[ii].ti_tag := IPTR(Args[i].vinteger);
end else
begin
case Args[i].vtype of
vtinteger: mytags^[ii].ti_data := IPTR(Args[i].vinteger);
vtboolean: mytags^[ii].ti_data := IPTR(Byte(Args[i].vboolean));
vtpchar: mytags^[ii].ti_data := IPTR(Args[i].vpchar);
vtchar: mytags^[ii].ti_data := IPTR(Args[i].vchar);
vtstring: mytags^[ii].ti_data := IPTR(PChar(string(Args[i].vstring^)));
vtpointer: mytags^[ii].ti_data := IPTR(Args[i].vpointer);
end;
Inc(ii);
end;
end;
Inc(ii);
// Add additional TAG_DONE (if user forget)
mytags^[ii].ti_tag := TAG_DONE;
mytags^[ii].ti_data := 0;
// return the pointer
ReadInTags := @(MyTags^[0]);
end;
initialization
New(MyTags);
SetLength(MyTags^, 200);
finalization
SetLength(MyTags^, 0);
Dispose(MyTags);
end.

37
packages/arosunits/src/utility.pas
View File

@ -33,18 +33,18 @@ type
Year: Word;
WDay: Word;
end;
// Use CALLHOOKPKT to call a hook
PHook = ^THook;
THookFunctionProc = function(Hook: PHook; Object_: APTR; Message: APTR): IPTR; cdecl;
THook = record
h_MinNode: TMinNode;
h_Entry: IPTR; // Main Entry point THookFunctionProc
h_SubEntry: IPTR; // Secondary entry point
h_Data: Pointer; // owner specific
end;
// The named object structure
PNamedObject = ^TNamedObject;
TNamedObject = record
@ -66,16 +66,16 @@ const
// Control attributes for Pack/UnpackStructureTags()
{ PackTable definition:
The PackTable is a simple array of LONGWORDS that are evaluated by
PackStructureTags() and UnpackStructureTags().
The table contains compressed information such as the tag offset from
the base tag. The tag offset has a limited range so the base tag is
defined in the first longword.
After the first longword, the fields look as follows:
+--------- 1 = signed, 0 = unsigned (for bits, 1=inverted boolean)
|
| +------ 00 = Pack/Unpack, 10 = Pack, 01 = Unpack, 11 = special
@ -91,11 +91,11 @@ const
Bit offset (for bit operations) ----/ | |
\ |
Offset into data structure -----------------------------------/
A -1 longword signifies that the next longword will be a new base tag
A 0 longword signifies that it is the end of the pack table.
What this implies is that there are only 13-bits of address offset
and 10 bits for tag offsets from the base tag. For most uses this
should be enough, but when this is not, either multiple pack tables
@ -108,7 +108,7 @@ const
PSTB_PACK = 29; // Note that these are active low...
PSTF_PACK = 1 shl 29;
PSTB_UNPACK = 30; // Note that these are active low...
PSTF_UNPACK = 1 shl 30;
PSTF_UNPACK = 1 shl 30;
PSTB_SIGNED = 31;
PSTF_SIGNED = 1 shl 31;
@ -199,7 +199,7 @@ const
MAP_REMOVE_NOT_FOUND = 0; // remove tags that aren't in mapList
MAP_KEEP_NOT_FOUND = 1; // keep tags that aren't in mapList
UTILITYNAME = 'utility.library';
UTILITYNAME = 'utility.library';
type
PUtilityBase = ^TUtilityBase;
@ -250,7 +250,6 @@ function UnpackStructureTags(Pack: APTR; PackTable: PLongWord; TagList: PTagItem
// Macros
function CALLHOOKPKT_(Hook: PHook; Object_: APTR; Message: APTR): IPTR; inline;
function TAGLIST(var Args: array of const): PTagItem; // NOT threadsafe! Better use AddTags/GetTagPtr
// VarArgs Versions
function AllocNamedObject(const Name: STRPTR; const Tags: array of const): PNamedObject;
@ -268,20 +267,18 @@ begin
AddTags(TagList, Tags);
Result := AllocNamedObjectA(Name, GetTagPtr(TagList));
end;
function TAGLIST(var Args: array of const): PTagItem;
begin
Result := ReadInTags(Args);
end;
function CallHook(Hook: PHook; Object_: APTR; const Params: array of const): IPTR;
var
Args: TArgList;
begin
CallHook := CallHookPkt(Hook, Object_ , ReadInLongs(Params));
AddArguments(Args, params);
CallHook := CallHookPkt(Hook, Object_ , GetArgPtr(Args));
end;
function CALLHOOKPKT_(Hook: PHook; Object_: APTR; Message: APTR): IPTR;
var
FuncPtr: THookFunctionProc;
FuncPtr: THookFunctionProc;
begin
Result := 0;
if (Hook = nil) or (Object_ = nil) or (Message = nil) then

39
packages/arosunits/src/workbench.pas
View File

@ -605,50 +605,73 @@ uses
// varargs versions:
function AddAppIcon(ID: LongWord; UserData: LongWord; Text_: PChar; MsgPort: PMsgPort; Lock: BPTR; DiskObj: PDiskObject; const Tags: array of const): PAppIcon;
var
TagList: TTagsList;
begin
AddAppIcon := AddAppIconA(ID, UserData, Text_, MsgPort, Lock, DiskObj, ReadInTags(Tags));
AddTags(TagList, Tags);
AddAppIcon := AddAppIconA(ID, UserData, Text_, MsgPort, Lock, DiskObj, GetTagPtr(TagList));
end;
function AddAppMenuItem(ID: LongWord; UserData: LongWord; Text_: APTR; MsgPort: PMsgPort; const Tags: array of const): PAppMenuItem;
var
TagList: TTagsList;
begin
AddAppMenuItem := AddAppMenuItemA(ID, UserData, Text_, MsgPort, ReadInTags(Tags));
AddAppMenuItem := AddAppMenuItemA(ID, UserData, Text_, MsgPort, GetTagPtr(TagList));
end;
function AddAppWindow(ID: LongWord; UserData: LongWord; Window: PWindow; MsgPort: PMsgPort; const Tags: array of const): PAppWindow;
var
TagList: TTagsList;
begin
AddAppWindow := AddAppWindowA(ID, UserData, Window, MsgPort, ReadInTags(Tags));
AddTags(TagList, Tags);
AddAppWindow := AddAppWindowA(ID, UserData, Window, MsgPort, GetTagPtr(TagList));
end;
function AddAppWindowDropZone(Aw: PAppWindow; ID: LongWord; UserData: LongWord; const Tags: array of const): PAppWindowDropZone;
var
TagList: TTagsList;
begin
AddAppWindowDropZone := AddAppWindowDropZoneA(Aw, ID, UserData, ReadInTags(Tags));
AddTags(TagList, Tags);
AddAppWindowDropZone := AddAppWindowDropZoneA(Aw, ID, UserData, GetTagPtr(TagList));
end;
function CloseWorkbenchObject(Name: STRPTR; const Tags: array of const): LongBool;
var
TagList: TTagsList;
begin
CloseWorkbenchObject := CloseWorkbenchObjectA(Name, ReadInTags(Tags));
AddTags(TagList, Tags);
CloseWorkbenchObject := CloseWorkbenchObjectA(Name, GetTagPtr(TagList));
end;
function MakeWorkbenchObjectVisible(Name: STRPTR; const Tags: array of const): LongBool;
var
TagList: TTagsList;
begin
MakeWorkbenchObjectVisible := MakeWorkbenchObjectVisibleA(Name, ReadInTags(Tags));
AddTags(TagList, Tags);
MakeWorkbenchObjectVisible := MakeWorkbenchObjectVisibleA(Name, GetTagPtr(TagList));
end;
function OpenWorkbenchObject(Name: STRPTR; const Tags: array of const): LongBool;
var
TagList: TTagsList;
begin
OpenWorkbenchObject := OpenWorkbenchObjectA(Name, ReadInTags(Tags));
AddTags(TagList, Tags);
OpenWorkbenchObject := OpenWorkbenchObjectA(Name, GetTagPtr(TagList));
end;
function WorkbenchControl(Name: STRPTR; const Tags: array of const): LongBool;
var
TagList: TTagsList;
begin
WorkbenchControl := WorkbenchControlA(Name, ReadInTags(Tags));
AddTags(TagList, Tags);
WorkbenchControl := WorkbenchControlA(Name, GetTagPtr(TagList));
end;