paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-13 05:29:34 +02:00
Code Issues Packages Projects Releases Wiki Activity

Amiga: Workbench 1.x compatibilty via the AMIGA_V1_2_ONLY define

Browse Source
This commit is contained in:
Marcus Sackrow 2021-08-06 19:48:27 +01:00
parent 136f042972
commit c1f6a7afdd
14 changed files with 1046 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
packages/ami-extra/src/muihelper.pas
View File

@ -439,12 +439,16 @@ end;
procedure MH_Set(Obj: PObject_; Tag, Data: PtrUInt);
begin
{$if not defined(AMIGA_V1_2_ONLY)}
SetAttrs(Obj, [Tag, Data, TAG_END]);
{$endif}
end;
function MH_Get(Obj: PObject_; Tag: PtrUInt): PtrUInt;
begin
{$if not defined(AMIGA_V1_2_ONLY)}
GetAttr(Tag, Obj, MH_Get);
{$endif}
end;
procedure MH_SetMutex(Obj: PObject_; n: Integer);
@ -1635,13 +1639,21 @@ end;
// ************************************************************************
function MH_NewObject(ClassPtr: PIClass; ClassID: PChar; const Tags: array of PtrUInt): APTR;
begin
{$if defined(AMIGA_V1_2_ONLY)}
MH_NewObject := nil;
{$else}
MH_NewObject := NewObject(ClassPtr, ClassID, Tags);
{$endif}
end;
function MH_NewObject(var Obj; ClassPtr: PIClass; ClassID: PChar; const Tags: array of PtrUInt): APTR;
begin
{$if defined(AMIGA_V1_2_ONLY)}
MH_NewObject := nil;
{$else}
PObject_(Obj) := NewObject(ClassPtr, ClassID, Tags);
MH_NewObject := PObject_(Obj);
{$endif}
end;
// deprecated but widely used macros

234
packages/amunits/src/coreunits/agraphics.pas
View File

