Difference between revisions of "Trinity in Trouble"
(→List of issues: correction for GetAttr()) |
(→Hardening trinity: updated unit trinity v2015-08-22) |
||
Line 106: | Line 106: | ||
− | // | + | // --------------------------------------------------------------------------- |
− | // | + | // Edit Date $ Entry |
− | // | + | // --------------------------------------------------------------------------- |
− | // | + | // 2015-08-22 $ CoerceMethod() |
− | // | + | // $ GetAttr() |
− | // | + | // 2015-08-21 $ SetAndTest Longint version |
− | // | + | // 2015-08-11 $ SetAttrs() |
+ | // $ additional TAG_() functions for Amiga | ||
+ | // $ additional TAG_() functions for MorphOS | ||
+ | // $ array of const for Amiga's DoMethod() instead of LW's | ||
+ | // $ workaround "Conversion between ordinals and pointers | ||
+ | // is not portable" hint messages | ||
+ | // $ Useful MUI text macro's | ||
// 2015-08-06 $ initial release | // 2015-08-06 $ initial release | ||
+ | // --------------------------------------------------------------------------- | ||
Line 139: | Line 146: | ||
− | function SetAndTest(Var OldValue: pointer; NewValue: pointer): boolean; overload; inline; | + | function SetAndTest(Var OldValue: pointer; NewValue: pointer) : boolean; overload; inline; |
− | function SetAndTest(Var OldValue: LongWord; NewValue: LongWord): boolean; overload; inline; | + | function SetAndTest(Var OldValue: LongWord; NewValue: LongWord): boolean; overload; inline; |
+ | function SetAndTest(Var OldValue: LongInt; NewValue: LongInt) : boolean; overload; inline; | ||
Line 172: | Line 180: | ||
Function TAG_(TagItem: LongWord): LongInt; overload; inline; | Function TAG_(TagItem: LongWord): LongInt; overload; inline; | ||
//Function TAG_(TagItem: LongInt ): LongInt; overload; inline; | //Function TAG_(TagItem: LongInt ): LongInt; overload; inline; | ||
− | Function TAG_(TagItem: Pointer ): LongInt; overload; inline; | + | Function TAG_(TagItem: Pointer ): LongInt; overload; inline; |
− | function TAG_(TagItem: boolean ): LongInt; overload; inline; | + | function TAG_(TagItem: boolean ): LongInt; overload; inline; |
{$ENDIF} | {$ENDIF} | ||
{$IFDEF AMIGA} | {$IFDEF AMIGA} | ||
− | Function TAG_(TagItem: LongWord): LongInt; overload; inline; | + | Function TAG_(TagItem: LongWord): LongInt; overload; inline; |
//Function TAG_(TagItem: LongInt ): LongInt; overload; inline; | //Function TAG_(TagItem: LongInt ): LongInt; overload; inline; | ||
− | Function TAG_(TagItem: Pointer ): LongInt; overload; inline; | + | Function TAG_(TagItem: Pointer ): LongInt; overload; inline; |
− | function TAG_(TagItem: boolean ): LongInt; overload; inline; | + | function TAG_(TagItem: boolean ): LongInt; overload; inline; |
{$ENDIF} | {$ENDIF} | ||
{$IFDEF MORPHOS} | {$IFDEF MORPHOS} | ||
//Function TAG_(TagItem: LongWord): LongWord; overload; inline; | //Function TAG_(TagItem: LongWord): LongWord; overload; inline; | ||
− | Function TAG_(TagItem: LongInt ): LongWord; overload; inline; | + | Function TAG_(TagItem: LongInt ): LongWord; overload; inline; |
− | Function TAG_(TagItem: Pointer ): LongWord; overload; inline; | + | Function TAG_(TagItem: Pointer ): LongWord; overload; inline; |
− | function TAG_(TagItem: boolean ): LongWord; overload; inline; | + | function TAG_(TagItem: boolean ): LongWord; overload; inline; |
{$ENDIF} | {$ENDIF} | ||
Line 199: | Line 207: | ||
{$IFDEF MORPHOS} | {$IFDEF MORPHOS} | ||
− | function SetGadgetAttrs(Gadget: PGadget; Window: PWindow; Requester: PRequester; const Tags: array of long): ULONG; | + | function SetGadgetAttrs(Gadget: PGadget; Window: PWindow; Requester: PRequester; const Tags: array of long): ULONG; |
{$ENDIF} | {$ENDIF} | ||
Line 215: | Line 223: | ||
− | function DoMethod(obj : pointer; MethodID: ULONG): ULONG; overload; | + | function DoMethod(obj : pointer; MethodID: ULONG): ULONG; overload; |
{$IFDEF AMIGA} | {$IFDEF AMIGA} | ||
− | function DoMethod(obj : pointer; MethodID: ULONG; const msg : array of const): ULONG; overload; | + | function DoMethod(obj : pointer; MethodID: ULONG; const msg : array of const): ULONG; overload; |
{$ENDIF} | {$ENDIF} | ||
{$IFDEF MORPHOS} | {$IFDEF MORPHOS} | ||
− | function DoMethod(obj : pointer; MethodID: ULONG; const msg : array of ULONG): ULONG; overload; | + | function DoMethod(obj : pointer; MethodID: ULONG; const msg : array of ULONG): ULONG; overload; |
{$ENDIF} | {$ENDIF} | ||
Line 236: | Line 244: | ||
− | function DoSuperMethod(cl: pointer; obj : pointer; id: LongWord): LongWord; overload; | + | function DoSuperMethod(cl: pointer; obj : pointer; id: LongWord): LongWord; overload; |
{$IF DEFINED(AMIGA) or DEFINED(MORPHOS) or DEFINED(AROS)} | {$IF DEFINED(AMIGA) or DEFINED(MORPHOS) or DEFINED(AROS)} | ||
− | function DoSuperMethod(cl: pointer; obj : pointer; id: LongWord; const msg : array of LongWord): longword; overload; | + | function DoSuperMethod(cl: pointer; obj : pointer; id: LongWord; const msg : array of LongWord): longword; overload; |
{$ENDIF} | {$ENDIF} | ||
Line 272: | Line 280: | ||
{$IFDEF AMIGA} | {$IFDEF AMIGA} | ||
− | function SetAttrs(Obj: APTR; tagList: Array of Const): ULONG; | + | function SetAttrs(Obj: APTR; tagList: Array of Const): ULONG; |
{$ENDIF} | {$ENDIF} | ||
{$IFDEF MORPHOS} | {$IFDEF MORPHOS} | ||
− | function SetAttrs(Obj: APTR; tagList: Array of DWord): ULONG; | + | function SetAttrs(Obj: APTR; tagList: Array of DWord): ULONG; |
{$ENDIF} | {$ENDIF} | ||
Line 307: | Line 315: | ||
////////////////////////////////////////////////////////////////////////////// | ////////////////////////////////////////////////////////////////////////////// | ||
// | // | ||
− | // Topic: | + | // Topic: CoerceMethos() |
+ | // | ||
+ | ////////////////////////////////////////////////////////////////////////////// | ||
+ | |||
+ | |||
+ | |||
+ | {$IFDEF MORPHOS} | ||
+ | Type | ||
+ | PBoopsiObject = PObject_; | ||
+ | {$ENDIF} | ||
+ | |||
+ | {$IFDEF AMIGA} | ||
+ | function CoerceMethod(cl: PIClass; Obj: PObject_; MethodID: ULONG): ULONG; | ||
+ | function CoerceMethod(cl: PIClass; Obj: PObject_; MethodID: ULONG; const Msg: array of const): ULONG; overload; | ||
+ | {$ENDIF} | ||
+ | {$IFDEF AROS} | ||
+ | function CoerceMethod(cl: PIClass; Obj: PObject_; MethodID: IPTR): IPTR; | ||
+ | {$ENDIF} | ||
+ | {$IFDEF MORPHOS} | ||
+ | function CoerceMethodA(cl: PIClass; Obj: PObject_; Msg: Pointer): ULONG; | ||
+ | function CoerceMethod(cl: PIClass; Obj: PBoopsiobject; MethodID: ULONG): ULONG; | ||
+ | function CoerceMethod(cl: PIClass; Obj: PBoopsiObject; MethodID: ULONG; const Msg: array of ULONG): ULONG; | ||
+ | {$ENDIF} | ||
+ | |||
+ | |||
+ | |||
+ | ////////////////////////////////////////////////////////////////////////////// | ||
+ | // | ||
+ | // Topic: GetAttr() for Morphos, complying to autodocs. | ||
+ | // | ||
+ | ////////////////////////////////////////////////////////////////////////////// | ||
+ | |||
+ | |||
+ | |||
+ | {$IFDEF MORPHOS} | ||
+ | function GetAttr(attrID : CARDINAL location 'd0'; object1 : POINTER location 'a0'; storagePtr : PCARDINAL location 'a1') : CARDINAL; SysCall IntuitionBase 654; | ||
+ | {$ENDIF} | ||
+ | |||
+ | |||
+ | |||
+ | ////////////////////////////////////////////////////////////////////////////// | ||
+ | // | ||
+ | // Topic: | ||
// | // | ||
////////////////////////////////////////////////////////////////////////////// | ////////////////////////////////////////////////////////////////////////////// | ||
Line 336: | Line 386: | ||
− | function SetAndTest(Var OldValue: pointer; NewValue: pointer): boolean; | + | function SetAndTest(Var OldValue: pointer; NewValue: pointer): boolean; |
begin | begin | ||
OldValue := NewValue; | OldValue := NewValue; | ||
Line 342: | Line 392: | ||
end; | end; | ||
− | function SetAndTest(Var OldValue: LongWord; NewValue: LongWord): boolean; | + | function SetAndTest(Var OldValue: LongWord; NewValue: LongWord): boolean; |
+ | begin | ||
+ | OldValue := NewValue; | ||
+ | result := (NewValue <> 0) | ||
+ | end; | ||
+ | |||
+ | function SetAndTest(Var OldValue: LongInt; NewValue: LongInt): boolean; | ||
begin | begin | ||
OldValue := NewValue; | OldValue := NewValue; | ||
Line 370: | Line 426: | ||
{$IFDEF CPU86} | {$IFDEF CPU86} | ||
− | function _hookEntry(h: PHook; obj: PObject_; Msg: Pointer): LongWord; cdecl; | + | function _hookEntry(h: PHook; obj: PObject_; Msg: Pointer): LongWord; cdecl; |
var | var | ||
Func: THookFunction; | Func: THookFunction; | ||
Line 414: | Line 470: | ||
{$IFDEF AROS} | {$IFDEF AROS} | ||
− | Function TAG_(TagItem: LongWord): LongInt; inline; | + | Function TAG_(TagItem: LongWord): LongInt; inline; |
begin | begin | ||
Result := LongInt(TagItem); | Result := LongInt(TagItem); | ||
end; | end; | ||
− | Function TAG_(TagItem: LongInt): LongInt; inline; | + | Function TAG_(TagItem: LongInt): LongInt; inline; |
begin | begin | ||
Result := LongInt(TagItem); | Result := LongInt(TagItem); | ||
end; | end; | ||
− | Function TAG_(TagItem: Pointer): LongInt; inline; | + | Function TAG_(TagItem: Pointer): LongInt; inline; |
begin | begin | ||
{$PUSH}{$HINTS OFF} | {$PUSH}{$HINTS OFF} | ||
Line 431: | Line 487: | ||
end; | end; | ||
− | function TAG_(TagItem: boolean): LongInt; inline; | + | function TAG_(TagItem: boolean): LongInt; inline; |
begin | begin | ||
Result := Ord(TagItem); | Result := Ord(TagItem); | ||
Line 440: | Line 496: | ||
{$IFDEF AMIGA} | {$IFDEF AMIGA} | ||
− | Function TAG_(TagItem: LongWord): LongInt; inline; | + | Function TAG_(TagItem: LongWord): LongInt; inline; |
begin | begin | ||
Result := LongInt(TagItem); | Result := LongInt(TagItem); | ||
end; | end; | ||
− | Function TAG_(TagItem: LongInt): LongInt; inline; | + | Function TAG_(TagItem: LongInt): LongInt; inline; |
begin | begin | ||
Result := LongInt(TagItem); | Result := LongInt(TagItem); | ||
end; | end; | ||
− | Function TAG_(TagItem: Pointer): LongInt; inline; | + | Function TAG_(TagItem: Pointer): LongInt; inline; |
begin | begin | ||
{$PUSH}{$HINTS OFF} | {$PUSH}{$HINTS OFF} | ||
Line 457: | Line 513: | ||
end; | end; | ||
− | function TAG_(TagItem: boolean): LongInt; inline; | + | function TAG_(TagItem: boolean): LongInt; inline; |
begin | begin | ||
Result := Ord(TagItem); | Result := Ord(TagItem); | ||
Line 466: | Line 522: | ||
{$IFDEF MORPHOS} | {$IFDEF MORPHOS} | ||
− | Function TAG_(TagItem: LongInt): LongWord; inline; | + | Function TAG_(TagItem: LongInt): LongWord; inline; |
begin | begin | ||
Result := LongWord(TagItem); | Result := LongWord(TagItem); | ||
end; | end; | ||
− | Function TAG_(TagItem: LongWord): LongWord; inline; | + | Function TAG_(TagItem: LongWord): LongWord; inline; |
begin | begin | ||
Result := LongWord(TagItem); | Result := LongWord(TagItem); | ||
end; | end; | ||
− | Function TAG_(TagItem: Pointer): LongWord; inline; | + | Function TAG_(TagItem: Pointer): LongWord; inline; |
begin | begin | ||
{$PUSH}{$HINTS OFF} | {$PUSH}{$HINTS OFF} | ||
Line 483: | Line 539: | ||
end; | end; | ||
− | function TAG_(TagItem: boolean): LongWord; inline; | + | function TAG_(TagItem: boolean): LongWord; inline; |
begin | begin | ||
Result := Ord(TagItem); | Result := Ord(TagItem); | ||
Line 500: | Line 556: | ||
{$IFDEF MORPHOS} | {$IFDEF MORPHOS} | ||
− | function SetGadgetAttrs(Gadget: PGadget; Window: PWindow; Requester: PRequester; const Tags: array of long): ULONG; | + | function SetGadgetAttrs(Gadget: PGadget; Window: PWindow; Requester: PRequester; const Tags: array of long): ULONG; |
begin | begin | ||
result := SetGadgetAttrsA(Gadget, Window, Requester, @Tags[0]); | result := SetGadgetAttrsA(Gadget, Window, Requester, @Tags[0]); | ||
Line 516: | Line 572: | ||
− | function DoMethod(obj : pointer; MethodID: ULONG): ULONG; | + | function DoMethod(obj : pointer; MethodID: ULONG): ULONG; |
Var | Var | ||
Tags : Array[0..0] of ULONG; | Tags : Array[0..0] of ULONG; | ||
Line 540: | Line 596: | ||
end; | end; | ||
− | function DoMethod(obj : pointer; MethodID: ULONG; const msg : array of const): ULONG; overload; | + | function DoMethod(obj : pointer; MethodID: ULONG; const msg : array of const): ULONG; overload; |
Var | Var | ||
Tags : Array of LongWord; i,n: integer; | Tags : Array of LongWord; i,n: integer; | ||
Line 562: | Line 618: | ||
{$IFDEF MORPHOS} | {$IFDEF MORPHOS} | ||
− | function DoMethod(obj : pointer; MethodID: ULONG; const msg : array of ULONG): ULONG; overload; | + | function DoMethod(obj : pointer; MethodID: ULONG; const msg : array of ULONG): ULONG; overload; |
Var | Var | ||
Tags : Array of LongWord; i,n: integer; | Tags : Array of LongWord; i,n: integer; | ||
Line 595: | Line 651: | ||
− | function DoSuperMethod(cl: pointer; obj : pointer; id: LongWord): LongWord; overload; | + | function DoSuperMethod(cl: pointer; obj : pointer; id: LongWord): LongWord; overload; |
Var | Var | ||
Tags : Array[0..0] of LongWord; | Tags : Array[0..0] of LongWord; | ||
Line 607: | Line 663: | ||
{$IF DEFINED(AMIGA) or DEFINED(MORPHOS) or DEFINED(AROS)} | {$IF DEFINED(AMIGA) or DEFINED(MORPHOS) or DEFINED(AROS)} | ||
− | function DoSuperMethod(cl: pointer; obj : pointer; id: LongWord; const msg : array of LongWord): longword; overload; | + | function DoSuperMethod(cl: pointer; obj : pointer; id: LongWord; const msg : array of LongWord): longword; overload; |
Var | Var | ||
Tags : Array of LongWord; i,n: integer; | Tags : Array of LongWord; i,n: integer; | ||
Line 638: | Line 694: | ||
{$IFDEF AMIGA} | {$IFDEF AMIGA} | ||
− | function SetAttrs(Obj: APTR; tagList: Array of Const): ULONG; | + | function SetAttrs(Obj: APTR; tagList: Array of Const): ULONG; |
begin | begin | ||
Result := SetAttrsA(Obj, ReadInTags(tagList)); | Result := SetAttrsA(Obj, ReadInTags(tagList)); | ||
Line 645: | Line 701: | ||
{$IFDEF MORPHOS} | {$IFDEF MORPHOS} | ||
− | function SetAttrs(Obj: APTR; tagList: Array of DWord): ULONG; | + | function SetAttrs(Obj: APTR; tagList: Array of DWord): ULONG; |
begin | begin | ||
Result := SetAttrsA(Obj, @tagList); | Result := SetAttrsA(Obj, @tagList); | ||
Line 655: | Line 711: | ||
////////////////////////////////////////////////////////////////////////////// | ////////////////////////////////////////////////////////////////////////////// | ||
// | // | ||
− | // Topic: | + | // Topic: CoerceMethod() |
// | // | ||
////////////////////////////////////////////////////////////////////////////// | ////////////////////////////////////////////////////////////////////////////// | ||
+ | |||
+ | |||
+ | |||
+ | {$IFDEF MORPHOS} | ||
+ | {$WARNING MORPHOS implementation of CoerceMethodA() is untested} | ||
+ | function CoerceMethodA(cl: PIClass; Obj: PObject_; Msg: Pointer): ULONG; | ||
+ | begin | ||
+ | If ( (cl <> nil) and (Obj <> nil) ) | ||
+ | then result := CALLHOOKPKT(PHook(cl), obj, Msg) | ||
+ | else result := 0; | ||
+ | end; | ||
+ | {$ENDIF} | ||
+ | |||
+ | {$IFDEF AMIGA} | ||
+ | function CoerceMethod(cl: PIClass; Obj: PObject_; MethodID: ULONG): ULONG; | ||
+ | {$ENDIF} | ||
+ | {$IFDEF AROS} | ||
+ | function CoerceMethod(cl: PIClass; Obj: PObject_; MethodID: IPTR): IPTR; | ||
+ | {$ENDIF} | ||
+ | {$IFDEF MORPHOS} | ||
+ | function CoerceMethod(cl: PIClass; Obj: PBoopsiobject; MethodID: ULONG): ULONG; | ||
+ | {$ENDIF} | ||
+ | Var | ||
+ | Tags : Array[0..0] of ULONG; | ||
+ | begin | ||
+ | {$IFDEF AROS} | ||
+ | if ( not(obj <> nil) or not (cl <> nil) ) then exit(0); | ||
+ | {$ENDIF} | ||
+ | Tags[0] := MethodID; | ||
+ | Result := CoerceMethodA(cl, Obj, @(Tags[0])); | ||
+ | end; | ||
+ | |||
+ | {$IFDEF AMIGA} | ||
+ | function CoerceMethod(cl: PIClass; Obj: PObject_; MethodID: ULONG; const Msg: array of const): ULONG; overload; | ||
+ | Var | ||
+ | Tags : Array of LongWord; i,n: integer; | ||
+ | begin | ||
+ | SetLength(Tags, Length(Msg) + 1); | ||
+ | |||
+ | i := 0; | ||
+ | Tags[i] := MethodID; | ||
+ | |||
+ | for n := low(Msg) to high(Msg) do | ||
+ | begin | ||
+ | inc(i); | ||
+ | Tags[i] := Msg[n]; // See operator | ||
+ | end; | ||
+ | |||
+ | Result := CoerceMethodA(cl, Obj, @(Tags[0])); | ||
+ | |||
+ | SetLength(Tags, 0); | ||
+ | end; | ||
+ | {$ENDIF} | ||
+ | |||
+ | {$IFDEF MORPHOS} | ||
+ | function CoerceMethod(cl: PIClass; Obj: PBoopsiObject; MethodID: ULONG; const Msg: array of ULONG): ULONG; | ||
+ | Var | ||
+ | Tags : Array of LongWord; i,n: integer; | ||
+ | begin | ||
+ | SetLength(Tags, Length(Msg) + 1); | ||
+ | |||
+ | i := 0; | ||
+ | Tags[i] := MethodID; | ||
+ | |||
+ | for n := low(Msg) to high(Msg) do | ||
+ | begin | ||
+ | inc(i); | ||
+ | Tags[i] := Msg[n]; | ||
+ | end; | ||
+ | |||
+ | Result := CoerceMethodA(cl, Obj, @(Tags[0])); | ||
+ | |||
+ | SetLength(Tags, 0); | ||
+ | end; | ||
+ | {$ENDIF} | ||
+ | |||
+ | |||
////////////////////////////////////////////////////////////////////////////// | ////////////////////////////////////////////////////////////////////////////// |
Revision as of 15:47, 22 August 2015
Note
Based on Free Pascal branch "fixes 3.0"
Feel free to add delete or change status.
Our trinity consist of Amiga, AROS and MorphOS.
Unfortunately, there are (still) some incompatibilities and/or some lack of consistency here and there. The idea is to have a list here that mentions them all. Layout may change, i simply had to start somewhere.
NOTE: I thought there is no use to mention the Tag, Tags, Taglist, etc. inconsistency and additional incompatibilities that this causes. We are all aware of those and will hopefully get some unity in the future
List of issues
- function: DoMethod()
- Amiga version seems missing completely.
- Implemented versions for AROS and MorphOS don't follow autodocs 100% and are inconsistent.
- function: ASLRequestTags()
- AROS implementation seems missing.
- Amiga implements it in utility unit systemvartags (see also unit: systemvartags)
- MorphOS implements it in unit ASL
- structure: Hook
- AROS version, entries are not IPTR rather APTR.
- function: GetAttr()
- MorphOS uses a var for parameter Return-Value while Amiga + AROS uses a pointer. Autodocs states it to be a pointer.
- function: SetAttrs()
- Amiga + MorphOS implementations seems missing
- unit: Workbench
- MorphOS version seems missing
- unit: systemvartags
- This utility unit is Amiga specific and implements most if not all vartags versions of library-calls rendering it incompatible with AROS and MorphOS
- function: AllocMem() (high priority)
- MorphOS implemented it as ExecAllocMem
- Amiga + AROS version have this function declared as AllocMem(), which is ambiguous with Free Pascal's AllocMem function.
- function: Info()
- AutoDocs: BOOL = Info( BPTR, struct InfoData * )
- Amiga declaration: FUNCTION Info(lock : LONGINT location 'd1'; parameterBlock : pInfoData location 'd2') : LongBool; syscall _DOSBase 114;
- AROS declaration: function Info(Lock: BPTR; ParameterBlock: PInfoData): LongInt; syscall AOS_DOSBase 19;
- MorphOS declaration: function Info(lock : LongInt location 'd1'; parameterBlock: PInfoData location 'd2'): LongInt; SysCall MOS_DOSBase 114;
- function: VFPrintf()
- AutoDocs: LONG = VFPrintf(BPTR, STRPTR, LONG *)
- Amiga declaration: FUNCTION VFPrintf(fh : LONGINT location 'd1';const format : pCHAR location 'd2';const argarray : POINTER location 'd3') : LONGINT; syscall _DOSBase 354;
- AROS declaration: function VFPrintf(Fh: BPTR; const format: STRPTR; const ArgArray: PLongInt): LongInt; syscall AOS_DOSBase 59;
- MorphOS declaration: function VFPrintf(fh : LongInt location 'd1'; format: PChar location 'd2'; argarray: Pointer location 'd3'): LongInt; SysCall MOS_DOSBase 354;
- NOTE: the generic pointer declaration prevents using "VFPrintf(nil/0, 'text', vargs );" where vargs = array of long.
- Remark: AFAIK for AROS it is theoretically possible to pass 64-bit formatted values.
- function: AslRequest()
- autodocs: BOOL AslRequest( APTR,struct TagItem * );
- Amiga: FUNCTION AslRequest(requester : POINTER location 'a0'; tagList : pTagItem location 'a1') : LongInt; syscall AslBase 060;
- AROS: function AslRequest(Requester: Pointer; const Tags: array of const): LongBool;
- MorphOS: function AslRequest(requester: Pointer location 'a0'; tagList : pTagItem location 'a1'): LongBool; SysCall AslBase 060;
- function: SetGadgetAttrs()
- MorphOS version seems missing
- Constants: MUIX_R, MUIX_C, MUIX_L, MUIX_N, MUIX_B, MUIX_I, MUIX_U, MUIX_PT and MUIX_PH
- AMIGA + AROS: these MUI constants uses c-language escape code characters, which won't work for Free Pascal.
- MorphOS: declared them as they should.
- function: NextTagItem()
- autodocs: struct TagItem *NextTagItem(struct TagItem **);
- Amiga: function NextTagItem(Item : ppTagItem location 'a0') : pTagItem; syscall _UtilityBase 048;
- AROS: function NextTagItem(var Item: PTagItem): PTagItem; syscall AOS_UtilityBase 8;
- MorphOS: function NextTagItem(tagListPtr: pPTagItem location 'a0'): PTagItem; SysCall MOS_UtilityBase 048;
- function: WriteStr()
- On MorphOS this function seems declared as Amiga-function, which clashes with Free Pascal build-in function WriteStr. Strange as WriteStr seems only declared as dos/stdio.h macro.
- function: CoerceMethod()
- MorphOS version seems missing completely (including CoerceMethodA().
- Amiga version has CoerceMethodA() implemented but no CoerceMethod()
- Implemented versions for AROS and Amiga don't follow autodocs 100% and are inconsistent.
Some of your finest
- AslRequest()
{$IFDEF AMIGA}
if (AslRequest(fr, nil) <> 0) then
{$ENDIF}
{$IFDEF AROS}
if (AslRequestA(fr, nil)) then
{$ENDIF}
{$IFDEF MORPHOS}
if (AslRequest(fr, nil)) then
{$ENDIF}
begin
// Could we now please check what the requester returned ?
end;
Hardening trinity
In order to circumvent some of the inconsistencies and incompatibilities, i needed a solution without tempering with the RTL and/or support units.
So, i invented unit trinity which solves some of the encountered issues (the unit itself is a work in progress). Whether or not it is the right solution to solve things, i don't know. But, i also don't care as things simply needed to be compiled *period*.
Without further ado: Unit Trinity
unit trinity;
// ---------------------------------------------------------------------------
// Edit Date $ Entry
// ---------------------------------------------------------------------------
// 2015-08-22 $ CoerceMethod()
// $ GetAttr()
// 2015-08-21 $ SetAndTest Longint version
// 2015-08-11 $ SetAttrs()
// $ additional TAG_() functions for Amiga
// $ additional TAG_() functions for MorphOS
// $ array of const for Amiga's DoMethod() instead of LW's
// $ workaround "Conversion between ordinals and pointers
// is not portable" hint messages
// $ Useful MUI text macro's
// 2015-08-06 $ initial release
// ---------------------------------------------------------------------------
{$IFNDEF HASAMIGA}
{$FATAL This source is compatible with Amiga, AROS and MorphOS only !}
{$ENDIF}
{$MODE OBJFPC}{$H+}
interface
Uses
Exec, Intuition, Utility;
//////////////////////////////////////////////////////////////////////////////
//
// Topic: Some generic c-helpers, should not be in here at all but convienent
//
//////////////////////////////////////////////////////////////////////////////
function SetAndTest(Var OldValue: pointer; NewValue: pointer) : boolean; overload; inline;
function SetAndTest(Var OldValue: LongWord; NewValue: LongWord): boolean; overload; inline;
function SetAndTest(Var OldValue: LongInt; NewValue: LongInt) : boolean; overload; inline;
//////////////////////////////////////////////////////////////////////////////
//
// Topic: Hooks -> cross-platform support
//
//////////////////////////////////////////////////////////////////////////////
Type
// THookFunction = function(Hook: pHook; obj: PObject_; Msg: Pointer): LongWord;
THookFunction = function(Hook: pHook; obj: APTR; Msg: APTR): LongWord;
Procedure InitHook(Var Hook: THook; Func: THookFunction; Data: APTR);
//////////////////////////////////////////////////////////////////////////////
//
// Topic: Tags and TagValue's. Array of const = LongInt vs. Array of long
// Cosmetic only e.g. get rid of compiler warnings
//
//////////////////////////////////////////////////////////////////////////////
{$IFDEF AROS}
Function TAG_(TagItem: LongWord): LongInt; overload; inline;
//Function TAG_(TagItem: LongInt ): LongInt; overload; inline;
Function TAG_(TagItem: Pointer ): LongInt; overload; inline;
function TAG_(TagItem: boolean ): LongInt; overload; inline;
{$ENDIF}
{$IFDEF AMIGA}
Function TAG_(TagItem: LongWord): LongInt; overload; inline;
//Function TAG_(TagItem: LongInt ): LongInt; overload; inline;
Function TAG_(TagItem: Pointer ): LongInt; overload; inline;
function TAG_(TagItem: boolean ): LongInt; overload; inline;
{$ENDIF}
{$IFDEF MORPHOS}
//Function TAG_(TagItem: LongWord): LongWord; overload; inline;
Function TAG_(TagItem: LongInt ): LongWord; overload; inline;
Function TAG_(TagItem: Pointer ): LongWord; overload; inline;
function TAG_(TagItem: boolean ): LongWord; overload; inline;
{$ENDIF}
//////////////////////////////////////////////////////////////////////////////
//
// Topic: SetGadgetAttrs(), missing from MorphOS
//
//////////////////////////////////////////////////////////////////////////////
{$IFDEF MORPHOS}
function SetGadgetAttrs(Gadget: PGadget; Window: PWindow; Requester: PRequester; const Tags: array of long): ULONG;
{$ENDIF}
//////////////////////////////////////////////////////////////////////////////
//
// Topic: DoMethod()
// Amiga : Missing
// MorphOS : wrong parameter declaration
// ALL : missing none msg version
//
//////////////////////////////////////////////////////////////////////////////
function DoMethod(obj : pointer; MethodID: ULONG): ULONG; overload;
{$IFDEF AMIGA}
function DoMethod(obj : pointer; MethodID: ULONG; const msg : array of const): ULONG; overload;
{$ENDIF}
{$IFDEF MORPHOS}
function DoMethod(obj : pointer; MethodID: ULONG; const msg : array of ULONG): ULONG; overload;
{$ENDIF}
//////////////////////////////////////////////////////////////////////////////
//
// Topic: DoSuperMethod()
// Amiga : Missing
// MorphOS + AROS : wrong parameter declaration
// ALL : missing none msg version
//
//////////////////////////////////////////////////////////////////////////////
function DoSuperMethod(cl: pointer; obj : pointer; id: LongWord): LongWord; overload;
{$IF DEFINED(AMIGA) or DEFINED(MORPHOS) or DEFINED(AROS)}
function DoSuperMethod(cl: pointer; obj : pointer; id: LongWord; const msg : array of LongWord): longword; overload;
{$ENDIF}
//////////////////////////////////////////////////////////////////////////////
//
// Topic: Structure TWBArg, Missing from MorphOS because of lacking unit
// Workbench
//
//////////////////////////////////////////////////////////////////////////////
{$IFDEF MORPHOS}
Type
PWBArg = ^TWBArg;
TWBArg = Record
wa_lock: BPTR; //* a lock descriptor */
wa_Name: PChar; //* a string relative to that lock */
end;
{$ENDIF}
//////////////////////////////////////////////////////////////////////////////
//
// Topic: Function SetAttrs(), this varargs version missing from Amiga & MOS
//
//////////////////////////////////////////////////////////////////////////////
{$IFDEF AMIGA}
function SetAttrs(Obj: APTR; tagList: Array of Const): ULONG;
{$ENDIF}
{$IFDEF MORPHOS}
function SetAttrs(Obj: APTR; tagList: Array of DWord): ULONG;
{$ENDIF}
//////////////////////////////////////////////////////////////////////////////
//
// Topic: Useful MUI text macro's. Used other names to avoid conflicts.
//
//////////////////////////////////////////////////////////////////////////////
const
Esc_R = #27#114; // right justified
Esc_C = #27#099; // centered
Esc_L = #27#108; // left justified
Esc_N = #27#110; // normal
Esc_B = #27#098; // bold
Esc_I = #27#105; // italic
Esc_U = #27#117; // underlined
Esc_PT = #27#050; // text pen
Esc_PH = #27#056; // highlight text pen
// Specials
Esc_IMS = #27#073; // Standard MUI Image
Esc_IMC = #27#079; // Created MUI Image
//////////////////////////////////////////////////////////////////////////////
//
// Topic: CoerceMethos()
//
//////////////////////////////////////////////////////////////////////////////
{$IFDEF MORPHOS}
Type
PBoopsiObject = PObject_;
{$ENDIF}
{$IFDEF AMIGA}
function CoerceMethod(cl: PIClass; Obj: PObject_; MethodID: ULONG): ULONG;
function CoerceMethod(cl: PIClass; Obj: PObject_; MethodID: ULONG; const Msg: array of const): ULONG; overload;
{$ENDIF}
{$IFDEF AROS}
function CoerceMethod(cl: PIClass; Obj: PObject_; MethodID: IPTR): IPTR;
{$ENDIF}
{$IFDEF MORPHOS}
function CoerceMethodA(cl: PIClass; Obj: PObject_; Msg: Pointer): ULONG;
function CoerceMethod(cl: PIClass; Obj: PBoopsiobject; MethodID: ULONG): ULONG;
function CoerceMethod(cl: PIClass; Obj: PBoopsiObject; MethodID: ULONG; const Msg: array of ULONG): ULONG;
{$ENDIF}
//////////////////////////////////////////////////////////////////////////////
//
// Topic: GetAttr() for Morphos, complying to autodocs.
//
//////////////////////////////////////////////////////////////////////////////
{$IFDEF MORPHOS}
function GetAttr(attrID : CARDINAL location 'd0'; object1 : POINTER location 'a0'; storagePtr : PCARDINAL location 'a1') : CARDINAL; SysCall IntuitionBase 654;
{$ENDIF}
//////////////////////////////////////////////////////////////////////////////
//
// Topic:
//
//////////////////////////////////////////////////////////////////////////////
implementation
{$IFDEF AMIGA}
Uses
AmigaLib, tagsarray;
{$ENDIF}
{$IFDEF MORPHOS}
Uses
AmigaLib;
{$ENDIF}
//////////////////////////////////////////////////////////////////////////////
//
// Topic: Some generic c-helpers, should not be in here
//
//////////////////////////////////////////////////////////////////////////////
function SetAndTest(Var OldValue: pointer; NewValue: pointer): boolean;
begin
OldValue := NewValue;
result := (NewValue <> nil)
end;
function SetAndTest(Var OldValue: LongWord; NewValue: LongWord): boolean;
begin
OldValue := NewValue;
result := (NewValue <> 0)
end;
function SetAndTest(Var OldValue: LongInt; NewValue: LongInt): boolean;
begin
OldValue := NewValue;
result := (NewValue <> 0)
end;
//////////////////////////////////////////////////////////////////////////////
//
// Topic: Hooks
//
//////////////////////////////////////////////////////////////////////////////
{$IFDEF CPU68}
procedure InitHook(var Hook: THook; Func: THookFunction; Data: APTR);
begin
Hook.h_Entry := @HookEntry;
Hook.h_SubEntry := Func;
Hook.h_Data := Data;
end;
{$ENDIF}
{$IFDEF CPU86}
function _hookEntry(h: PHook; obj: PObject_; Msg: Pointer): LongWord; cdecl;
var
Func: THookFunction;
begin
{$PUSH}{$HINTS OFF}
Func := THookFunction(h^.h_SubEntry);
{$POP}
result := Func(h, obj, msg);
end;
procedure InitHook(var Hook: THook; Func: THookFunction; Data: APTR);
begin
{$PUSH}{$HINTS OFF}
Hook.h_Entry := IPTR(@_hookEntry);
Hook.h_SubEntry := IPTR(Func);
{$POP}
Hook.h_Data := Data;
end;
{$ENDIF}
{$IFDEF CPUPOWERPC}
procedure InitHook(var Hook: THook; Func: THookFunction; Data: APTR);
const
HOOKENTRY_TRAP: TEmulLibEntry = ( Trap: TRAP_LIB; Extension: 0; Func: @HookEntry );
begin
Hook.h_Entry := @HOOKENTRY_TRAP;
Hook.h_SubEntry := Func;
Hook.h_Data := Data;
end;
{$ENDIF}
//////////////////////////////////////////////////////////////////////////////
//
// Topic: Tags
//
//////////////////////////////////////////////////////////////////////////////
{$IFDEF AROS}
Function TAG_(TagItem: LongWord): LongInt; inline;
begin
Result := LongInt(TagItem);
end;
Function TAG_(TagItem: LongInt): LongInt; inline;
begin
Result := LongInt(TagItem);
end;
Function TAG_(TagItem: Pointer): LongInt; inline;
begin
{$PUSH}{$HINTS OFF}
Result := LongInt(TagItem);
{$POP}
end;
function TAG_(TagItem: boolean): LongInt; inline;
begin
Result := Ord(TagItem);
end;
{$ENDIF}
{$IFDEF AMIGA}
Function TAG_(TagItem: LongWord): LongInt; inline;
begin
Result := LongInt(TagItem);
end;
Function TAG_(TagItem: LongInt): LongInt; inline;
begin
Result := LongInt(TagItem);
end;
Function TAG_(TagItem: Pointer): LongInt; inline;
begin
{$PUSH}{$HINTS OFF}
Result := LongInt(TagItem);
{$POP}
end;
function TAG_(TagItem: boolean): LongInt; inline;
begin
Result := Ord(TagItem);
end;
{$ENDIF}
{$IFDEF MORPHOS}
Function TAG_(TagItem: LongInt): LongWord; inline;
begin
Result := LongWord(TagItem);
end;
Function TAG_(TagItem: LongWord): LongWord; inline;
begin
Result := LongWord(TagItem);
end;
Function TAG_(TagItem: Pointer): LongWord; inline;
begin
{$PUSH}{$HINTS OFF}
Result := LongWord(TagItem);
{$POP}
end;
function TAG_(TagItem: boolean): LongWord; inline;
begin
Result := Ord(TagItem);
end;
{$ENDIF}
//////////////////////////////////////////////////////////////////////////////
//
// Topic: SetGadgetAttrs(), missing from MorphOS
//
//////////////////////////////////////////////////////////////////////////////
{$IFDEF MORPHOS}
function SetGadgetAttrs(Gadget: PGadget; Window: PWindow; Requester: PRequester; const Tags: array of long): ULONG;
begin
result := SetGadgetAttrsA(Gadget, Window, Requester, @Tags[0]);
end;
{$ENDIF}
//////////////////////////////////////////////////////////////////////////////
//
// Topic: DoMethod()
//
//////////////////////////////////////////////////////////////////////////////
function DoMethod(obj : pointer; MethodID: ULONG): ULONG;
Var
Tags : Array[0..0] of ULONG;
begin
Tags[0] := MethodID;
Result := CALLHOOKPKT(PHook(OCLASS(obj)), obj, @(Tags[0]));
// or should it be: CALLHOOKPKT(PHook(OCLASS(Obj)), Obj, nil);
end;
{$IFDEF AMIGA}
operator := (Src: TVarRec) Dest: LongWord;
begin
Case Src.vtype of
{$PUSH}{$HINTS OFF}
vtinteger : Dest := PtrInt(Src.vinteger);
vtboolean : Dest := PtrInt(Src.vboolean);
vtpchar : Dest := PtrInt(Src.vpchar);
vtchar : Dest := PtrInt(Src.vchar);
vtstring : Dest := PtrInt(PChar(string(Src.vstring^)));
vtpointer : Dest := PtrInt(Src.vpointer);
{$POP}
end;
end;
function DoMethod(obj : pointer; MethodID: ULONG; const msg : array of const): ULONG; overload;
Var
Tags : Array of LongWord; i,n: integer;
begin
SetLength(Tags, Length(msg) + 1);
i := 0;
Tags[i] := MethodID;
for n := low(msg) to high(msg) do
begin
inc(i);
Tags[i] := msg[n]; // See operator
end;
Result := CALLHOOKPKT(PHook(OCLASS(Obj)), Obj, @(Tags[0]));
SetLength(Tags, 0);
end;
{$ENDIF}
{$IFDEF MORPHOS}
function DoMethod(obj : pointer; MethodID: ULONG; const msg : array of ULONG): ULONG; overload;
Var
Tags : Array of LongWord; i,n: integer;
begin
SetLength(Tags, Length(msg) + 1);
i := 0;
Tags[i] := MethodID;
for n := low(msg) to high(msg) do
begin
inc(i);
Tags[i] := msg[n];
end;
Result := CALLHOOKPKT(PHook(OCLASS(Obj)), Obj, @(Tags[0]));
SetLength(Tags, 0);
end;
{$ENDIF}
//////////////////////////////////////////////////////////////////////////////
//
// Topic: DoSuperMethod()
// Amiga : Missing
// MorphOS + AROS : wrong parameter declaration
// ALL : missing none msg version
//
//////////////////////////////////////////////////////////////////////////////
function DoSuperMethod(cl: pointer; obj : pointer; id: LongWord): LongWord; overload;
Var
Tags : Array[0..0] of LongWord;
begin
Tags[0] := id;
Result := DoSuperMethodA(cl, obj, @tags[0]);
// or should it be: DoSuperMethodA(cl, obj, nil);
end;
{$IF DEFINED(AMIGA) or DEFINED(MORPHOS) or DEFINED(AROS)}
function DoSuperMethod(cl: pointer; obj : pointer; id: LongWord; const msg : array of LongWord): longword; overload;
Var
Tags : Array of LongWord; i,n: integer;
begin
SetLength(Tags, Length(msg) + 1);
i := 0;
Tags[i] := id;
for n := low(msg) to high(msg) do
begin
inc(i);
Tags[i] := msg[n];
end;
Result := DoSuperMethodA(cl, obj, @tags[0]);
SetLength(Tags, 0);
end;
{$ENDIF}
//////////////////////////////////////////////////////////////////////////////
//
// Topic: SetAttrs()
//
//////////////////////////////////////////////////////////////////////////////
{$IFDEF AMIGA}
function SetAttrs(Obj: APTR; tagList: Array of Const): ULONG;
begin
Result := SetAttrsA(Obj, ReadInTags(tagList));
end;
{$ENDIF}
{$IFDEF MORPHOS}
function SetAttrs(Obj: APTR; tagList: Array of DWord): ULONG;
begin
Result := SetAttrsA(Obj, @tagList);
end;
{$ENDIF}
//////////////////////////////////////////////////////////////////////////////
//
// Topic: CoerceMethod()
//
//////////////////////////////////////////////////////////////////////////////
{$IFDEF MORPHOS}
{$WARNING MORPHOS implementation of CoerceMethodA() is untested}
function CoerceMethodA(cl: PIClass; Obj: PObject_; Msg: Pointer): ULONG;
begin
If ( (cl <> nil) and (Obj <> nil) )
then result := CALLHOOKPKT(PHook(cl), obj, Msg)
else result := 0;
end;
{$ENDIF}
{$IFDEF AMIGA}
function CoerceMethod(cl: PIClass; Obj: PObject_; MethodID: ULONG): ULONG;
{$ENDIF}
{$IFDEF AROS}
function CoerceMethod(cl: PIClass; Obj: PObject_; MethodID: IPTR): IPTR;
{$ENDIF}
{$IFDEF MORPHOS}
function CoerceMethod(cl: PIClass; Obj: PBoopsiobject; MethodID: ULONG): ULONG;
{$ENDIF}
Var
Tags : Array[0..0] of ULONG;
begin
{$IFDEF AROS}
if ( not(obj <> nil) or not (cl <> nil) ) then exit(0);
{$ENDIF}
Tags[0] := MethodID;
Result := CoerceMethodA(cl, Obj, @(Tags[0]));
end;
{$IFDEF AMIGA}
function CoerceMethod(cl: PIClass; Obj: PObject_; MethodID: ULONG; const Msg: array of const): ULONG; overload;
Var
Tags : Array of LongWord; i,n: integer;
begin
SetLength(Tags, Length(Msg) + 1);
i := 0;
Tags[i] := MethodID;
for n := low(Msg) to high(Msg) do
begin
inc(i);
Tags[i] := Msg[n]; // See operator
end;
Result := CoerceMethodA(cl, Obj, @(Tags[0]));
SetLength(Tags, 0);
end;
{$ENDIF}
{$IFDEF MORPHOS}
function CoerceMethod(cl: PIClass; Obj: PBoopsiObject; MethodID: ULONG; const Msg: array of ULONG): ULONG;
Var
Tags : Array of LongWord; i,n: integer;
begin
SetLength(Tags, Length(Msg) + 1);
i := 0;
Tags[i] := MethodID;
for n := low(Msg) to high(Msg) do
begin
inc(i);
Tags[i] := Msg[n];
end;
Result := CoerceMethodA(cl, Obj, @(Tags[0]));
SetLength(Tags, 0);
end;
{$ENDIF}
//////////////////////////////////////////////////////////////////////////////
//
// Topic:
//
//////////////////////////////////////////////////////////////////////////////
end.