@ -2250,6 +2250,120 @@ const
var
GfxBase : PGfxBase = nil;
{$if defined(AMIGA_V1_2_ONLY)}
FUNCTION AllocRaster(width : ULONG location 'd0'; height : ULONG location 'd1') : TPlanePtr; syscall GfxBase 492;
PROCEDURE FreeRaster(p : TPlanePtr location 'a0'; width : ULONG location 'd0'; height : ULONG location 'd1'); syscall GfxBase 498;
PROCEDURE InitBitMap(bitMap : pBitMap location 'a0'; depth : LONGINT location 'd0'; width : LONGINT location 'd1'; height : LONGINT location 'd2'); syscall GfxBase 390;
PROCEDURE InitRastPort(rp : pRastPort location 'a1'); syscall GfxBase 198;
PROCEDURE SetAPen(rp : pRastPort location 'a1'; pen : ULONG location 'd0'); syscall GfxBase 342;
PROCEDURE SetBPen(rp : pRastPort location 'a1'; pen : ULONG location 'd0'); syscall GfxBase 348;
PROCEDURE SetDrMd(rp : pRastPort location 'a1'; drawMode : ULONG location 'd0'); syscall GfxBase 354;
PROCEDURE SetRast(rp : pRastPort location 'a1'; pen : ULONG location 'd0'); syscall GfxBase 234;
PROCEDURE ClearEOL(rp : pRastPort location 'a1'); syscall GfxBase 042;
PROCEDURE ClearScreen(rp : pRastPort location 'a1'); syscall GfxBase 048;
PROCEDURE Draw(rp : pRastPort location 'a1'; x : LONGINT location 'd0'; y : LONGINT location 'd1'); syscall GfxBase 246;
PROCEDURE DrawEllipse(rp : pRastPort location 'a1'; xCenter : LONGINT location 'd0'; yCenter : LONGINT location 'd1'; a : LONGINT location 'd2'; b : LONGINT location 'd3'); syscall GfxBase 180;
PROCEDURE gfxMove(rp : pRastPort location 'a1'; x : LONGINT location 'd0'; y : LONGINT location 'd1'); syscall GfxBase 240;
PROCEDURE PolyDraw(rp : pRastPort location 'a1'; count : LONGINT location 'd0';const polyTable : PSmallInt location 'a0'); syscall GfxBase 336;
FUNCTION ReadPixel(rp : pRastPort location 'a1'; x : LONGINT location 'd0'; y : LONGINT location 'd1') : ULONG; syscall GfxBase 318;
PROCEDURE ScrollRaster(rp : pRastPort location 'a1'; dx : LONGINT location 'd0'; dy : LONGINT location 'd1'; xMin : LONGINT location 'd2'; yMin : LONGINT location 'd3'; xMax : LONGINT location 'd4'; yMax : LONGINT location 'd5'); syscall GfxBase 396;
FUNCTION GfxText(rp : pRastPort location 'a1';const string_ : pCHAR location 'a0'; count : ULONG location 'd0') : LONGINT; syscall GfxBase 060;
FUNCTION TextLength(rp : pRastPort location 'a1';const string_ : pCHAR location 'a0'; count : ULONG location 'd0') : smallint; syscall GfxBase 054;
FUNCTION WritePixel(rp : pRastPort location 'a1'; x : LONGINT location 'd0'; y : LONGINT location 'd1') : LONGINT; syscall GfxBase 324;
FUNCTION AreaDraw(rp : pRastPort location 'a1'; x : LONGINT location 'd0'; y : LONGINT location 'd1') : LONGINT; syscall GfxBase 258;
FUNCTION AreaEllipse(rp : pRastPort location 'a1'; xCenter : LONGINT location 'd0'; yCenter : LONGINT location 'd1'; a : LONGINT location 'd2'; b : LONGINT location 'd3') : LONGINT; syscall GfxBase 186;
FUNCTION AreaEnd(rp : pRastPort location 'a1') : LONGINT; syscall GfxBase 264;
FUNCTION AreaMove(rp : pRastPort location 'a1'; x : LONGINT location 'd0'; y : LONGINT location 'd1') : LONGINT; syscall GfxBase 252;
FUNCTION Flood(rp : pRastPort location 'a1'; mode : ULONG location 'd2'; x : LONGINT location 'd0'; y : LONGINT location 'd1') : LongBool; syscall GfxBase 330;
PROCEDURE InitArea(areaInfo : pAreaInfo location 'a0'; vectorBuffer : POINTER location 'a1'; maxVectors : LONGINT location 'd0'); syscall GfxBase 282;
FUNCTION InitTmpRas(tmpRas : pTmpRas location 'a0'; buffer : Pointer location 'a1'; size : LONGINT location 'd0') : pTmpRas; syscall GfxBase 468;
PROCEDURE RectFill(rp : pRastPort location 'a1'; xMin : LONGINT location 'd0'; yMin : LONGINT location 'd1'; xMax : LONGINT location 'd2'; yMax : LONGINT location 'd3'); syscall GfxBase 306;
PROCEDURE FreeColorMap(colorMap : pColorMap location 'a0'); syscall GfxBase 576;
FUNCTION GetColorMap(entries : LONGINT location 'd0') : pColorMap; syscall GfxBase 570;
FUNCTION GetRGB4(colorMap : pColorMap location 'a0'; entry : LONGINT location 'd0') : ULONG; syscall GfxBase 582;
PROCEDURE LoadRGB4(vp : pViewPort location 'a0';const colors : pWord location 'a1'; count : LONGINT location 'd0'); syscall GfxBase 192;
PROCEDURE SetRGB4(vp : pViewPort location 'a0'; index : LONGINT location 'd0'; red : ULONG location 'd1'; green : ULONG location 'd2'; blue : ULONG location 'd3'); syscall GfxBase 288;
PROCEDURE SetRGB4CM(colorMap : pColorMap location 'a0'; index : LONGINT location 'd0'; red : ULONG location 'd1'; green : ULONG location 'd2'; blue : ULONG location 'd3'); syscall GfxBase 630;
FUNCTION BltBitMap(const srcBitMap : pBitMap location 'a0'; xSrc : LONGINT location 'd0'; ySrc : LONGINT location 'd1'; destBitMap : pBitMap location 'a1'; xDest : LONGINT location 'd2'; yDest : LONGINT location 'd3'; xSize : LONGINT location 'd4'; ySize : LONGINT location 'd5'; minterm : ULONG location 'd6'; mask : ULONG location 'd7'; tempA : pCHAR location 'a2') : LONGINT; syscall GfxBase 030;
PROCEDURE BltBitMapRastPort(const srcBitMap : pBitMap location 'a0'; xSrc : LONGINT location 'd0'; ySrc : LONGINT location 'd1'; destRP : pRastPort location 'a1'; xDest : LONGINT location 'd2'; yDest : LONGINT location 'd3'; xSize : LONGINT location 'd4'; ySize : LONGINT location 'd5'; minterm : ULONG location 'd6'); syscall GfxBase 606;
PROCEDURE BltClear(memBlock : pointer location 'a1'; byteCount : ULONG location 'd0'; flags : ULONG location 'd1'); syscall GfxBase 300;
PROCEDURE BltMaskBitMapRastPort(const srcBitMap : pBitMap location 'a0'; xSrc : LONGINT location 'd0'; ySrc : LONGINT location 'd1'; destRP : pRastPort location 'a1'; xDest : LONGINT location 'd2'; yDest : LONGINT location 'd3'; xSize : LONGINT location 'd4'; ySize : LONGINT location 'd5'; minterm : ULONG location 'd6';const bltMask : pCHAR location 'a2'); syscall GfxBase 636;
PROCEDURE BltPattern(rp : pRastPort location 'a1';const mask : pCHAR location 'a0'; xMin : LONGINT location 'd0'; yMin : LONGINT location 'd1'; xMax : LONGINT location 'd2'; yMax : LONGINT location 'd3'; maskBPR : ULONG location 'd4'); syscall GfxBase 312;
PROCEDURE BltTemplate(const source : pWORD location 'a0'; xSrc : LONGINT location 'd0'; srcMod : LONGINT location 'd1'; destRP : pRastPort location 'a1'; xDest : LONGINT location 'd2'; yDest : LONGINT location 'd3'; xSize : LONGINT location 'd4'; ySize : LONGINT location 'd5'); syscall GfxBase 036;
PROCEDURE ClipBlit(srcRP : pRastPort location 'a0'; xSrc : LONGINT location 'd0'; ySrc : LONGINT location 'd1'; destRP : pRastPort location 'a1'; xDest : LONGINT location 'd2'; yDest : LONGINT location 'd3'; xSize : LONGINT location 'd4'; ySize : LONGINT location 'd5'; minterm : ULONG location 'd6'); syscall GfxBase 552;
PROCEDURE DisownBlitter; syscall GfxBase 462;
PROCEDURE OwnBlitter; syscall GfxBase 456;
PROCEDURE QBlit(blit : pbltnode location 'a1'); syscall GfxBase 276;
PROCEDURE QBSBlit(blit : pbltnode location 'a1'); syscall GfxBase 294;
PROCEDURE WaitBlit; syscall GfxBase 228;
PROCEDURE CBump(copList : pUCopList location 'a1'); syscall GfxBase 366;
PROCEDURE CMove(copList : pUCopList location 'a1'; destination : POINTER location 'a0'; data : LONGINT location 'd1'); syscall GfxBase 372;
PROCEDURE CWait(copList : pUCopList location 'a1'; v : LONGINT location 'd0'; h : LONGINT location 'd1'); syscall GfxBase 378;
PROCEDURE FreeCopList(copList : pCopList location 'a0'); syscall GfxBase 546;
PROCEDURE FreeCprList(cprList : pcprlist location 'a0'); syscall GfxBase 564;
PROCEDURE FreeVPortCopLists(vp : pViewPort location 'a0'); syscall GfxBase 540;
PROCEDURE InitView(view : pView location 'a1'); syscall GfxBase 360;
PROCEDURE InitVPort(vp : pViewPort location 'a0'); syscall GfxBase 204;
PROCEDURE LoadView(view : pView location 'a1'); syscall GfxBase 222;
FUNCTION MakeVPort(view : pView location 'a0'; vp : pViewPort location 'a1') : ULONG; syscall GfxBase 216;
FUNCTION MrgCop(view : pView location 'a1') : ULONG; syscall GfxBase 210;
PROCEDURE ScrollVPort(vp : pViewPort location 'a0'); syscall GfxBase 588;
FUNCTION UCopperListInit(uCopList : pUCopList location 'a0'; n : LONGINT location 'd0') : pCopList; syscall GfxBase 594;
FUNCTION VBeamPos : LONGINT; syscall GfxBase 384;
PROCEDURE WaitBOVP(vp : pViewPort location 'a0'); syscall GfxBase 402;
PROCEDURE WaitTOF; syscall GfxBase 270;
PROCEDURE AndRectRegion(region : pRegion location 'a0';const rectangle : pRectangle location 'a1'); syscall GfxBase 504;
FUNCTION AndRegionRegion(const srcRegion : pRegion location 'a0'; destRegion : pRegion location 'a1') : LongBool; syscall GfxBase 624;
FUNCTION AttemptLockLayerRom(layer : pLayer location 'a5') : LongBool; syscall GfxBase 654;
FUNCTION ClearRectRegion(region : pRegion location 'a0';const rectangle : pRectangle location 'a1') : LongBool; syscall GfxBase 522;
PROCEDURE ClearRegion(region : pRegion location 'a0'); syscall GfxBase 528;
PROCEDURE CopySBitMap(layer : pLayer location 'a0'); syscall GfxBase 450;
PROCEDURE DisposeRegion(region : pRegion location 'a0'); syscall GfxBase 534;
PROCEDURE LockLayerRom(layer : pLayer location 'a5'); syscall GfxBase 432;
FUNCTION NewRegion : pRegion; syscall GfxBase 516;
FUNCTION OrRectRegion(region : pRegion location 'a0';const rectangle : pRectangle location 'a1') : LongBool; syscall GfxBase 510;
FUNCTION OrRegionRegion(const srcRegion : pRegion location 'a0'; destRegion : pRegion location 'a1') : LongBool; syscall GfxBase 612;
PROCEDURE SyncSBitMap(layer : pLayer location 'a0'); syscall GfxBase 444;
PROCEDURE UnlockLayerRom(layer : pLayer location 'a5'); syscall GfxBase 438;
FUNCTION XorRectRegion(region : pRegion location 'a0';const rectangle : pRectangle location 'a1') : LongBool; syscall GfxBase 558;
FUNCTION XorRegionRegion(const srcRegion : pRegion location 'a0'; destRegion : pRegion location 'a1') : LongBool; syscall GfxBase 618;
PROCEDURE AddFont(textFont : pTextFont location 'a1'); syscall GfxBase 480;
PROCEDURE AskFont(rp : pRastPort location 'a1'; textAttr : pTextAttr location 'a0'); syscall GfxBase 474;
FUNCTION AskSoftStyle(rp : pRastPort location 'a1') : ULONG; syscall GfxBase 084;
PROCEDURE CloseFont(textFont : pTextFont location 'a1'); syscall GfxBase 078;
FUNCTION OpenFont(textAttr : pTextAttr location 'a0') : pTextFont; syscall GfxBase 072;
PROCEDURE RemFont(textFont : pTextFont location 'a1'); syscall GfxBase 486;
FUNCTION SetFont(rp : pRastPort location 'a1';const textFont : pTextFont location 'a0') : LONGINT; syscall GfxBase 066;
FUNCTION SetSoftStyle(rp : pRastPort location 'a1'; style : ULONG location 'd0'; enable : ULONG location 'd1') : ULONG; syscall GfxBase 090;
PROCEDURE AddAnimOb(anOb : pAnimOb location 'a0'; anKey : ppAnimOb location 'a1'; rp : pRastPort location 'a2'); syscall GfxBase 156;
PROCEDURE AddBob(bob : pBob location 'a0'; rp : pRastPort location 'a1'); syscall GfxBase 096;
PROCEDURE AddVSprite(vSprite : pVSprite location 'a0'; rp : pRastPort location 'a1'); syscall GfxBase 102;
PROCEDURE Animate(anKey : ppAnimOb location 'a0'; rp : pRastPort location 'a1'); syscall GfxBase 162;
PROCEDURE ChangeSprite(vp : pViewPort location 'a0'; sprite : pSimpleSprite location 'a1'; newData : pWORD location 'a2'); syscall GfxBase 420;
PROCEDURE DoCollision(rp : pRastPort location 'a1'); syscall GfxBase 108;
PROCEDURE DrawGList(rp : pRastPort location 'a1'; vp : pViewPort location 'a0'); syscall GfxBase 114;
PROCEDURE FreeGBuffers(anOb : pAnimOb location 'a0'; rp : pRastPort location 'a1'; flag : LONGINT location 'd0'); syscall GfxBase 600;
PROCEDURE FreeSprite(num : LONGINT location 'd0'); syscall GfxBase 414;
FUNCTION GetGBuffers(anOb : pAnimOb location 'a0'; rp : pRastPort location 'a1'; flag : LONGINT location 'd0') : LongBool; syscall GfxBase 168;
FUNCTION GetSprite(sprite : pSimpleSprite location 'a0'; num : LONGINT location 'd0') : smallint; syscall GfxBase 408;
PROCEDURE InitGels(head : pVSprite location 'a0'; tail : pVSprite location 'a1'; gelsInfo : pGelsInfo location 'a2'); syscall GfxBase 120;
PROCEDURE InitGMasks(anOb : pAnimOb location 'a0'); syscall GfxBase 174;
PROCEDURE InitMasks(vSprite : pVSprite location 'a0'); syscall GfxBase 126;
PROCEDURE MoveSprite(vp : pViewPort location 'a0'; sprite : pSimpleSprite location 'a1'; x : LONGINT location 'd0'; y : LONGINT location 'd1'); syscall GfxBase 426;
PROCEDURE RemIBob(bob : pBob location 'a0'; rp : pRastPort location 'a1'; vp : pViewPort location 'a2'); syscall GfxBase 132;
PROCEDURE RemVSprite(vSprite : pVSprite location 'a0'); syscall GfxBase 138;
PROCEDURE SetCollision(num : ULONG location 'd0'; routine : tPROCEDURE location 'a0'; gelsInfo : pGelsInfo location 'a1'); syscall GfxBase 144;
PROCEDURE SortGList(rp : pRastPort location 'a1'); syscall GfxBase 150;
{$else}
PROCEDURE AddAnimOb(anOb : pAnimOb location 'a0'; anKey : ppAnimOb location 'a1'; rp : pRastPort location 'a2'); syscall GfxBase 156;
PROCEDURE AddBob(bob : pBob location 'a0'; rp : pRastPort location 'a1'); syscall GfxBase 096;
PROCEDURE AddFont(textFont : pTextFont location 'a1'); syscall GfxBase 480;
@ -2424,6 +2538,9 @@ function ObtainBestPen(cm : pColorMap; r : ULONG; g : ULONG; b : ULONG; Const ar
procedure SetRPAttrs(rp : pRastPort; Const argv : array of PtrUInt);
function VideoControlTags(colorMap : pColorMap; Const argv : array of PtrUInt) : LongWord;
function WeighTAMatchTags(reqTextAttr : pTextAttr; targetTextAttr : pTextAttr; Const argv : array of PtrUInt) : smallint;
PROCEDURE SafeSetOutlinePen(w : pRastPort; c : byte);
PROCEDURE SafeSetWriteMask( w : pRastPort ; m : smallint ) ;
{$endif}
{ gfxmacros }
@ -2433,9 +2550,7 @@ PROCEDURE SetAfPt(w: pRastPort;p: Pointer; n: Byte);
PROCEDURE SetDrPt(w: pRastPort;p: Word);
PROCEDURE SetOPen(w: pRastPort;c: Byte);
PROCEDURE SetWrMsk(w: pRastPort; m: Byte);
PROCEDURE SafeSetOutlinePen(w : pRastPort; c : byte);
PROCEDURE SafeSetWriteMask( w : pRastPort ; m : smallint ) ;
procedure RemBob(Bob: PBob); inline;
PROCEDURE OFF_DISPLAY (cust: pCustom);
PROCEDURE ON_DISPLAY (cust: pCustom);
@ -2449,8 +2564,85 @@ function AreaCircle(Rp: PRastPort; xCenter, yCenter, r: SmallInt): LongWord; inl
function RasSize(w, h: Word): Integer;
function CreateBitMap(Width, Height, Depth: Integer): PBitmap;
procedure DestroyBitMap(MyBM: PBitmap; Width, Height, Depth: Integer);
{$if defined(AMIGA_V1_2_ONLY)}
procedure SetABPenDrMd(Rp: PRastPort; APen, BPen, Drawmode: LongWord); inline;
function AllocBitMap(SizeX, SizeY, Depth, Flags: LongWord; friend_bitmap: PBitMap): PBitMap;
procedure FreeBitMap(Bm: PBitMap);
function GetBitMapAttr(Bm: PBitMap; AttrNum: LongWord): LongWord;
{$endif}
IMPLEMENTATION
procedure RemBob(Bob: PBob);
begin
Bob^.Flags := Bob^.Flags or BOBSAWAY;
end;
function CreateBitMap(Width, Height, Depth: Integer): PBitmap;
var
MyBM: PBitmap;
i: Integer;
begin
MyBM := ExecAllocMem(SizeOf(TBitMap), MEMF_CLEAR or MEMF_PUBLIC);
for i := 0 to Depth - 1 do
MyBM^.Planes[i] := AllocRaster(Width, Height);
for i := Depth to 7 do
MyBM^.Planes[i] := nil;
MyBM^.Flags := MyBM^.Flags or BMF_STANDARD;
CreateBitMap := MyBM;
end;
procedure DestroyBitMap(MyBM: PBitmap; Width, Height, Depth: Integer);
var
i: Integer;
begin
if MyBM <> nil then
begin
for i := 0 to Depth - 1 do
if MyBM^.Planes[i] <> nil then
FreeRaster(MyBM^.Planes[i], Width, Height);
FreeMem(MyBM, SizeOf(TBitMap));
end;
end;
{$if defined(AMIGA_V1_2_ONLY)}
procedure SetABPenDrMd(Rp: PRastPort; APen, BPen, Drawmode: LongWord);
begin
SetAPen(RP, APen);
SetBPen(RP, BPen);
SetDrMd(RP, DrawMode);
end;
function AllocBitMap(SizeX, SizeY, Depth, Flags: LongWord; friend_bitmap: PBitMap): PBitMap;
begin
AllocBitMap := CreateBitmap(SizeX, SizeY, Depth);
end;
procedure FreeBitMap(Bm: PBitMap);
begin
if bm <> nil then
DestroyBitMap(bm, Bm^.BytesPerRow * 8, bm^.Rows, bm^.Depth);
end;
function GetBitMapAttr(Bm: PBitMap; AttrNum: LongWord): LongWord;
begin
case AttrNum of
BMA_HEIGHT: GetBitMapAttr := bm^.Rows;
BMA_WIDTH: GetBitMapAttr := bm^.BytesPerRow * 8;
BMA_DEPTH: GetBitMapAttr := bm^.Depth;
BMA_FLAGS: GetBitMapAttr := bm^.Flags and (BMF_DISPLAYABLE or BMF_INTERLEAVED or BMF_STANDARD);
else
GetBitMapAttr := 0;
end;
end;
{$endif}
{$if not defined(AMIGA_V1_2_ONLY)}
function AllocSpriteData(bm : pBitMap; Const argv : array of PtrUInt) : pExtSprite;
begin
AllocSpriteData := AllocSpriteDataA(bm,@argv);
@ -2501,6 +2693,26 @@ begin
WeighTAMatchTags := WeighTAMatch(reqTextAttr,targetTextAttr,@argv);
end;
PROCEDURE SafeSetOutlinePen(w : pRastPort; c : byte);
begin
IF pGfxBase(GfxBase)^.LibNode.Lib_Version < 39 THEN begin
w^.AOlPen := c;
w^.Flags := w^.Flags OR AREAOUTLINE;
END ELSE begin
c := SetOutlinePen(w,c);
END;
END;
PROCEDURE SafeSetWriteMask( w : pRastPort ; m : smallint ) ;
VAR x : smallint ;
BEGIN
IF pGfxBase(GfxBase)^.LibNode.Lib_Version < 39 THEN w^.Mask := BYTE(m)
ELSE x := SetWriteMask( w, m );
END;
{$endif}
PROCEDURE BNDRYOFF (w: pRastPort);
BEGIN
WITH w^ DO BEGIN
@ -2549,22 +2761,6 @@ BEGIN
w^.Mask := m;
END;
PROCEDURE SafeSetOutlinePen(w : pRastPort; c : byte);
begin
IF pGfxBase(GfxBase)^.LibNode.Lib_Version < 39 THEN begin
w^.AOlPen := c;
w^.Flags := w^.Flags OR AREAOUTLINE;
END ELSE begin
c := SetOutlinePen(w,c);
END;
END;
PROCEDURE SafeSetWriteMask( w : pRastPort ; m : smallint ) ;
VAR x : smallint ;
BEGIN
IF pGfxBase(GfxBase)^.LibNode.Lib_Version < 39 THEN w^.Mask := BYTE(m)
ELSE x := SetWriteMask( w, m );
END;
PROCEDURE OFF_DISPLAY (cust: pCustom);
BEGIN

44
packages/amunits/src/coreunits/amigados.pas
View File

@ -1575,7 +1575,43 @@ CONST
{ tags for NewLoadSeg }
{ no tags are defined yet for NewLoadSeg }
{$if defined(AMIGA_V1_2_ONLY)}
PROCEDURE DOSClose(file_ : BPTR location 'd1'); syscall _DOSBase 036;
FUNCTION DOSOpen(const name : pCHAR location 'd1'; accessMode : LONGINT location 'd2') : BPTR; syscall _DOSBase 030;
FUNCTION DOSRead(file_ : BPTR location 'd1'; buffer : POINTER location 'd2'; length : LONGINT location 'd3') : LONGINT; syscall _DOSBase 042;
FUNCTION DOSSeek(file_ : BPTR location 'd1'; position : LONGINT location 'd2'; offset : LONGINT location 'd3') : LONGINT; syscall _DOSBase 066;
FUNCTION DOSWrite(file_ : BPTR location 'd1'; buffer : POINTER location 'd2'; length : LONGINT location 'd3') : LONGINT; syscall _DOSBase 048;
FUNCTION CreateDir(const name : pCHAR location 'd1') : BPTR; syscall _DOSBase 120;
FUNCTION CurrentDir(lock : BPTR location 'd1') : BPTR; syscall _DOSBase 126;
FUNCTION DOSDeleteFile(const name : STRPTR location 'd1') : LongBool; syscall _DOSBase 072;
FUNCTION Examine(lock : BPTR location 'd1'; fileInfoBlock : pFileInfoBlock location 'd2') : LongBool; syscall _DOSBase 102;
FUNCTION ExNext(lock : BPTR location 'd1'; fileInfoBlock : pFileInfoBlock location 'd2') : LongBool; syscall _DOSBase 108;
FUNCTION Info(lock : BPTR location 'd1'; parameterBlock : pInfoData location 'd2') : LongBool; syscall _DOSBase 114;
FUNCTION ParentDir(lock : BPTR location 'd1') : BPTR; syscall _DOSBase 210;
FUNCTION DOSRename(const oldName : STRPTR location 'd1';const newName : STRPTR location 'd2') : LongBool; syscall _DOSBase 078;
FUNCTION SetComment(const name : pCHAR location 'd1';const comment : pCHAR location 'd2') : LongBool; syscall _DOSBase 180;
FUNCTION SetProtection(const name : pCHAR location 'd1'; protect : LONGINT location 'd2') : LongBool; syscall _DOSBase 186;
FUNCTION DupLock(lock : BPTR location 'd1') : BPTR; syscall _DOSBase 096;
FUNCTION DOSInput : BPTR; syscall _DOSBase 054;
FUNCTION IoErr : LONGINT; syscall _DOSBase 132;
FUNCTION IsInteractive(file_ : BPTR location 'd1') : LongBool; syscall _DOSBase 216;
FUNCTION Lock(const name : pCHAR location 'd1'; type_ : LONGINT location 'd2') : LONGINT; syscall _DOSBase 084;
FUNCTION DOSOutput : BPTR; syscall _DOSBase 060;
PROCEDURE UnLock(lock : BPTR location 'd1'); syscall _DOSBase 090;
FUNCTION CreateProc(const name : pCHAR location 'd1'; pri : LONGINT location 'd2'; segList : BPTR location 'd3'; stackSize : LONGINT location 'd4') : pMsgPort; syscall _DOSBase 138;
PROCEDURE DateStamp(date : pDateStamp location 'd1'); syscall _DOSBase 192;
PROCEDURE DOSDelay(timeout : LONGINT location 'd1'); syscall _DOSBase 198;
FUNCTION DeviceProc(const name : pCHAR location 'd1') : pMsgPort; syscall _DOSBase 174;
PROCEDURE DOSExit(returnCode : LONGINT location 'd1'); syscall _DOSBase 144;
FUNCTION WaitForChar(file_ : BPTR location 'd1'; timeout : LONGINT location 'd2') : LongBool; syscall _DOSBase 204;
FUNCTION Execute(const string_ : pCHAR location 'd1'; file_ : BPTR location 'd2'; file2 : BPTR location 'd3') : LongBool; syscall _DOSBase 222;
FUNCTION LoadSeg(const name : pCHAR location 'd1') : LONGINT; syscall _DOSBase 150;
PROCEDURE UnLoadSeg(seglist : BPTR location 'd1'); syscall _DOSBase 156;
{$else}
PROCEDURE AbortPkt(port : pMsgPort location 'd1'; pkt : pDosPacket location 'd2'); syscall _DOSBase 264;
FUNCTION AddBuffers(const name : pCHAR location 'd1'; number : LONGINT location 'd2') : LongBool; syscall _DOSBase 732;
FUNCTION AddDosEntry(dlist : pDosList location 'd1') : LongBool; syscall _DOSBase 678;
@ -1739,10 +1775,13 @@ FUNCTION VPrintf(const format : pCHAR location 'd1'; const argarray : PLongInt l
FUNCTION WaitForChar(file_ : BPTR location 'd1'; timeout : LONGINT location 'd2') : LongBool; syscall _DOSBase 204;
FUNCTION WaitPkt : pDosPacket; syscall _DOSBase 252;
FUNCTION WriteChars(const buf : pCHAR location 'd1'; buflen : ULONG location 'd2') : LONGINT; syscall _DOSBase 942;
{$endif}
FUNCTION BADDR(bval :BPTR): POINTER;
FUNCTION MKBADDR(adr: Pointer): BPTR;
{$if not defined(AMIGA_V1_2_ONLY)}
// var args version
FUNCTION AllocDosObjectTags(type_ : ULONG; Const argv : Array of PtrUInt) : POINTER;
FUNCTION CreateNewProcTags(Const argv : Array of PtrUInt) : pProcess;
@ -1819,6 +1858,7 @@ FUNCTION SplitName(const name : string; seperator : ULONG; buf : pCHAR; oldpos :
FUNCTION StrToLong(const string_ : string; VAR value : LONGINT) : LONGINT;
FUNCTION SystemTagList(const command : string;const tags : pTagItem) : LONGINT;
FUNCTION DOSSystem(const command : string;const tags : pTagItem) : LONGINT;
{$endif}
IMPLEMENTATION
@ -1832,7 +1872,7 @@ FUNCTION MKBADDR(adr : POINTER): BPTR; inline;
BEGIN
MKBADDR := BPTR( PTRUINT(adr) shr 2);
END;
{$if not defined(AMIGA_V1_2_ONLY)}
FUNCTION AllocDosObjectTags(type_ : ULONG; Const argv : Array of PtrUInt) : POINTER;
begin
AllocDosObjectTags := AllocDosObjectTagList(type_, @argv);
@ -2192,7 +2232,7 @@ FUNCTION DOSSystem(const command : string;const tags : pTagItem) : LONGINT;
begin
DOSSystem := DOSSystem(PChar(RawByteString(command)),tags);
end;
{$endif}
END. (* UNIT DOS *)

7
packages/amunits/src/coreunits/amigalib.pas
View File

@ -73,6 +73,7 @@ function CreateTask (name: STRPTR; pri: longint;
procedure DeleteTask (task: pTask); inline;
procedure NewList (list: pList); inline;
{$if not defined(AMIGA_V1_2_ONLY)}
// moved to commodities, use them from there
{* Commodities support functions from amiga.lib *}
procedure FreeIEvents (events: pInputEvent); inline;
@ -99,6 +100,7 @@ function CoerceMethodA(cl : pIClass; obj : pObject_; msg : APTR): ulong; inline;
function SetSuperAttrsA(cl : pIClass; obj: pObject_; msg : APTR): ulong; inline;
function DoMethod(obj: PObject_; Params: array of DWord): LongWord; inline;
{$endif}
// moved to utility, use them from there
procedure HookEntry;
@ -256,6 +258,7 @@ begin
CxTranslate := Commodities.CxTranslate(ie)
end;
{$if not defined(AMIGA_V1_2_ONLY)}
function DoMethodA(obj : pObject_; msg : APTR): ulong; inline;
begin
DoMethodA := Intuition.DoMethodA(obj, msg);
@ -280,7 +283,7 @@ function SetSuperAttrsA(cl : pIClass; obj: pObject_; msg : APTR): ulong; inline;
begin
SetSuperAttrsA := Intuition.SetSuperAttrsA(cl, obj, msg);
end;
{$endif}
{ Do *NOT* change this to nostackframe! }
{ The compiler will build a stackframe with link/unlk. So that will actually correct
the stackpointer for both Pascal/StdCall and Cdecl functions, so the stackpointer
@ -333,7 +336,9 @@ begin
end;
end;
end;
{$if not defined(AMIGA_V1_2_ONLY)}
VPrintf(Fmtstr,@argarray[0]);
{$endif}
end;
procedure printf(Fmtstr : string; const Args : array of const);

139
packages/amunits/src/coreunits/exec.pas
View File

@ -1176,6 +1176,111 @@ CONST
var
ExecBase: PExecBase absolute _ExecBase;
{$if defined(AMIGA_V1_2_ONLY)}
FUNCTION Supervisor(userFunction : tPROCEDURE location 'a5') : ULONG; syscall _ExecBase 030;
PROCEDURE Alert(alertNum : ULONG location 'd7'); syscall _ExecBase 108;
PROCEDURE Debug(flags : ULONG location 'd0'); syscall _ExecBase 114;
FUNCTION FindResident(const name : pCHAR location 'a1') : pResident; syscall _ExecBase 096;
PROCEDURE InitCode(startClass : ULONG location 'd0'; version : ULONG location 'd1'); syscall _ExecBase 072;
FUNCTION InitResident(const resident_ : pResident location 'a1'; segList : ULONG location 'd0') : POINTER; syscall _ExecBase 102;
PROCEDURE InitStruct(const initTable : POINTER location 'a1'; memory : POINTER location 'a2'; size : ULONG location 'd0'); syscall _ExecBase 078;
PROCEDURE AddIntServer(intNumber : LONGINT location 'd0'; interrupt_ : pInterrupt location 'a1'); syscall _ExecBase 168;
PROCEDURE Cause(interrupt_ : pInterrupt location 'a1'); syscall _ExecBase 180;
PROCEDURE Disable; syscall _ExecBase 120;
PROCEDURE Enable; syscall _ExecBase 126;
PROCEDURE Forbid; syscall _ExecBase 132;
PROCEDURE Permit; syscall _ExecBase 138;
PROCEDURE RemIntServer(intNumber : LONGINT location 'd0'; interrupt_ : pInterrupt location 'a1'); syscall _ExecBase 174;
FUNCTION SetIntVector(intNumber : LONGINT location 'd0';const interrupt_ : pInterrupt location 'a1') : pInterrupt; syscall _ExecBase 162;
FUNCTION SetSR(newSR : ULONG location 'd0'; mask : ULONG location 'd1') : ULONG; syscall _ExecBase 144;
FUNCTION SuperState : POINTER; syscall _ExecBase 150;
PROCEDURE UserState(sysStack : POINTER location 'd0'); syscall _ExecBase 156;
FUNCTION AllocAbs(byteSize : ULONG location 'd0'; location : POINTER location 'a1') : POINTER; syscall _ExecBase 204;
FUNCTION Allocate(freeList : pMemHeader location 'a0'; byteSize : ULONG location 'd0') : POINTER; syscall _ExecBase 186;
FUNCTION AllocEntry(entry : pMemList location 'a0') : pMemList; syscall _ExecBase 222;
FUNCTION ExecAllocMem(byteSize : ULONG location 'd0'; requirements : ULONG location 'd1') : POINTER; syscall _ExecBase 198;
FUNCTION AvailMem(requirements : ULONG location 'd1') : ULONG; syscall _ExecBase 216;
PROCEDURE Deallocate(freeList : pMemHeader location 'a0'; memoryBlock : POINTER location 'a1'; byteSize : ULONG location 'd1'); syscall _ExecBase 192;
PROCEDURE FreeEntry(entry : pMemList location 'a0'); syscall _ExecBase 228;
PROCEDURE ExecFreeMem(memoryBlock : POINTER location 'a1'; byteSize : ULONG location 'd0'); syscall _ExecBase 210;
PROCEDURE AddHead(list : pList location 'a0'; node : pNode location 'a1'); syscall _ExecBase 240;
PROCEDURE AddTail(list : pList location 'a0'; node : pNode location 'a1'); syscall _ExecBase 246;
PROCEDURE Enqueue(list : pList location 'a0'; node : pNode location 'a1'); syscall _ExecBase 270;
FUNCTION FindName(list : pList location 'a0'; const name : pCHAR location 'a1') : pNode; syscall _ExecBase 276;
PROCEDURE ExecInsert(list : pList location 'a0'; node : pNode location 'a1'; pred : pNode location 'a2'); syscall _ExecBase 234;
FUNCTION RemHead(list : pList location 'a0') : pNode; syscall _ExecBase 258;
PROCEDURE Remove(node : pNode location 'a1'); syscall _ExecBase 252;
FUNCTION RemTail(list : pList location 'a0') : pNode; syscall _ExecBase 264;
FUNCTION AddTask(task : pTask location 'a1';const initPC : POINTER location 'a2';const finalPC : POINTER location 'a3') : POINTER; syscall _ExecBase 282;
FUNCTION AllocSignal(signalNum : LONGINT location 'd0') : shortint; syscall _ExecBase 330;
FUNCTION AllocTrap(trapNum : LONGINT location 'd0') : LONGINT; syscall _ExecBase 342;
FUNCTION FindTask(const name : pCHAR location 'a1') : pTask; syscall _ExecBase 294;
PROCEDURE FreeSignal(signalNum : LONGINT location 'd0'); syscall _ExecBase 336;
PROCEDURE FreeTrap(trapNum : LONGINT location 'd0'); syscall _ExecBase 348;
PROCEDURE RemTask(task : pTask location 'a1'); syscall _ExecBase 288;
FUNCTION SetExcept(newSignals : ULONG location 'd0'; signalSet : ULONG location 'd1') : ULONG; syscall _ExecBase 312;
FUNCTION SetSignal(newSignals : ULONG location 'd0'; signalSet : ULONG location 'd1') : ULONG; syscall _ExecBase 306;
FUNCTION SetTaskPri(task : pTask location 'a1'; priority : LONGINT location 'd0') : shortint; syscall _ExecBase 300;
FUNCTION Wait(signalSet : ULONG location 'd0') : ULONG; syscall _ExecBase 318;
PROCEDURE AddPort(port : pMsgPort location 'a1'); syscall _ExecBase 354;
FUNCTION FindPort(const name : pCHAR location 'a1') : pMsgPort; syscall _ExecBase 390;
FUNCTION GetMsg(port : pMsgPort location 'a0') : pMessage; syscall _ExecBase 372;
PROCEDURE PutMsg(port : pMsgPort location 'a0'; message : pMessage location 'a1'); syscall _ExecBase 366;
PROCEDURE RemPort(port : pMsgPort location 'a1'); syscall _ExecBase 360;
PROCEDURE ReplyMsg(message : pMessage location 'a1'); syscall _ExecBase 378;
FUNCTION WaitPort(port : pMsgPort location 'a0') : pMessage; syscall _ExecBase 384;
PROCEDURE AddLibrary(lib : pLibrary location 'a1'); syscall _ExecBase 396;
PROCEDURE CloseLibrary(lib : pLibrary location 'a1'); syscall _ExecBase 414;
PROCEDURE MakeFunctions(const target : POINTER location 'a0';const functionArray : POINTER location 'a1';const funcDispBase :pointer location 'a2'); syscall _ExecBase 090;
FUNCTION MakeLibrary(const funcInit : POINTER location 'a0';const structInit : POINTER location 'a1'; libInit : tPROCEDURE location 'a2';dataSize : ULONG location 'd0'; segList : ULONG location 'd0') : pLibrary; syscall _ExecBase 084;
FUNCTION OldOpenLibrary(const libName : pCHAR location 'a1') : pLibrary; syscall _ExecBase 408;
FUNCTION OpenLibrary(const libName : pCHAR location 'a1'; version : ULONG location 'd0') : pLibrary; syscall _ExecBase 552;
PROCEDURE RemLibrary(lib : pLibrary location 'a1'); syscall _ExecBase 402;
FUNCTION SetFunction(lib : pLibrary location 'a1'; funcOffset : LONGINT location 'a0'; newFunction : tPROCEDURE location 'd0') : POINTER; syscall _ExecBase 420;
PROCEDURE SumLibrary(lib : pLibrary location 'a1'); syscall _ExecBase 426;
PROCEDURE AbortIO(ioRequest : pIORequest location 'a1'); syscall _ExecBase 480;
PROCEDURE AddDevice(device : pDevice location 'a1'); syscall _ExecBase 432;
FUNCTION CheckIO(ioRequest : pIORequest location 'a1') : pIORequest; syscall _ExecBase 468;
PROCEDURE CloseDevice(ioRequest : pIORequest location 'a1'); syscall _ExecBase 450;
FUNCTION DoIO(ioRequest : pIORequest location 'a1') : shortint; syscall _ExecBase 456;
FUNCTION OpenDevice(const devName : pCHAR location 'a0'; unite : ULONG location 'd0'; ioRequest : pIORequest location 'a1'; flags : ULONG location 'd1') : shortint; syscall _ExecBase 444;
PROCEDURE RemDevice(device : pDevice location 'a1'); syscall _ExecBase 438;
PROCEDURE SendIO(ioRequest : pIORequest location 'a1'); syscall _ExecBase 462;
FUNCTION WaitIO(ioRequest : pIORequest location 'a1') : shortint; syscall _ExecBase 474;
PROCEDURE AddResource(resource : POINTER location 'a1'); syscall _ExecBase 486;
FUNCTION OpenResource(const resName : pCHAR location 'a1') : POINTER; syscall _ExecBase 498;
PROCEDURE RemResource(resource : POINTER location 'a1'); syscall _ExecBase 492;
PROCEDURE AddSemaphore(sigSem : pSignalSemaphore location 'a1'); syscall _ExecBase 600;
FUNCTION AttemptSemaphore(sigSem : pSignalSemaphore location 'a0') : LongBool; syscall _ExecBase 576;
FUNCTION FindSemaphore(const sigSem : pCHAR location 'a1') : pSignalSemaphore; syscall _ExecBase 594;
PROCEDURE InitSemaphore(sigSem : pSignalSemaphore location 'a0'); syscall _ExecBase 558;
PROCEDURE ObtainSemaphore(sigSem : pSignalSemaphore location 'a0'); syscall _ExecBase 564;
PROCEDURE ObtainSemaphoreList(sigSem : pList location 'a0'); syscall _ExecBase 582;
FUNCTION Procure(sigSem : pSignalSemaphore location 'a0'; bidMsg : pSemaphoreMessage location 'a1') : LongBool; syscall _ExecBase 540;
PROCEDURE ReleaseSemaphore(sigSem : pSignalSemaphore location 'a0'); syscall _ExecBase 570;
PROCEDURE ReleaseSemaphoreList(sigSem : pList location 'a0'); syscall _ExecBase 588;
PROCEDURE RemSemaphore(sigSem : pSignalSemaphore location 'a1'); syscall _ExecBase 606;
PROCEDURE Vacate(sigSem : pSignalSemaphore location 'a0'; bidMsg : pSemaphoreMessage location 'a1'); syscall _ExecBase 546;
PROCEDURE AddMemList(size : ULONG location 'd0'; attributes : ULONG location 'd1'; pri : LONGINT location 'd2'; base : POINTER location 'a0'; const name : pCHAR location 'a1'); syscall _ExecBase 618;
PROCEDURE CopyMem(const source : POINTER location 'a0'; dest : POINTER location 'a1'; size : ULONG location 'd0'); syscall _ExecBase 624;
PROCEDURE CopyMemQuick(const source : POINTER location 'a0'; dest : POINTER location 'a1'; size : ULONG location 'd0'); syscall _ExecBase 630;
PROCEDURE SumKickData; syscall _ExecBase 612;
FUNCTION GetCC : ULONG; syscall _ExecBase 528;
function RawDoFmt(const formatString : pCHAR location 'a0';const dataStream : POINTER location 'a1'; putChProc : tPROCEDURE location 'a2'; putChData : POINTER location 'a3'): pointer; syscall _ExecBase 522;
FUNCTION TypeOfMem(const address : POINTER location 'a1') : ULONG; syscall _ExecBase 534;
{$else}
PROCEDURE AbortIO(ioRequest : pIORequest location 'a1'); syscall _ExecBase 480;
PROCEDURE AddDevice(device : pDevice location 'a1'); syscall _ExecBase 432;
PROCEDURE AddHead(list : pList location 'a0'; node : pNode location 'a1'); syscall _ExecBase 240;
@ -1306,6 +1411,7 @@ FUNCTION AVL_FindNextNodeByAddress(CONST node : pAVLNode location 'a0') : pAVLNo
FUNCTION AVL_FindNextNodeByKey(CONST root : pAVLNode location 'a0'; key : POINTER location 'a1'; func : POINTER location 'a2') : pAVLNode; syscall _ExecBase 894;
FUNCTION AVL_FindFirstNode(CONST root : pAVLNode location 'a0') : pAVLNode; syscall _ExecBase 900;
FUNCTION AVL_FindLastNode(CONST root : pAVLNode location 'a0') : pAVLNode; syscall _ExecBase 906;
{$endif}
FUNCTION FindName(list : pList; const name : String) : pNode;
FUNCTION FindPort(const name : String) : pMsgPort;
@ -1333,6 +1439,16 @@ function CreateTask(Name: STRPTR; Pri: LongInt; InitPC: Pointer; StackSize: Long
procedure DeleteTask(Task: PTask);
procedure NewList(List: PList);
{$if defined(AMIGA_V1_2_ONLY)}
function CreateMsgPort: PMsgPort;
procedure DeleteMsgPort(Port: PMsgPort);
function CreateIORequest(const Port: PMsgPort; Size: LongWord): PIORequest;
procedure DeleteIORequest(IOReq: PIORequest);
{$endif}
IMPLEMENTATION
function BitMask(no :shortint): longint; inline;
@ -1444,6 +1560,17 @@ begin
end
end;
{$if defined(AMIGA_V1_2_ONLY)}
function CreateIORequest(const Port: PMsgPort; Size: LongWord): PIORequest;
begin
CreateIORequest := CreateExtIO(Port, Size);
end;
procedure DeleteIORequest(IOReq: PIORequest);
begin
DeleteExtIO(IOReq);
end;
{$endif}
function CreateStdIO(Port: PMsgPort): PIOStdReq;
begin
@ -1507,6 +1634,18 @@ begin
end;
end;
{$if defined(AMIGA_V1_2_ONLY)}
function CreateMsgPort: PMsgPort;
begin
CreateMsgPort := CreatePort(nil, 0);
end;
procedure DeleteMsgPort(Port: PMsgPort);
begin
DeletePort(Port);
end;
{$endif}
function CreateTask(Name: STRPTR; Pri: LongInt; InitPC: Pointer; StackSize: LongWord): PTask;
var
Memlist: PMemList;

376
packages/amunits/src/coreunits/intuition.pas
View File

@ -4067,6 +4067,94 @@ CONST
var
IntuitionBase: pIntuitionBase;
{$if defined(AMIGA_V1_2_ONLY)}
PROCEDURE ActivateWindow(window : pWindow location 'a0'); syscall _IntuitionBase 450;
PROCEDURE CloseWindow(window : pWindow location 'a0'); syscall _IntuitionBase 072;
FUNCTION ModifyIDCMP(window : pWindow location 'a0'; flags : ULONG location 'd0') : LongBool; syscall _IntuitionBase 150;
PROCEDURE MoveWindow(window : pWindow location 'a0'; dx : LONGINT location 'd0'; dy : LONGINT location 'd1'); syscall _IntuitionBase 168;
FUNCTION OpenWindow(const newWindow : pNewWindow location 'a0') : pWindow; syscall _IntuitionBase 204;
PROCEDURE RefreshWindowFrame(window : pWindow location 'a0'); syscall _IntuitionBase 456;
PROCEDURE SetWindowTitles(window : pWindow location 'a0';const windowTitle : pCHAR location 'a1';const screenTitle : pCHAR location 'a2'); syscall _IntuitionBase 276;
PROCEDURE SizeWindow(window : pWindow location 'a0'; dx : LONGINT location 'd0'; dy : LONGINT location 'd1'); syscall _IntuitionBase 288;
FUNCTION WindowLimits(window : pWindow location 'a0'; widthMin : LONGINT location 'd0'; heightMin : LONGINT location 'd1'; widthMax : ULONG location 'd2'; heightMax : ULONG location 'd3') : LongBool; syscall _IntuitionBase 318;
PROCEDURE WindowToBack(window : pWindow location 'a0'); syscall _IntuitionBase 306;
PROCEDURE WindowToFront(window : pWindow location 'a0'); syscall _IntuitionBase 312;
FUNCTION ActivateGadget(gadgets : pGadget location 'a0'; window : pWindow location 'a1'; requester : pRequester location 'a2') : LongBool syscall _IntuitionBase 462;
FUNCTION AddGadget(window : pWindow location 'a0'; gadget : pGadget location 'a1'; position : ULONG location 'd0') : WORD; syscall _IntuitionBase 042;
FUNCTION AddGList(window : pWindow location 'a0'; gadget : pGadget location 'a1'; position : ULONG location 'd0'; numGad : LONGINT location 'd1'; requester : pRequester location 'a2') : WORD; syscall _IntuitionBase 438;
PROCEDURE ModifyProp(gadget : pGadget location 'a0'; window : pWindow location 'a1'; requester : pRequester location 'a2'; flags : ULONG location 'd0'; horizPot : ULONG location 'd1'; vertPot : ULONG location 'd2'; horizBody : ULONG location 'd3'; vertBody : ULONG location 'd4'); syscall _IntuitionBase 156;
PROCEDURE NewModifyProp(gadget : pGadget location 'a0'; window : pWindow location 'a1'; requester : pRequester location 'a2'; flags : ULONG location 'd0'; horizPot : ULONG location 'd1'; vertPot : ULONG location 'd2'; horizBody : ULONG location 'd3'; vertBody : ULONG location 'd4'; numGad : LONGINT location 'd5'); syscall _IntuitionBase 468;
PROCEDURE OffGadget(gadget : pGadget location 'a0'; window : pWindow location 'a1'; requester : pRequester location 'a2'); syscall _IntuitionBase 174;
PROCEDURE OnGadget(gadget : pGadget location 'a0'; window : pWindow location 'a1'; requester : pRequester location 'a2'); syscall _IntuitionBase 186;
PROCEDURE RefreshGadgets(gadgets : pGadget location 'a0'; window : pWindow location 'a1'; requester : pRequester location 'a2'); syscall _IntuitionBase 222;
PROCEDURE RefreshGList(gadgets : pGadget location 'a0'; window : pWindow location 'a1'; requester : pRequester location 'a2'; numGad : LONGINT location 'd0'); syscall _IntuitionBase 432;
FUNCTION RemoveGadget(window : pWindow; gadget : pGadget) : WORD; syscall _IntuitionBase 228;
FUNCTION RemoveGList(remPtr : pWindow location 'a0'; gadget : pGadget location 'a1'; numGad : LONGINT location 'd0') : WORD; syscall _IntuitionBase 444;
PROCEDURE ClearMenuStrip(window : pWindow location 'a0'); syscall _IntuitionBase 054;
FUNCTION ItemAddress(const menuStrip : pMenu location 'a0'; menuNumber : ULONG location 'd0') : pMenuItem; syscall _IntuitionBase 144;
PROCEDURE OffMenu(window : pWindow location 'a0'; menuNumber : ULONG location 'd0'); syscall _IntuitionBase 180;
PROCEDURE OnMenu(window : pWindow location 'a0'; menuNumber : ULONG location 'd0'); syscall _IntuitionBase 192;
FUNCTION SetMenuStrip(window : pWindow location 'a0'; menu : pMenu location 'a1') : LongBool; syscall _IntuitionBase 264;
FUNCTION AutoRequest(window : pWindow location 'a0';const body : pIntuiText location 'a1';const posText : pIntuiText location 'a2';const negText : pIntuiText location 'a3'; pFlag : ULONG location 'd0'; nFlag : ULONG location 'd1'; width : ULONG location 'd2'; height : ULONG location 'd3') : LongBool; syscall _IntuitionBase 348;
FUNCTION BuildSysRequest(window : pWindow location 'a0';const body : pIntuiText location 'a1';const posText : pIntuiText location 'a2';const negText : pIntuiText location 'a3'; flags : ULONG location 'd0'; width : ULONG location 'd1'; height : ULONG location 'd2') : pWindow; syscall _IntuitionBase 360;
FUNCTION ClearDMRequest(window : pWindow location 'a0') : LongBool; syscall _IntuitionBase 048;
FUNCTION DisplayAlert(alertNumber : ULONG location 'd0';const string_ : pCHAR location 'a0'; height : ULONG location 'd1') : LongBool; syscall _IntuitionBase 090;
PROCEDURE EndRequest(requester : pRequester location 'a0'; window : pWindow location 'a1'); syscall _IntuitionBase 120;
PROCEDURE FreeSysRequest(window : pWindow location 'a0'); syscall _IntuitionBase 372;
PROCEDURE InitRequester(requester : pRequester location 'a0'); syscall _IntuitionBase 138;
FUNCTION Request(requester : pRequester location 'a0'; window : pWindow location 'a1') : LongBool; syscall _IntuitionBase 240;
FUNCTION SetDMRequest(window : pWindow location 'a0'; requester : pRequester location 'a1') : LongBool; syscall _IntuitionBase 258;
function CloseScreen(screen : pScreen location 'a0'): LongBool; syscall _IntuitionBase 066;
FUNCTION CloseWorkBench : LongBool; syscall _IntuitionBase 078;
PROCEDURE DisplayBeep(screen : pScreen location 'a0'); syscall _IntuitionBase 096;
FUNCTION GetScreenData(buffer : POINTER location 'a0'; size : ULONG location 'D0'; type_ : ULONG location 'd1';const screen : pScreen location 'a1') : LongBool; syscall _IntuitionBase 426;
FUNCTION MakeScreen(screen : pScreen location 'a0') : LONGINT; syscall _IntuitionBase 378;
PROCEDURE MoveScreen(screen : pScreen location 'a0'; dx : LONGINT location 'd0'; dy : LONGINT location 'd1'); syscall _IntuitionBase 162;
FUNCTION OpenScreen(const newScreen : pNewScreen location 'a0') : pScreen; syscall _IntuitionBase 198;
FUNCTION OpenWorkBench : ULONG; syscall _IntuitionBase 210;
PROCEDURE ScreenToBack(screen : pScreen location 'a0'); syscall _IntuitionBase 246;
PROCEDURE ScreenToFront(screen : pScreen location 'a0'); syscall _IntuitionBase 252;
PROCEDURE ShowTitle(screen : pScreen location 'a0'; showIt : LONGINT location 'd0'); syscall _IntuitionBase 282;
FUNCTION WBenchToBack : LongBool; syscall _IntuitionBase 336;
FUNCTION WBenchToFront : LongBool; syscall _IntuitionBase 342;
PROCEDURE ClearPointer(window : pWindow location 'a0'); syscall _IntuitionBase 060;
PROCEDURE DrawBorder(rp : pRastPort location 'a0';const border : pBorder location 'a1'; leftOffset : LONGINT location 'd0'; topOffset : LONGINT location 'd1'); syscall _IntuitionBase 108;
PROCEDURE DrawImage(rp : pRastPort location 'a0'; image : pImage location 'a1'; leftOffset : LONGINT location 'd0'; topOffset : LONGINT location 'd1'); syscall _IntuitionBase 114;
FUNCTION IntuiTextLength(const iText : pIntuiText location 'a0') : LONGINT; syscall _IntuitionBase 330;
PROCEDURE PrintIText(rp : pRastPort location 'a0';const iText : pIntuiText location 'a1'; left : LONGINT location 'd0'; top : LONGINT location 'd1'); syscall _IntuitionBase 216;
PROCEDURE SetPointer(window : pWindow location 'a0'; pointer_ : pword location 'a1'; height : LONGINT location 'd0'; width : LONGINT location 'd1'; xOffset : LONGINT location 'd2'; yOffset : LONGINT location 'd3'); syscall _IntuitionBase 270;
FUNCTION AllocRemember(var rememberKey : pRemember location 'a0'; size : ULONG location 'd0'; flags : ULONG location 'd1') : POINTER syscall _IntuitionBase 396;
PROCEDURE FreeRemember(VAR rememberKey : pRemember location 'a0'; reallyForget : LONGINT location 'd0'); syscall _IntuitionBase 408;
PROCEDURE BeginRefresh(window : pWindow location 'a0'); syscall _IntuitionBase 354;
PROCEDURE EndRefresh(window : pWindow location 'a0'; complete : LONGBOOL location 'd0'); syscall _IntuitionBase 366;
FUNCTION RemakeDisplay : LONGINT; syscall _IntuitionBase 384;
FUNCTION RethinkDisplay : LONGINT; syscall _IntuitionBase 390;
FUNCTION LockIBase(dontknow : ULONG location 'd0') : ULONG; syscall _IntuitionBase 414;
PROCEDURE UnlockIBase(ibLock : ULONG location 'a0'); syscall _IntuitionBase 420;
FUNCTION ViewAddress : pView; syscall _IntuitionBase 294;
FUNCTION ViewPortAddress(const window : pWindow location 'a0') : pViewPort; syscall _IntuitionBase 300;
PROCEDURE CurrentTime(VAR seconds : ULONG location 'a0'; VAR micros : ULONG location 'a1'); syscall _IntuitionBase 084;
FUNCTION DoubleClick(sSeconds : ULONG location 'd0'; sMicros : ULONG location 'd1'; cSeconds : ULONG location 'd2'; cMicros : ULONG location 'd3') : LongBool; syscall _IntuitionBase 102;
FUNCTION GetDefPrefs(preferences : pPreferences location 'a0'; size : LONGINT location 'd0') : pPreferences; syscall _IntuitionBase 126;
FUNCTION GetPrefs(preferences : pPreferences location 'a0'; size : LONGINT location 'd0') : pPreferences; syscall _IntuitionBase 132;
PROCEDURE ReportMouse(flag : LONGINT location 'd0'; window : pWindow location 'a0'); syscall _IntuitionBase 234;
FUNCTION SetPrefs(const preferences : pPreferences location 'a0'; size : LONGINT location 'd0'; inform : LONGINT location 'd1') : pPreferences; syscall _IntuitionBase 324;
function OpenWindowTagList(NewWindow: PNewWindow; TagList: PTagItem):PWindow;
function OpenScreenTagList(NewScreen: PNewScreen; TagList: PTagItem): PScreen;
function EasyRequestArgs(Window: PWindow; const EasyStruct: PEasyStruct; IDCMPPtr: PLongWord; const Args: Pointer): LongInt;
{$else}
FUNCTION ActivateGadget(gadgets : pGadget location 'a0'; window : pWindow location 'a1'; requester : pRequester location 'a2') : LongBool syscall _IntuitionBase 462;
PROCEDURE ActivateWindow(window : pWindow location 'a0'); syscall _IntuitionBase 450;
PROCEDURE AddClass(classPtr : pIClass location 'a0'); syscall _IntuitionBase 684;
@ -4189,24 +4277,29 @@ FUNCTION WindowLimits(window : pWindow location 'a0'; widthMin : LONGINT locatio
PROCEDURE WindowToBack(window : pWindow location 'a0'); syscall _IntuitionBase 306;
PROCEDURE WindowToFront(window : pWindow location 'a0'); syscall _IntuitionBase 312;
PROCEDURE ZipWindow(window : pWindow location 'a0'); syscall _IntuitionBase 504;
{$endif}
function OpenScreenTags(newScreen : pNewScreen; tagList : array of PtrUInt) : pScreen;
function OpenWindowTags(newWindow : pNewWindow; tagList : array of PtrUInt) : pWindow;
{$if not defined(AMIGA_V1_2_ONLY)}
function NewObject(classPtr : pIClass; classID : string; Const argv : array of PtrUInt ) : POINTER;
function NewObject(classPtr : pIClass; classID : pCHAR; Const argv : array of PtrUInt) : POINTER;
function SetAttrs(obj : POINTER; tags: array of DWord) : ULONG;
function SetGadgetAttrs(gadget : pGadget; window : pWindow; requester : pRequester; Const argv : array of PtrUInt) : ULONG;
function NewObject(classPtr : pIClass; classID : string; Const argv : array of PtrUInt ) : POINTER;
function EasyRequest(window : pWindow;const easyStruct : pEasyStruct; idcmpPtr : pULONG; args : array of DWord) : LONGINT;
procedure SetWindowPointer(win : pWindow; tags: array of DWord);
{$endif}
function EasyRequest(window : pWindow;const easyStruct : pEasyStruct; idcmpPtr : pULONG; args : array of DWord) : LONGINT;
{ Intuition macros }
{$if not defined(AMIGA_V1_2_ONLY)}
function INST_DATA (cl: pIClass; o: p_Object): Pointer;
function SIZEOF_INSTANCE (cl: pIClass): Longint;
function BASEOBJECT (o: p_Object): Pointer;
function _OBJ(o: p_Object): p_Object; inline;
function __OBJECT (o: Pointer): p_Object; inline;
function OCLASS (o: Pointer): pIClass; inline;
{$endif}
function SHIFTITEM (n: smallint): word;
function SHIFTMENU (n: smallint): word;
function SHIFTSUB (n: smallint): word;
@ -4222,14 +4315,17 @@ function SUBNUM( n : Word): Word;
FUNCTION DisplayAlert(alertNumber : ULONG;const string_ : string; height : ULONG) : BOOLEAN;
FUNCTION LockPubScreen(const name : string) : pScreen;
{$if not defined(AMIGA_V1_2_ONLY)}
FUNCTION MakeClass(const classID : string;const superClassID : pCHAR;const superClassPtr : pIClass; instanceSize : ULONG; flags : ULONG) : pIClass;
FUNCTION MakeClass(const classID : pCHAR;const superClassID : string;const superClassPtr : pIClass; instanceSize : ULONG; flags : ULONG) : pIClass;
FUNCTION MakeClass(const classID : string;const superClassID : string;const superClassPtr : pIClass; instanceSize : ULONG; flags : ULONG) : pIClass;
FUNCTION NewObjectA(classPtr : pIClass;const classID : string;const tagList : pTagItem) : POINTER;
{$endif}
PROCEDURE SetDefaultPubScreen(const name : string);
FUNCTION TimedDisplayAlert(alertNumber : ULONG;const string_ : string; height : ULONG; time : ULONG) : BOOLEAN;
PROCEDURE UnlockPubScreen(const name : string; screen : pScreen);
{$if not defined(AMIGA_V1_2_ONLY)}
function DoMethodA(Obj: PObject_; Msg: APTR): PtrUInt;
function DoSuperMethodA(Cl: PIClass; Obj: PObject_; Msg: APTR): PtrUInt;
function CoerceMethodA(Cl: PIClass; Obj: PObject_; Msg: APTR): PtrUInt;
@ -4237,9 +4333,265 @@ function SetSuperAttrsA(Cl: PIClass; Obj: PObject_; Msg : APTR): PtrUInt;
function DoMethod(Obj: PObject_; Params: array of PtrUInt): LongWord; inline;
function DoSuperMethod(Cl: PIClass; Obj: PObject_; const Params: array of PtrUInt): PtrUInt; inline;
{$endif}
IMPLEMENTATION
{$if defined(AMIGA_V1_2_ONLY)}
function OpenWindowTagList(NewWindow: PNewWindow; TagList: PTagItem):PWindow;
var
Nw: TNewWindow;
Scr: PScreen;
LockedScreenName: PChar;
ScreenTitle: PChar;
Win: PWindow;
ILock: LongWord;
begin
if not Assigned(NewWindow) then
begin
NewWindow := @Nw;
FillChar(Nw, SizeOf(Nw), 0);
NW.LeftEdge := 20;
NW.TopEdge := 20;
NW.Width := 200;
NW.Height := 100;
Nw.DetailPen := 0;
Nw.BlockPen := 1;
nw.MaxWidth := 640;
nw.MaxHeight := 512;
nw.WType := WBENCHSCREEN_F;
end;
LockedScreenName := nil;
ScreenTitle := nil;
//
while TagList <> nil do
begin
case TagList^.ti_Tag of
WA_Flags: NewWindow^.Flags := NewWindow^.Flags or TagList^.ti_Data;
WA_Gadgets: NewWindow^.FirstGadget := Pointer(TagList^.ti_Data);
WA_GimmeZeroZero: NewWindow^.Flags := NewWindow^.Flags or WFLG_GIMMEZEROZERO;
WA_InnerHeight,WA_Height: NewWindow^.Height := TagList^.ti_Data;
WA_IDCMP: NewWindow^.IDCMPFlags := NewWindow^.IDCMPFlags or TagList^.ti_Data;
WA_Left: NewWindow^.LeftEdge := TagList^.ti_Data;
WA_MaxHeight: NewWindow^.MaxHeight := TagList^.ti_Data;
WA_MaxWidth: NewWindow^.MaxWidth := TagList^.ti_Data;
WA_MinHeight: NewWindow^.MinHeight := TagList^.ti_Data;
WA_MinWidth: NewWindow^.MinWidth := TagList^.ti_Data;
WA_NoCareRefresh: NewWindow^.Flags := NewWindow^.Flags or WFLG_NOCAREREFRESH;
WA_PubScreen: NewWindow^.Screen := Pointer(TagList^.ti_Data);
WA_PubScreenName:
begin
ILock := LockIBase(0);
LockedScreenName := PChar(TagList^.ti_Data);
if (LowerCase(string(LockedScreenName)) = 'workbench') or (LockedScreenName = nil) then
begin
NewWindow^.WType := WBENCHSCREEN_F;
NewWindow^.Screen := nil;
end
else
begin
Scr := pIntuitionBase(_IntuitionBase)^.FirstScreen;
while Assigned(Scr) do
begin
if LowerCase(string(scr^.Title)) = LowerCase(string(LockedScreenName)) then
begin
NewWindow^.Screen := Scr;
NewWindow^.WType := CUSTOMSCREEN_F;
Break;
end;
Scr := Scr^.NextScreen
end;
UnlockIBase(ILock);
end;
end;
WA_ReportMouse: NewWindow^.Flags := NewWindow^.Flags or WFLG_REPORTMOUSE;
WA_RMBTrap: NewWindow^.Flags := NewWindow^.Flags or WFLG_RMBTRAP;
WA_ScreenTitle: ScreenTitle := PChar(TagList^.ti_Data);
WA_SimpleRefresh: NewWindow^.Flags := NewWindow^.Flags or WFLG_SIMPLE_REFRESH;
WA_SizeBBottom: NewWindow^.Flags := NewWindow^.Flags or WFLG_SIZEBBOTTOM;
WA_SizeBRight: NewWindow^.Flags := NewWindow^.Flags or WFLG_SIZEBRIGHT;
WA_SizeGadget: NewWindow^.Flags := NewWindow^.Flags or WFLG_SIZEGADGET;
WA_SmartRefresh: NewWindow^.Flags := NewWindow^.Flags or WFLG_SMART_REFRESH;
WA_SuperBitMap: NewWindow^.BitMap := Pointer(TagList^.ti_Data);
WA_Title: NewWindow^.Title := PChar(TagList^.ti_Data);
WA_Top: NewWindow^.TopEdge := TagList^.ti_Data;
WA_InnerWidth,WA_Width: NewWindow^.Width := TagList^.ti_Data;
end;
TagList := NextTagItem(TagList);
end;
Win := OpenWindow(NewWindow);
if Assigned(Win) and Assigned(ScreenTitle) then
SetWindowTitles(Win, NewWindow^.Title, ScreenTitle);
OpenWindowTagList := Win;
end;
function OpenScreenTagList(NewScreen: PNewScreen; TagList: PTagItem): PScreen;
var
Scr: PScreen;
Ns: TNewScreen;
ILock: LongWord;
STagList: PTagItem;
begin
OpenScreenTagList := nil;
if not Assigned(NewScreen) then
begin
NewScreen := @Ns;
FillChar(Ns, SizeOf(Ns), 0);
Ns.LeftEdge := 0;
Ns.TopEdge := 0;
Ns.Width := 320;
Ns.Height := 200;
Ns.DetailPen := 0;
Ns.BlockPen := 1;
Ns.Depth := 1;
Ns.ViewModes := 0;
end;
// SEarch for Like Workbench
STagList := TagList;
while STagList <> nil do
begin
if STagList^.ti_Tag = SA_LikeWorkbench then
begin
ILock := LockIBase(0);
Scr := PIntuitionBase(_IntuitionBase)^.FirstScreen;
if Assigned(Scr) then
begin
NewScreen^.LeftEdge := Scr^.LeftEdge;
NewScreen^.TopEdge := Scr^.TopEdge;
NewScreen^.Width := Scr^.Width;
NewScreen^.Height := Scr^.Height;
NewScreen^.Font := Scr^.Font;
NewScreen^.Depth := Scr^.BitMap.Depth;
NewScreen^.DetailPen := Scr^.DetailPen;
NewScreen^.BlockPen := Scr^.BlockPen;
NewScreen^.ViewModes := Scr^.ViewPort.Modes;
NewScreen^.SType := Scr^.Flags; // not sure if that is correct
end;
UnlockIBase(ILock);
end;
STagList := NextTagItem(STagList);
end;
// check the other tags
while TagList <> nil do
begin
case TagList^.ti_Tag of
SA_AutoScroll: if TagList^.ti_Data <> 0 then NewScreen^.SType := NewScreen^.SType or AUTOSCROLL else NewScreen^.SType := NewScreen^.SType and not AUTOSCROLL;
SA_Behind: if TagList^.ti_Data <> 0 then NewScreen^.SType := NewScreen^.SType or SCREENBEHIND_F else NewScreen^.SType := NewScreen^.SType and not SCREENBEHIND_F;
SA_BitMap: begin NewScreen^.SType := NewScreen^.SType or CUSTOMBITMAP_F; NewScreen^.CustomBitMap := Pointer(TagList^.ti_Data); end;
SA_BlockPen: NewScreen^.BlockPen := TagList^.ti_Data;
//SA_ColorMapEntries: TODO:
//SA_Colors: todo: after
//SA_Colors32: todo: after
SA_Depth: NewScreen^.Depth := TagList^.ti_Data;
SA_DetailPen: NewScreen^.DetailPen := TagList^.ti_Data;
SA_Font: NewScreen^.Font := Pointer(TagList^.ti_Data);
//SA_FullPalette: TODO:
//SA_Pens: TODO:
SA_Height: NewScreen^.Height := TagList^.ti_Data;
SA_Left: NewScreen^.LeftEdge := TagList^.ti_Data;
//SA_PubName: TODO: hmmm, not really possible
SA_Quiet: if TagList^.ti_Data <> 0 then NewScreen^.SType := NewScreen^.SType or SCREENQUIET_F else NewScreen^.SType := NewScreen^.SType and not SCREENQUIET_F;
SA_ShowTitle: if TagList^.ti_Data <> 0 then NewScreen^.SType := NewScreen^.SType or SHOWTITLE_F else NewScreen^.SType := NewScreen^.SType and not SHOWTITLE_F;
SA_Title: NewScreen^.DefaultTitle := PChar(TagList^.ti_Data);
SA_Top: NewScreen^.TopEdge := TagList^.ti_Data;
SA_Type: NewScreen^.SType := NewScreen^.SType or (TagList^.ti_Data) and not PUBLICSCREEN_F;
SA_DisplayID: NewScreen^.ViewModes := TagList^.ti_Data;
SA_Width: NewScreen^.Width := TagList^.ti_Data;
end;
TagList := NextTagItem(TagList);
end;
Scr := OpenScreen(NewScreen);
OpenScreenTagList := Scr;
end;
function EasyRequestArgs(Window: PWindow; const EasyStruct: PEasyStruct; IDCMPPtr: PLongWord; const Args: Pointer): LongInt;
var
Body, PosText, NegText: TIntuiText;
pFlags, nFlags, Width, Height: LongWord;
pText, NText, s: AnsiString;
Found: Boolean;
i: Integer;
Target: array[0..255] of Char;
Magic: LongWord;
begin
Magic := $16c04e75; // move.b d0,(a3)+ rts
RawDoFmt(easyStruct^.es_TextFormat, args, TProcedure(@Magic), @Target[0]);
with Body do
begin
BackPen := 1;
FrontPen := 2;
DrawMode := JAM1;
IText := @Target[0];
LeftEdge := 17;
TopEdge := 20;
ITextFont := nil;
NextText := nil;
end;
//
NText := '';
PText := '';
if Assigned(easyStruct^.es_GadgetFormat) then
begin
s := string(easyStruct^.es_GadgetFormat);
Found := False;
for i := 1 to Length(s) do
begin
if not Found and (s[i] = '|') then
Found := True
else
begin
if Found then
NText := NText + s[i]
else
PText := PText + s[i];
end;
end;
end;
if (PText = '') and (NText = '') then
PText := 'Ok';
with PosText do
begin
BackPen := 1;
FrontPen := 2;
DrawMode := JAM1;
IText := PChar(PText);
LeftEdge := 7;
TopEdge := 4;
ITextFont := nil;
NextText := nil;
end;
with NegText do
begin
BackPen := 1;
FrontPen := 2;
DrawMode := JAM1;
IText := PChar(NText);
LeftEdge := 7;
TopEdge := 4;
ITextFont := nil;
NextText := nil;
end;
Width := IntuiTextLength(@Body) + 50;
Height := 70;
if idcmpPtr <> nil then
pFlags := idcmpPtr^
else
pFlags := 0;
NFlags := 0;
if AutoRequest(Window, @Body, @PosText, @NegText, pFlags, nFlags, Width, Height) then
EasyRequestArgs := 1
else
EasyRequestArgs := 0;
end;
{$endif}
function OpenScreenTags(newScreen : pNewScreen; tagList : array of PtrUInt) : pScreen;
begin
OpenScreenTags := OpenScreenTagList(newScreen, @tagList);
@ -4250,6 +4602,7 @@ begin
OpenWindowTags := OpenWindowTagList(newWindow, @tagList);
end;
{$if not defined(AMIGA_V1_2_ONLY)}
function NewObject(classPtr : pIClass; classID : pCHAR; Const argv : array of PtrUInt) : POINTER;
begin
NewObject := NewObjectA(classPtr,classID, @argv);
@ -4270,16 +4623,19 @@ begin
SetGadgetAttrs := SetGadgetAttrsA(gadget,window,requester,@argv);
end;
procedure SetWindowPointer(win : pWindow; tags: array of DWord);
begin
SetWindowPointerA(win, @tags);
end;
{$endif}
function EasyRequest(window : pWindow;const easyStruct : pEasyStruct; idcmpPtr : pULONG; args : array of DWord) : LONGINT;
begin
EasyRequest := EasyRequestArgs(window, easystruct, idcmpptr, @args);
end;
procedure SetWindowPointer(win : pWindow; tags: array of DWord);
begin
SetWindowPointerA(win, @tags);
end;
{$if not defined(AMIGA_V1_2_ONLY)}
function INST_DATA (cl: pIClass; o: p_Object): Pointer; inline;
begin
INST_DATA := Pointer(Longint(o) + cl^.cl_InstOffset);
@ -4309,6 +4665,7 @@ function OCLASS (o: Pointer): pIClass; inline;
begin
OCLASS := p_Object(o - sizeof(t_Object))^.o_Class;
end;
{$endif}
function SHIFTITEM (n: smallint): word; inline;
begin
@ -4389,6 +4746,7 @@ begin
LockPubScreen := LockPubScreen(PChar(RawByteString(name)));
end;
{$if not defined(AMIGA_V1_2_ONLY)}
FUNCTION MakeClass(const classID : string;const superClassID : pCHAR;const superClassPtr : pIClass; instanceSize : ULONG; flags : ULONG) : pIClass;
begin
MakeClass := MakeClass(PChar(RawByteString(classID)),superClassID,superClassPtr,instanceSize,flags);
@ -4408,6 +4766,7 @@ FUNCTION NewObjectA(classPtr : pIClass;const classID : string;const tagList : pT
begin
NewObjectA := NewObjectA(classPtr,PChar(RawByteString(classID)),taglist);
end;
{$endif}
PROCEDURE SetDefaultPubScreen(const name : string);
begin
@ -4424,7 +4783,7 @@ begin
UnlockPubScreen(PChar(RawByteString(name)),screen);
end;
{$if not defined(AMIGA_V1_2_ONLY)}
function DoMethodA(Obj: PObject_; Msg: APTR): PtrUInt;
begin
if Assigned(Obj) then
@ -4470,6 +4829,7 @@ begin
arr[2] := 0;
SetSuperAttrsA := DoSuperMethodA(Cl, Obj, @arr);
end;
{$endif}
initialization
IntuitionBase := pIntuitionBase(_IntuitionBase);

48
packages/amunits/src/coreunits/keymap.pas
View File

@ -110,13 +110,58 @@ VAR KeymapBase : pLibrary = nil;
const
KEYMAPNAME : PChar = 'keymap.library';
{$if defined(AMIGA_V1_2_ONLY)}
function MapRawKey(event: PInputEvent; Buffer: PCHAR; Length: LongInt; keyMap: PKeyMap): SmallInt;
{$else}
FUNCTION AskKeyMapDefault : pKeyMap; syscall KeymapBase 036;
FUNCTION MapANSI(thestring : pCHAR location 'a0'; count : LONGINT location 'd0'; buffer : pCHAR location 'a1'; length : LONGINT location 'd1'; keyMap : pKeyMap location 'a2') : LONGINT; syscall KeymapBase 048;
FUNCTION MapRawKey(event : pInputEvent location 'a0'; buffer : pCHAR location 'a1'; length : LONGINT location 'd1'; keyMap : pKeyMap location 'a2') : smallint; syscall KeymapBase 042;
PROCEDURE SetKeyMapDefault(keyMap : pKeyMap location 'a0'); syscall KeymapBase 030;
{$endif}
IMPLEMENTATION
{$if defined(AMIGA_V1_2_ONLY)}
var
ConDev: PDevice = nil;
ConMsgPort: PMsgPort = nil;
ConIOReq: PIORequest = nil;
function RawKeyConvert(Events: PInputEvent location 'a0'; Buffer: PCHAR location 'a1'; Length: LongInt location 'd1'; KeyMap: PKeyMap location 'a2'): LongInt; syscall ConDev 048;
function MapRawKey(event: PInputEvent; Buffer: PCHAR; Length: LongInt; keyMap: PKeyMap): SmallInt;
begin
if not Assigned(ConDev) then
begin
ConMsgPort := CreatePort(nil, 0);
ConIOReq := CreateExtIO(ConMsgPort, SizeOf(TIOStdReq));
OpenDevice('console.device', -1, ConIOReq, 0);
ConDev := ConIOReq^.io_Device;
end;
if Assigned(ConDev) then
MapRawKey := RawKeyConvert(event, Buffer, length, keymap)
else
MapRawKey := 0;
end;
procedure CloseKeyMapConsole;
begin
if Assigned(ConDev) and Assigned(ConIOReq) then
begin
CloseDevice(ConIOReq);
DeleteExtIO(ConIOReq);
end;
ConDev := nil;
ConIOReq := nil;
if Assigned(ConMsgPort) then
DeletePort(ConMsgPort);
ConMsgPort := nil;
end;
{$endif}
const
{ Change VERSION and LIBVERSION to proper values }
VERSION : string[2] = '0';
@ -127,6 +172,9 @@ initialization
finalization
if Assigned(KeymapBase) then
CloseLibrary(KeymapBase);
{$if defined(AMIGA_V1_2_ONLY)}
CloseKeyMapConsole;
{$endif}
END. (* UNIT KEYMAP *)

41
packages/amunits/src/coreunits/utility.pas
View File

@ -339,6 +339,11 @@ Type
var
UtilityBase: pUtilityBase;
{$if defined(AMIGA_V1_2_ONLY)}
function NextTagItem(var Item: PTagItem): PTagItem; inline;
{$else}
function AddNamedObject(nameSpace : pNamedObject location 'a0';obj : pNamedObject location 'a1') : LongBool; syscall _UtilityBase 222;
function AllocateTagItems(num : ULONG location 'd0') : pTagItem; syscall _UtilityBase 066;
function AllocNamedObjectA(const name : STRPTR location 'a0';const TagList : pTagItem location 'a1') : pNamedObject; syscall _UtilityBase 228;
@ -389,6 +394,7 @@ FUNCTION Stricmp(CONST string1 : string; CONST string2 : string) : LONGINT;
FUNCTION Strnicmp(CONST string1 : string; CONST string2 : pCHAR; length : LONGINT) : LONGINT;
FUNCTION Strnicmp(CONST string1 : pCHAR; CONST string2 : string; length : LONGINT) : LONGINT;
FUNCTION Strnicmp(CONST string1 : string; CONST string2 : string; length : LONGINT) : LONGINT;
{$endif}
function TAG_(value: pointer): PtrUInt; overload; inline;
@ -408,6 +414,40 @@ procedure HookEntryPas;
IMPLEMENTATION
{$if defined(AMIGA_V1_2_ONLY)}
{$HINTS OFF}
function NextTagItem(var Item: PTagItem): PTagItem; inline;
begin
NextTagItem := nil;
if Item = nil then
Exit;
//
Inc(Item);
repeat
if Item = nil then
Exit;
case Item^.ti_Tag of
TAG_DONE:
begin
Item := nil;
NextTagItem := nil;
Exit;
end;
TAG_SKIP: Inc(Item, Item^.ti_Data);
TAG_MORE: Item := PTagItem(Item^.ti_Data);
TAG_IGNORE: Inc(Item);
else
begin
NextTagItem := Item;
Exit;
end;
end;
until False;
end;
{$else}
function AllocNamedObject(name : STRPTR; Const argv : array of PtrUInt) : pNamedObject;
begin
AllocNamedObject := AllocNamedObjectA(name,@argv);
@ -453,6 +493,7 @@ FUNCTION Strnicmp(CONST string1 : string; CONST string2 : string; length : LONGI
begin
Strnicmp := Strnicmp(PChar(RawbyteString(string1)),PChar(RawbyteString(string2)),length);
end;
{$endif}
function TAG_(value: pointer): PtrUInt; inline;
begin

5
packages/amunits/src/utilunits/hisoft.pas
View File

@ -88,10 +88,13 @@ function FExpandLock( l : BPTR): String;
var
buffer : array[0..255] of char;
begin
{$if not defined(AMIGA_V1_2_ONLY)}
if l <> 0 then begin
if NameFromLock(l,buffer,255) then FExpandLock := strpas(buffer)
else FExpandLock := '';
end else FExpandLock := '';
end else
{$endif}
FExpandLock := '';
end;
Function CSCPAR(rk : pRemember; s : String) : STRPTR;

5
packages/amunits/src/utilunits/wbargs.pas
View File

@ -59,9 +59,12 @@ begin
if WBMsg <> nil then begin
ProgramName := strpas(WBMsg^.sm_ArgList^[1].wa_Name);
end else begin
{$if not defined(AMIGA_V1_2_ONLY)}
if GetprogramName(buffer,255) then begin
ProgramName := strpas(buffer);
end else begin
end else
{$endif}
begin
ProgramName := '';
end;
end;

6
packages/fcl-process/src/amicommon/pipes.inc
View File

@ -31,8 +31,10 @@ var
fib: TFileInfoBlock;
begin
Result := 0;
{$if not defined(AMIGA_V1_2_ONLY)}
if Boolean(ExamineFH(BPTR(Handle), @fib)) then
Result := fib.fib_size;
{$endif}
end;
function TInputPipeStream.GetPosition: Int64;
@ -50,11 +52,13 @@ var
Filename: array[0..255] of Char;
DeleteIt: Boolean;
begin
{$if not defined(AMIGA_V1_2_ONLY)}
if (FHandle <> UnusedHandle) and (FHandle <> 0) then
begin
DeleteIt := NameFromFH(BPTR(FHandle), @(Filename[0]), 255);
FileClose(FHandle);
if DeleteIt then
AmigaDos.dosDeleteFile(@(Filename[0]));
end;
end;
{$endif}
end;

10
packages/rtl-console/src/amicommon/crt.pp
View File

@ -556,8 +556,10 @@ begin
else
InternalWrite(CSI + '22;3'+ IntToStr(AnsiColors[Color].o) + 'm')
{$else}
{$if not defined(AMIGA_V1_2_ONLY)}
if Pens[Color] < 0 then
Pens[Color] := ObtainBestPen(IntuitionBase^.ActiveScreen^.ViewPort.ColorMap, AnsiColors[color].r shl 24, AnsiColors[color].g shl 24, AnsiColors[color].b shl 24, [TAG_END]);
{$endif}
TheUnit := GetConUnit;
if Assigned(TheUnit) then
begin
@ -595,8 +597,10 @@ begin
else
InternalWrite(CSI + '22;4'+ IntToStr(AnsiColors[Color].o) + 'm')
{$else}
{$if not defined(AMIGA_V1_2_ONLY)}
if Pens[Color] < 0 then
Pens[Color] := ObtainBestPen(IntuitionBase^.ActiveScreen^.ViewPort.ColorMap, AnsiColors[color].r shl 24, AnsiColors[color].g shl 24, AnsiColors[color].b shl 24, [TAG_END]);
{$endif}
TheUnit := GetConUnit;
if Assigned(TheUnit) then
begin
@ -891,7 +895,9 @@ procedure InitCRT;
var
i: Integer;
begin
{$if not defined(AMIGA_V1_2_ONLY)}
SetMode(DosOutput(), 1);
{$endif}
//
AssignCrt(Output);
Rewrite(Output);
@ -913,11 +919,15 @@ procedure FreeCRT;
var
i: Integer;
begin
{$if not defined(AMIGA_V1_2_ONLY)}
SetMode(DosOutput(), 0);
{$endif}
for i := 0 to High(Pens) do
begin
{$if not defined(AMIGA_V1_2_ONLY)}
if Pens[i] >= 0 then
ReleasePen(IntuitionBase^.ActiveScreen^.ViewPort.ColorMap, Pens[i]);
{$endif}
Pens[i] := -1;
end;
// reset colors and delete to end of screen (get rid of old drawings behind the last caret position)

131
packages/rtl-console/src/amicommon/keyboard.pp
View File

@ -22,7 +22,7 @@ interface
message port of the window. This is mainly used in Free Vision to
give up the Task''s timeslice instead of dos.library/Delay() which
blocks the event handling and ruins proper window refreshing among
others
others
input: specify a timeout to wait for an event to arrive. this is the
maximum timeout. the function might return earlier or even
immediately if there's an event. it's specified in milliseconds
@ -31,6 +31,10 @@ interface
function WaitForSystemEvent(millisec: Integer): boolean;
function IBMToANSI(s: RawByteString): RawByteString;
function ANSIToIBM(s: RawByteString): RawByteString;
implementation
uses
@ -69,7 +73,7 @@ end;
var
KeyQueue: TKeyEvent;
type
type
RawCodeEntry = record
rc,n,s,c,a : Word; { raw code, normal, shift, ctrl, alt }
end;
@ -90,7 +94,7 @@ const
(rc: 77; n: $5000; s: $5000; c: $9100; a: $A000; ), // DOWN // shift?
(rc: 78; n: $4D00; s: $4D00; c: $7400; a: $9D00; ), // RIGHT // shift?
(rc: 79; n: $4B00; s: $4B00; c: $7300; a: $9B00; ), // LEFT // shift?
(rc: 80; n: $3B00; s: $5400; c: $5E00; a: $6800; ), // F1
(rc: 81; n: $3C00; s: $5500; c: $5F00; a: $6900; ), // F2
(rc: 82; n: $3D00; s: $5600; c: $6000; a: $6A00; ), // F3
@ -175,6 +179,118 @@ begin
LastShiftState := LastShiftState or $40;
end;
procedure AnsiToIBMChar(var c: Char); inline;
begin
// https://en.wikipedia.org/wiki/Code_page_437
case c of
// line 8
#$C7: c := #128; // C
#$FC: c := #129; // ue
#$E9: c := #130; // e'
#$E2: c := #131; // a^
#$E4: c := #132; // ae
#$E0: c := #133; // a`
#$E5: c := #134; // a°
#$e7: c := #135; // c
#$ea: c := #136; // e^
#$eb: c := #137; // ee
#$E8: c := #138; // e`
#$ef: c := #139; // ie
#$ee: c := #140; // i^
#$ec: c := #141; // i`
#$C4: c := #142; // AE
// line 9
#$C9: c := #144; // Ee
#$e6: c := #145; // a-e
#$c6: c := #146; // A-E
#$F4: c := #147; // o^
#$F6: c := #148; // oe
#$F2: c := #149; // o`
#$FB: c := #150; // u^
#$F9: c := #151; // u`
#$FF: c := #152; // ye
#$D6: c := #153; // OE
#$DC: c := #154; // UE
#$A2: c := #155; // cent
#$A3: c := #156; // Pound
#$A5: c := #157; // Yen
// line A
#$E1: c := #160; // a'
#$ED: c := #161; // i'
#$F3: c := #162; // o'
#$FA: c := #163; // u'
#$F1: c := #164; // n~
#$D1: c := #165; // N~
// line E
#$DF: c := #225; // sz
end;
end;
procedure IBMToAnsiChar(var c: Char); inline;
begin
case c of
// line 8
#128: c := #$C7; // C
#129: c := #$FC; // ue
#130: c := #$E9; // e'
#131: c := #$E2; // a^
#132: c := #$E4; // ae
#133: c := #$E0; // a`
#134: c := #$E5; // a°
#135: c := #$e7; // c
#136: c := #$ea; // e^
#137: c := #$eb; // ee
#138: c := #$E8; // e`
#139: c := #$ef; // ie
#140: c := #$ee; // i^
#141: c := #$ec; // i`
#142: c := #$C4; // AE
// line 9
#144: c := #$C9; // Ee
#145: c := #$e6; // a-e
#146: c := #$c6; // A-E
#147: c := #$F4; // o^
#148: c := #$F6; // oe
#149: c := #$F2; // o`
#150: c := #$FB; // u^
#151: c := #$F9; // u`
#152: c := #$FF; // ye
#153: c := #$D6; // OE
#154: c := #$DC; // UE
#155: c := #$A2; // cent
#156: c := #$A3; // Pound
#157: c := #$A5; // Yen
// line A
#160: c := #$E1; // a'
#161: c := #$ED; // i'
#162: c := #$F3; // o'
#163: c := #$FA; // u'
#164: c := #$F1; // n~
#165: c := #$D1; // N~
// line E
#225: c := #$DF; // sz
end;
end;
function IBMToANSI(s: RawByteString): RawByteString;
var
i: Integer;
begin
for i := 1 to Length(s) do
IBMToAnsiChar(s[i]);
IBMToANSI := s;
end;
function ANSIToIBM(s: RawByteString): RawByteString;
var
i: Integer;
begin
for i := 1 to Length(s) do
AnsiToIBMChar(s[i]);
ANSIToIBM := s;
end;
function SysPollKeyEvent: TKeyEvent;
var
MouseEvent: Boolean; // got a mouseevent -> do not leave cycle
@ -233,7 +349,7 @@ begin
GotActiveWindow;
end;
IDCMP_INACTIVEWINDOW: begin
// force cursor off. we stop getting IntuiTicks when
// force cursor off. we stop getting IntuiTicks when
// the window is inactive, so the blinking stops.
ToggleCursor(true);
GotInactiveWindow;
@ -344,6 +460,7 @@ begin
ie.ie_position.ie_addr := PPointer(IAddr)^;
Buff[0] := #0;
Ret := MapRawKey(@ie, @Buff[0], 1, nil);
AnsiToIBMChar(Buff[0]);
KeyCode := Ord(Buff[0]);
KeySet^.KeyCode := Ord(Buff[0]); // if maprawkey does not work it still is 0
KeySet^.ShiftState := LastShiftState; // shift state set before the case
@ -492,7 +609,7 @@ begin
Res := SysPollKeyEvent;
// remove event from KeyQueue, because we return it here,
// else we get double keys if GetKeyevent is called without a PollKeyEvent called first
KeyQueue := 0;
KeyQueue := 0;
until Res <> 0;
end else
begin
@ -562,7 +679,7 @@ begin
if (recvbits and windowbit) > 0 then
WaitForSystemEvent:=true;
if waitTimerFired then
if waitTimerFired then
begin
AbortIO(PIORequest(waitTimer));
WaitIO(PIORequest(waitTimer));
@ -575,7 +692,7 @@ procedure DoneSystemEventWait;
begin
if assigned(waitTimer) then
begin
if waitTimerFired then
if waitTimerFired then
begin
AbortIO(PIORequest(waitTimer));
WaitIO(PIORequest(waitTimer));

33
packages/rtl-console/src/amicommon/video.pp
View File

@ -129,6 +129,9 @@ begin
SA_Draggable , 1,
SA_Quiet , 1,
SA_LikeWorkbench , 1, // Let OS
{$if defined(AMIGA_V1_2_ONLY)}
SA_Depth , 4,
{$endif}
TAG_END, TAG_END
]);
{$ifdef VIDEODEBUG}
@ -174,9 +177,10 @@ var
videoDefaultFlags: PtrUInt;
begin
videoDefaultFlags:=VIDEO_WFLG_DEFAULTS;
{$if not defined(AMIGA_V1_2_ONLY)}
if GetVar('FPC_VIDEO_SIMPLEREFRESH',@envBuf,sizeof(envBuf),0) > -1 then
videoDefaultFlags:=videoDefaultFlags and not WFLG_SMART_REFRESH;
{$endif}
if FPC_VIDEO_FULLSCREEN then
begin
OS_Screen := GetScreen;
@ -196,7 +200,7 @@ begin
WA_Activate , 1,
WA_Borderless , 1,
WA_BackDrop , 1,
WA_FLAGS , VIDEO_WFLG_DEFAULTS,
WA_FLAGS , VIDEO_WFLG_DEFAULTS or WFLG_BORDERLESS,
WA_IDCMP , VIDEO_IDCMP_DEFAULTS,
TAG_END, TAG_END
]);
@ -266,6 +270,11 @@ begin
{ FIXME/TODO: next to the hardwired selection, there could be some heuristics,
which sets the font size correctly on screens according to the aspect
ratio. (KB) }
{$if defined(AMIGA_V1_2_ONLY)}
VideoFont:=@vgafont8;
VideoFontHeight:=8;
FPC_VIDEO_FULLSCREEN := True;
{$else}
VideoFont:=@vgafont;
VideoFontHeight:=16;
if GetVar('FPC_VIDEO_BUILTINFONT',@envBuf,sizeof(envBuf),0) > -1 then
@ -283,6 +292,7 @@ begin
end;
end;
end;
{$endif}
// fill videobuf and oldvideobuf with different bytes, to allow proper first draw
FillDword(VideoBuf^, VideoBufSize div 4, $1234D3AD);
@ -305,7 +315,7 @@ begin
// borders or titlebar as intended.
ScreenWidth := VideoWindow^.GZZWidth div 8;
ScreenHeight := VideoWindow^.GZZHeight div VideoFontHeight;
ScreenColor := False;
ScreenColor := True;
{$ifdef VIDEODEBUG}
Writeln('DEBUG: Fullscreen - windowed - Width * Heigth = ',ScreenWidth,' * ',ScreenHeight);
@ -326,8 +336,13 @@ begin
for Counter := 0 to 15 do
begin
VideoPens[Counter] := ObtainBestPenA(VideoColorMap,
{$if defined(AMIGA_V1_2_ONLY)}
VideoPens[Counter] := Counter;
SetRGB4(@(PScreen(VideoWindow^.WScreen)^.ViewPort), Counter, vgacolors[counter, 0] shr 4, vgacolors[counter, 1] shr 4, vgacolors[counter, 2] shr 4);
{$else}
VideoPens[Counter] := ObtainBestPenA(VideoColorMap,
vgacolors[counter, 0] shl 24, vgacolors[counter, 1] shl 24, vgacolors[counter, 2] shl 24, nil);
{$endif}
{$ifdef VIDEODEBUG}
If VideoPens[Counter] = -1 then
WriteLn('errr color[',Counter,'] = ', VideoPens[Counter])
@ -437,8 +452,10 @@ begin
FreeBitmap(BufRp^.Bitmap);
BufRp^.Bitmap := nil;
{$endif}
{$if not defined(AMIGA_V1_2_ONLY)}
for Counter := 0 to 15 do
ReleasePen(VideoColorMap, VideoPens[Counter]);
{$endif}
if ((FPC_VIDEO_FULLSCREEN) and (OS_Screen <> nil)) then
begin
CloseScreen(OS_Screen);
@ -821,7 +838,11 @@ end;
function SysGetVideoModeCount: Word;
begin
{$if defined(AMIGA_V1_2_ONLY)}
SysGetVideoModeCount := 1;
{$else}
SysGetVideoModeCount := 2;
{$endif}
end;
function SysGetVideoModeData(Index: Word; var Mode: TVideoMode): Boolean;
@ -832,8 +853,9 @@ begin
0: begin
Mode.Col := 80;
Mode.Row := 25;
Mode.Color := True;
Mode.Color := False;
end;
{$if not defined(AMIGA_V1_2_ONLY)}
1: begin
Screen := LockPubScreen('Workbench');
Mode.Col := Screen^.Width div 8;
@ -841,6 +863,7 @@ begin
UnlockPubScreen('Workbench', Screen);
Mode.Color := False;
end;
{$endif}
end;
SysGetVideoModeData := True;
end;