* initial release

packages/extra/amunits/utilunits/amigautils.pas

@@ -0,0 +1,199 @@
+{
+    This file is part of the Free Pascal run time library.
+
+    A file in Amiga system run time library.
+    Copyright (c) 1998-2002 by Nils Sjoholm
+    member of the Amiga RTL development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+{
+   This is just a temporary unit I made for some of
+   my demos. I hope it will vanish in time.
+
+   [email protected]
+}
+
+unit amigautils;
+
+interface
+
+uses strings;
+
+function ExtractFilePath(FileName: PChar): PChar;
+function FileType(thefile :  PChar): Longint;
+Function PathAndFile(Path,FName : PChar): PChar;
+FUNCTION PathOf(Name : PChar): PChar;
+
+Function LongToStr (I : Longint) : String;
+
+implementation
+
+type
+    pDateStamp = ^tDateStamp;
+    tDateStamp = record
+        ds_Days         : Longint;      { Number of days since Jan. 1, 1978 }
+        ds_Minute       : Longint;      { Number of minutes past midnight }
+        ds_Tick         : Longint;      { Number of ticks past minute }
+    end;
+
+{$PACKRECORDS 4}
+Type
+
+{ Returned by Examine() and ExInfo(), must be on a 4 byte boundary }
+
+    pFileInfoBlock = ^tFileInfoBlock;
+    tFileInfoBlock = record
+        fib_DiskKey      : Longint;
+        fib_DirEntryType : Longint;
+                        { Type of Directory. If < 0, then a plain file.
+                          If > 0 a directory }
+        fib_FileName     : Array [0..107] of Char;
+                        { Null terminated. Max 30 chars used for now }
+        fib_Protection   : Longint;
+                        { bit mask of protection, rwxd are 3-0. }
+        fib_EntryType    : Longint;
+        fib_Size         : Longint;      { Number of bytes in file }
+        fib_NumBlocks    : Longint;      { Number of blocks in file }
+        fib_Date         : tDateStamp;   { Date file last changed }
+        fib_Comment      : Array [0..79] of Char;
+                        { Null terminated comment associated with file }
+        fib_OwnerUID     : Word;
+        fib_OwnerGID     : Word;
+        fib_Reserved     : Array [0..31] of Char;
+    end;
+
+{$PACKRECORDS NORMAL}
+
+FUNCTION Examine(lock : LONGINT; fileInfoBlock : pFileInfoBlock) : BOOLEAN;
+BEGIN
+  ASM
+    MOVE.L  A6,-(A7)
+    MOVE.L  lock,D1
+    MOVE.L  fileInfoBlock,D2
+    MOVEA.L _DOSBase,A6
+    JSR -102(A6)
+    MOVEA.L (A7)+,A6
+    TST.L   D0
+    BEQ.B   @end
+    MOVEQ   #1,D0
+    @end: MOVE.B  D0,@RESULT
+  END;
+END;
+
+FUNCTION Lock(name : pCHAR; type_ : LONGINT) : LONGINT;
+BEGIN
+  ASM
+    MOVE.L  A6,-(A7)
+    MOVE.L  name,D1
+    MOVE.L  type_,D2
+    MOVEA.L _DOSBase,A6
+    JSR -084(A6)
+    MOVEA.L (A7)+,A6
+    MOVE.L  D0,@RESULT
+  END;
+END;
+
+PROCEDURE UnLock(lock : LONGINT);
+BEGIN
+  ASM
+    MOVE.L  A6,-(A7)
+    MOVE.L  lock,D1
+    MOVEA.L _DOSBase,A6
+    JSR -090(A6)
+    MOVEA.L (A7)+,A6
+  END;
+END;
+
+FUNCTION PCharCopy(s: PChar; thepos , len : Longint): PChar;
+VAR
+    dummy : PChar;
+BEGIN
+    getmem(dummy,len+1);
+    dummy := strlcopy(dummy,@s[thepos],len);
+    PCharCopy := dummy;
+END;
+
+
+function ExtractFilePath(FileName: PChar): PChar;
+var
+  I: Longint;
+begin
+  I := strlen(FileName);
+  while (I > 0) and not ((FileName[I] = '/') or (FileName[I] = ':')) do Dec(I);
+  ExtractFilePath := PCharCopy(FileName, 0, I+1);
+end;
+
+function FileType(thefile :  PChar): Longint;
+VAR
+   fib  :  pFileInfoBlock;
+   mylock : Longint;
+   mytype : Longint;
+begin
+   mytype := 0;
+   new(fib);
+   mylock := Lock(thefile, -2);
+   IF mylock <> 0 THEN begin
+       IF Examine(mylock, fib) THEN begin
+           mytype := fib^.fib_DirEntryType;
+           UnLock(mylock);
+       END;
+    END;
+    dispose(fib);
+    FileType := mytype
+END;
+
+Function PathAndFile(Path,FName : PChar): PChar;
+var
+    LastChar : CHAR;
+    Temparray : ARRAY [0..255] OF CHAR;
+    Temp     : PChar;
+BEGIN
+    Temp := @Temparray;
+    if strlen(Path) > 0 then begin
+        strcopy(Temp, Path);
+        LastChar := Temp[Pred(strlen(Temp))];
+        if (LastChar <> '/') and (LastChar <> ':') then
+            strcat(Temp, PChar('/'#0));
+        if strlen(FName) > 0 then
+            strcat(Temp,FName);
+    end;
+    if strlen(Temp) > 0 then begin
+        PathAndFile := PCharCopy(Temp,0,Strlen(Temp));
+    end else begin
+        PathAndFile := nil;
+    end;
+end;
+
+FUNCTION PathOf(Name : PChar): PChar;
+begin
+    PathOf := ExtractFilePath(Name);
+end;
+
+Function LongToStr (I : Longint) : String;
+Var
+    S : String;
+begin
+    Str (I,S);
+    LongToStr:=S;
+end;
+
+
+end.
+
+{
+  $Log$
+  Revision 1.1  2002-11-22 21:34:59  nils
+
+    * initial release
+
+}
+
+  

packages/extra/amunits/utilunits/consoleio.pas

@@ -0,0 +1,410 @@
+{
+    This file is part of the Free Pascal run time library.
+
+    A file in Amiga system run time library.
+    Copyright (c) 1998-2002 by Nils Sjoholm
+    member of the Amiga RTL development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+unit consoleio;
+
+{
+    History:
+    First version of ConsoleIO.
+    This is an translation of consoleio from PCQ Pascal.
+    Just AttachConsole to a window and you have your
+    own console.
+    12 Sep 2000.
+    
+    [email protected]
+
+}
+ 
+interface
+
+uses exec, intuition, console, amigalib, conunit;
+
+TYPE
+    tConsoleSet = record
+		     WritePort,
+		     ReadPort	: pMsgPort;
+		     WriteRequest,
+		     ReadRequest : pIOStdReq;
+		     Window	: pWindow; { not yet used }
+		     Buffer	: Char;
+		 end;
+    pConsoleSet = ^tConsoleSet;
+
+{
+	ConsoleIO.p
+
+	This file implements all the normal console.device stuff for
+dealing with windows.  They are pulled from the ROM Kernel Manual.
+See ConsoleTest.p for an example of using these routines.
+}
+
+Procedure ConPutChar(Request : pIOStdReq; Character : Char);
+Procedure ConWrite(Request : pIOStdReq; Str : pchar; length : longint);
+Procedure ConPutStr(Request : pIOStdReq; Str : pchar);
+Procedure QueueRead(Request : pIOStdReq; Where : pchar);
+Function ConGetChar(consolePort : pMsgPort; Request : pIOStdReq;
+			WhereTo : pchar) : Char;
+Procedure CleanSet(con : pConsoleSet);
+Function AttachConsole(w : pWindow) : pConsoleSet;
+Function ReadKey(con : pConsoleSet) : Char;
+Function KeyPressed(con : pConsoleSet) : Boolean;
+Procedure WriteString(con : pConsoleSet; Str : Pchar);
+Procedure WriteString(con : pConsoleSet; Str : string);
+Function MaxX(con : pConsoleSet) : integer;
+Function MaxY(con : pConsoleSet) : integer;
+Function WhereX(con : pConsoleSet) : integer;
+Function WhereY(con : pConsoleSet) : integer;
+Procedure TextColor(con : pConsoleSet; pen : Byte);
+Procedure TextBackground(con : pConsoleSet; pen : Byte);
+Procedure DetachConsole(con : pConsoleSet);
+Procedure ClrEOL(con : pConsoleSet);
+Procedure ClrScr(con : pConsoleSet);
+Procedure CursOff(con : pConsoleSet);
+Procedure CursOn(con : pConsoleSet);
+Procedure DelLine(con : pConsoleSet);
+Function LongToStr (I : integer) : String;
+Procedure GotoXY(con : pConsoleSet; x,y : integer);
+Procedure InsLine(con : pConsoleSet);
+Procedure OpenConsoleDevice;
+Procedure CloseConsoleDevice;
+
+implementation
+
+Procedure ConPutChar(Request : pIOStdReq; Character : Char);
+var
+    Error : longint;
+begin
+    Request^.io_Command := CMD_WRITE;
+    Request^.io_Data := Addr(Character);
+    Request^.io_Length := 1;
+    Error := DoIO(pIORequest(Request));
+end;
+
+Procedure ConWrite(Request : pIOStdReq; Str : pchar; length : longint);
+var
+   Error : longint;
+begin
+    Request^.io_Command := CMD_WRITE;
+    Request^.io_Data := Str;
+    Request^.io_Length := Length;
+    Error := DoIO(pIORequest(Request));
+end;
+
+Procedure ConPutStr(Request : pIOStdReq; Str : pchar);
+var
+    Error : longint;
+begin
+    Request^.io_Command := CMD_WRITE;
+    Request^.io_Data := Str;
+    Request^.io_Length := -1;
+    Error := DoIO(pIORequest(Request));
+end;
+
+Procedure QueueRead(Request : pIOStdReq; Where : pchar);
+begin
+    Request^.io_Command := CMD_READ;
+    Request^.io_Data := Where;
+    Request^.io_Length := 1;
+    SendIO(pIORequest(Request));
+end;
+
+Function ConGetChar(consolePort : pMsgPort; Request : pIOStdReq;
+			WhereTo : pchar) : Char;
+var
+    Temp : Char;
+    TempMsg : pMessage;
+begin
+    if GetMsg(consolePort) = Nil then begin
+	TempMsg := WaitPort(consolePort);
+	TempMsg := GetMsg(consolePort);
+    end;
+    Temp := WhereTo^;
+    QueueRead(Request, WhereTo);
+    ConGetChar := Temp;
+end;
+
+Procedure CleanSet(con : pConsoleSet);
+begin
+    with con^ do begin
+	if ReadRequest <> Nil then
+	    DeleteStdIO(ReadRequest);
+	if WriteRequest <> Nil then
+	    DeleteStdIO(WriteRequest);
+	if ReadPort <> Nil then
+	    DeletePort(ReadPort);
+	if WritePort <> Nil then
+	    DeletePort(WritePort);
+    end;
+end;
+
+Function AttachConsole(w : pWindow) : pConsoleSet;
+var
+    con : pConsoleSet;
+    Error : Boolean;
+begin
+    New(con);
+    if con = Nil then
+	AttachConsole := Nil;
+    with Con^ do begin
+	WritePort := CreatePort(Nil, 0);
+	Error := WritePort = Nil;
+	ReadPort  := CreatePort(Nil, 0);
+	Error := Error or (ReadPort = Nil);
+	if not Error then begin
+	    WriteRequest := CreateStdIO(WritePort);
+	    Error := Error or (WriteRequest = Nil);
+	    ReadRequest := CreateStdIO(ReadPort);
+	    Error := Error or (ReadRequest = Nil);
+	end;
+	if Error then begin
+	    CleanSet(con);
+	    Dispose(con);
+	    AttachConsole := Nil;
+	end;
+	Window := w;
+    end;
+    with con^.WriteRequest^ do begin
+	io_Data := pointer(w);
+	io_Length := SizeOf(tWindow);
+    end;
+    Error := OpenDevice('console.device', 0,
+			pIORequest(con^.WriteRequest), 0) <> 0;
+    if Error then begin
+	CleanSet(con);
+	Dispose(con);
+	AttachConsole := Nil;
+    end;
+    with con^ do begin
+	ReadRequest^.io_Device := WriteRequest^.io_Device;
+	ReadRequest^.io_Unit := WriteRequest^.io_Unit;
+    end;
+    QueueRead(con^.ReadRequest, Addr(con^.Buffer));
+    AttachConsole := Con;
+end;
+
+Function ReadKey(con : pConsoleSet) : Char;
+begin
+    with con^ do
+	ReadKey := ConGetChar(ReadPort, ReadRequest, Addr(Buffer));
+end;
+
+Function KeyPressed(con : pConsoleSet) : Boolean;
+begin
+    with con^ do
+	KeyPressed := CheckIO(pIORequest(ReadRequest)) <> Nil;
+end;
+
+Procedure WriteString(con : pConsoleSet; Str : Pchar);
+begin
+    ConPutStr(con^.WriteRequest, Str);
+end;
+
+Procedure WriteString(con : pConsoleSet; Str : string);
+var
+    temp : string;
+begin
+    temp := Str;
+    temp := temp + #0;
+    ConPutStr(con^.WriteRequest, @temp[1]);
+end;
+
+Function MaxX(con : pConsoleSet) : integer;
+var
+    CU : pConUnit;
+begin
+    CU := pConUnit(con^.WriteRequest^.io_Unit);
+    MaxX := CU^.cu_XMax;
+end;
+
+Function MaxY(con : pConsoleSet) : integer;
+var
+    CU : pConUnit;
+begin
+    CU := pConUnit(con^.WriteRequest^.io_Unit);
+    MaxY := CU^.cu_YMax;
+end;
+
+Function WhereX(con : pConsoleSet) : integer;
+var
+    CU : pConUnit;
+begin
+    CU := pConUnit(con^.WriteRequest^.io_Unit);
+    WhereX := CU^.cu_XCP;
+end;
+
+Function WhereY(con : pConsoleSet) : integer;
+var
+    CU : pConUnit;
+begin
+    CU := pConUnit(con^.WriteRequest^.io_Unit);
+    WhereY := CU^.cu_YCP;
+end;
+
+Procedure TextColor(con : pConsoleSet; pen : Byte);
+var
+    CU : pConUnit;
+begin
+    CU := pConUnit(con^.WriteRequest^.io_Unit);
+    CU^.cu_FgPen := pen;
+end;
+
+Procedure TextBackground(con : pConsoleSet; pen : Byte);
+var
+    CU : pConUnit;
+begin
+    CU := pConUnit(con^.WriteRequest^.io_Unit);
+    CU^.cu_BgPen := pen;
+end;
+
+Procedure DetachConsole(con : pConsoleSet);
+var
+    TempMsg : pMessage;
+begin
+    with con^ do begin
+	Forbid;
+	if CheckIO(pIORequest(ReadRequest)) = Nil then begin
+	    AbortIO(pIORequest(ReadRequest));
+	    Permit;
+	    TempMsg := WaitPort(ReadPort);
+	    TempMsg := GetMsg(ReadPort);
+	end else
+	    Permit;
+	CloseDevice(pIORequest(WriteRequest));
+    end;
+    CleanSet(con);
+    Dispose(con);
+end;
+
+const
+    CSI = #27 + '[';
+
+Procedure ClrEOL(con : pConsoleSet);
+{
+    Clear to the end of the line
+}
+begin
+    WriteString(con, CSI + 'K');
+end;
+
+Procedure ClrScr(con : pConsoleSet);
+{
+    Clear the text area of the window
+}
+begin
+    WriteString(con, CSI + '1;1H\cJ');
+end;
+
+Procedure CursOff(con : pConsoleSet);
+{
+    Turn the console device's text cursor off
+}
+begin
+    WriteString(con, CSI + '0 p');
+end;
+
+Procedure CursOn(con : pConsoleSet);
+{
+    Turn the text cursor on
+}
+begin
+    WriteString(con, CSI + ' p');
+end;
+
+
+{ Delete the current line, moving all the lines below it  }
+{ up one.  The bottom line is cleared.                    }
+
+Procedure DelLine(con : pConsoleSet);
+begin
+    WriteString(con, CSI + 'M');
+end;
+
+Function LongToStr (I : integer) : String;
+Var
+    S : String;
+begin
+    Str (I,S);
+    LongToStr:=S;
+end;
+
+Procedure GotoXY(con : pConsoleSet; x,y : integer);
+{
+    Move the text cursor to the x,y position.  This routine uses
+    the ANSI CUP command.
+}
+var
+    XRep : string[7];
+    YRep : string[7];
+begin
+    XRep := LongToStr(x);
+    YRep := LongToStr(y);
+    WriteString(con,CSI);
+    WriteString(con,(YRep));
+    WriteString(con,string(';'));
+    WriteString(con,(XRep));
+    WriteString(con,string('H'));
+end;
+
+
+{  Insert a line at the current text position.  The current line and  }
+{  all those below it are moved down one.                             }
+
+Procedure InsLine(con : pConsoleSet);
+begin
+    WriteString(con, CSI + 'L');
+end;
+
+
+
+{
+	These routines just open and close the Console device without
+attaching it to any window.  They update ConsoleBase, and are thus required
+for RawKeyConvert and DeadKeyConvert.
+}
+
+
+
+var
+    
+    ConsoleRequest : tIOStdReq;
+
+Procedure OpenConsoleDevice;
+{
+	This procedure initializes ConsoleDevice, which is required for
+    CDInputHandler and RawKeyConvert.
+}
+var
+    Error : longint;
+begin
+    Error := OpenDevice('console.device', -1, Addr(ConsoleRequest), 0);
+    ConsoleDevice := ConsoleRequest.io_Device;
+end;
+
+Procedure CloseConsoleDevice;
+begin
+    CloseDevice(Addr(ConsoleRequest));
+end;
+
+end.
+
+{
+  $Log$
+  Revision 1.1  2002-11-22 21:34:59  nils
+
+    * initial release
+
+}
+  

packages/extra/amunits/utilunits/doublebuffer.pas

@@ -0,0 +1,242 @@
+{
+    This file is part of the Free Pascal run time library.
+
+    A file in Amiga system run time library.
+    Copyright (c) 1998-2002 by Nils Sjoholm
+    member of the Amiga RTL development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+unit doublebuffer;
+
+
+{
+	DoubleBuffer.p
+
+	These routines provide a very simple double buffer
+	mechanism, mainly by being a bit inflexible with the
+	choice of screens and windows.
+
+	The first thing to do is to set up a NewScreen structure,
+	just like you would do for OpenScreen.  This can be any
+	sort of screen.  Then call OpenDoubleBuffer, which will
+	return a pointer to a full-screen, borderless backdrop
+	window, or Nil if something went wrong.
+
+	If you write into the window's RastPort, it won't be
+	visible until you call SwapBuffers.  By the way, you
+	can always write into the same RastPort - you don't
+	need to reinitialize after SwapBuffers.  All the
+	buffer swapping takes place at the level of BitMaps,
+	so it's transparent to RastPorts.
+
+	When you have finished, call CloseDoubleBuffer.  If you
+	close the window and screen seperately it might crash
+	(I'm not sure), but you'll definitely lose memory.
+
+	One last point: GfxBase must be open before you call
+			OpenDoubleBuffer
+}
+
+{
+     History:
+     This is just an translation of DoubleBuffer.p from PCQ pascal
+     to FPC Pascal.
+     28 Aug 2000.
+     [email protected]
+}
+
+interface
+
+uses exec, intuition, graphics;
+
+{
+    OpenDoubleBuffer opens the Screen described in "ns" without
+    modification, then opens a full screen, borderless backdrop
+    window on it.  That way the window and screen normally share
+    the same BitMap.
+
+    Assuming all that went OK, it allocates an extra BitMap record
+    and the Rasters to go along with it.  Then it points the
+    Window's BitMap, in its RastPort, at the extra bitmap.
+}
+
+Function OpenDoubleBuffer(ns : pNewScreen) : pWindow;
+
+{
+    SwapBuffers swaps the PlanePtrs in the Window's and Screen's
+    BitMap structure's, then calls ScrollVPort on the Screen's
+    ViewPort to get everything going.
+}
+
+Procedure SwapBuffers(w : pWindow);
+
+{
+    CloseDoubleBuffer resets the Window's BitMap to the Screen's
+    BitMap (just in case), closes the Window and Screen, then
+    deallocates the extra BitMap structure and Rasters.
+}
+
+Procedure CloseDoubleBuffer(w : pWindow);
+
+implementation
+
+Function OpenDoubleBuffer(ns : pNewScreen) : pWindow;
+var
+    s : pScreen;
+    w : pWindow;
+    bm : pBitMap;
+    i,j : Integer;
+    nw : tNewWindow;
+    rp : pRastPort;
+begin
+    s := OpenScreen(ns);
+    if s = Nil then
+	OpenDoubleBuffer := Nil;
+
+    ShowTitle(s, 0);
+
+    with s^ do begin
+	nw.LeftEdge := LeftEdge;
+	nw.TopEdge  := TopEdge;
+	nw.Width    := Width;
+	nw.Height   := Height;
+    end;
+
+    with nw do begin
+	DetailPen := 0;
+	BlockPen  := 0;
+	IDCMPFlags := 0;
+	Flags     := WFLG_BACKDROP + WFLG_BORDERLESS + WFLG_ACTIVATE;
+	FirstGadget := Nil;
+	CheckMark := Nil;
+	Title := nil;
+	Screen := s;
+	BitMap := Nil;
+	WType := CUSTOMSCREEN_f;
+    end;
+
+    w := OpenWindow(Addr(nw));
+    if w = Nil then begin
+	CloseScreen(s);
+	OpenDoubleBuffer := Nil;
+    end;
+
+    bm := AllocMem(SizeOf(tBitMap), MEMF_PUBLIC);
+    if bm = Nil then begin
+	CloseWindow(w);
+	CloseScreen(s);
+	OpenDoubleBuffer := Nil;
+    end;
+
+    bm^ := s^.BitMap;
+
+    with bm^ do
+	for i := 0 to Pred(Depth) do begin
+	    Planes[i] := AllocRaster(s^.Width, s^.Height);
+	    if Planes[i] = Nil then begin
+		if i > 0 then
+		    for j := 0 to Pred(i) do
+			FreeRaster(Planes[j], s^.Width, s^.Height);
+		CloseWindow(w);
+		CloseScreen(s);
+		OpenDoubleBuffer := Nil;
+	    end;
+	end;
+
+    rp := w^.RPort;
+    rp^.bitMap := bm;
+
+    OpenDoubleBuffer := w;
+end;
+
+{
+    SwapBuffers swaps the PlanePtrs in the Window's and Screen's
+    BitMap structure's, then calls ScrollVPort on the Screen's
+    ViewPort to get everything going.
+}
+
+Procedure SwapBuffers(w : pWindow);
+var
+    s : pScreen;
+    bm1,
+    bm2 : pBitMap;
+    rp : pRastPort;
+    Temp : Array [0..7] of PLANEPTR;
+begin
+    s := w^.WScreen;
+    rp := w^.RPort;
+    bm1 := rp^.bitMap;
+    bm2 := addr(s^.BitMap);
+    {Temp := bm2^.Planes; 
+    This is really stupid I can't assign
+    bm2^.Planes to Temp, Sigh
+    }
+    Temp[0] := bm2^.Planes[0];
+    Temp[1] := bm2^.Planes[1];
+    Temp[2] := bm2^.Planes[2];
+    Temp[3] := bm2^.Planes[3];
+    Temp[4] := bm2^.Planes[4];
+    Temp[5] := bm2^.Planes[5];
+    Temp[6] := bm2^.Planes[6];
+    Temp[7] := bm2^.Planes[7];
+   
+    bm2^.Planes := bm1^.Planes;
+   { bm1^.Planes := Temp;
+     And this one to, stupid
+   }
+    bm1^.Planes[0] := Temp[0];
+    bm1^.Planes[1] := Temp[1];
+    bm1^.Planes[2] := Temp[2]; 
+    bm1^.Planes[3] := Temp[3];
+    bm1^.Planes[4] := Temp[4];
+    bm1^.Planes[5] := Temp[5];
+    bm1^.Planes[6] := Temp[6];
+    bm1^.Planes[7] := Temp[7];
+
+    ScrollVPort(addr(s^.ViewPort));
+end;
+
+{
+    CloseDoubleBuffer resets the Window's BitMap to the Screen's
+    BitMap (just in case), closes the Window and Screen, then
+    deallocates the extra BitMap structure and Rasters.
+}
+
+Procedure CloseDoubleBuffer(w : pWindow);
+var
+    s : pScreen;
+    bm : pBitMap;
+    i  : longint;
+    rp : pRastPort;
+begin
+    s := w^.WScreen;
+    rp := w^.RPort;
+    bm := rp^.bitMap;
+    rp^.bitMap := addr(s^.BitMap);
+    with bm^ do
+	for i := 0 to Pred(Depth) do
+	    FreeRaster(Planes[i], s^.Width, s^.Height);
+    FreeMem(bm, SizeOf(tBitMap));
+    CloseWindow(w);
+    CloseScreen(s);
+end;
+
+end.
+
+{
+  $Log$
+  Revision 1.1  2002-11-22 21:34:59  nils
+
+    * initial release
+
+}
+
+  

packages/extra/amunits/utilunits/easyasl.pas

@@ -0,0 +1,534 @@
+{
+    This file is part of the Free Pascal run time library.
+
+    A file in Amiga system run time library.
+    Copyright (c) 1998-2002 by Nils Sjoholm
+    member of the Amiga RTL development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+{
+    An easy way to use asl.library, no need to open asl.library,
+    unit asl will open it for you.
+    A lot of overlay functions here.:)
+    
+    One remark, be aware of that GetMultiFiles use linklist for the
+    linked list of files, you can't use your own list with ordinary
+    nodes.
+    26 Oct 1998
+    
+    Removed amigaoverlays, use smartlink instead.
+    05 Nov 2002.
+    
+    [email protected]
+}
+
+unit easyasl;
+
+
+interface
+
+uses exec, asl, utility, amigautils,strings, workbench, linklist;
+
+
+TYPE
+
+    pFPCFontInfo = ^tFPCFontInfo;
+
+    tFPCFontInfo = RECORD
+    nfi_Name       : String[40];
+    nfi_Size       : Word;
+    nfi_Style      : Byte;
+    nfi_Flags      : Byte;
+    nfi_FrontPen   : Byte;
+    nfi_BackPen    : Byte;
+    nfi_DrawMode   : Byte;
+    END;
+
+
+FUNCTION GetFileAsl(title : PChar; VAR path, fname : PChar; thepatt : PChar;win : Pointer): Boolean;
+FUNCTION GetFontAsl(title : PChar;VAR finfo : tFPCFontInfo; win : Pointer): Boolean;
+FUNCTION GetMultiAsl(title : PChar; VAR path : PChar;  VAR Thelist : pList; thepatt : PChar;win : Pointer): Boolean;
+FUNCTION GetPathAsl(title : PChar; VAR path : PChar; win : Pointer): Boolean;
+FUNCTION SaveFileAsl(title : PChar; VAR path, fname : PChar; win : Pointer): Boolean;
+
+
+FUNCTION GetFileAsl(title : PChar; VAR path, fname : PChar; thepatt : String;win : Pointer): Boolean;
+FUNCTION GetFileAsl(title : String; VAR path, fname : PChar; thepatt : PChar;win : Pointer): Boolean;
+FUNCTION GetFileAsl(title : String; VAR path, fname : PChar; thepatt : String;win : Pointer): Boolean;
+FUNCTION GetFontAsl(title : String;VAR finfo : tFPCFontInfo; win : Pointer): Boolean;
+FUNCTION GetMultiAsl(title : PChar; VAR path : PChar;  VAR Thelist : pList; thepatt : String;win : Pointer): Boolean;
+FUNCTION GetMultiAsl(title : String; VAR path : PChar;  VAR Thelist : pList; thepatt : PChar;win : Pointer): Boolean;
+FUNCTION GetMultiAsl(title : String; VAR path : PChar;  VAR Thelist : pList; thepatt : String;win : Pointer): Boolean;
+FUNCTION GetPathAsl(title : String; VAR path : PChar; win : Pointer): Boolean;
+FUNCTION SaveFileAsl(title : String; VAR path, fname : PChar; win : Pointer): Boolean;
+
+
+implementation
+
+
+ uses pastoc;
+
+
+
+FUNCTION GetFileAsl(title : PChar; VAR path, fname : PChar; thepatt : PChar;win : Pointer): Boolean;
+
+VAR
+    fr : pFileRequester;
+    result : Boolean;
+    mytags : ARRAY[0..7] OF tTagItem;
+
+BEGIN
+    result := false;
+    IF strlen(fname) >0 THEN begin
+        mytags[0].ti_Tag  := ASLFR_InitialFile;
+        mytags[0].ti_Data := Longint(fname);
+    END ELSE begin
+        mytags[0].ti_Tag := TAG_IGNORE;
+    END;
+    IF (strlen(path) > 0) and (FileType(path) = 2) THEN begin
+        mytags[1].ti_Tag  := ASLFR_InitialDrawer;
+        mytags[1].ti_Data := Longint(path);
+    END ELSE begin
+        mytags[1].ti_Tag  := ASLFR_InitialDrawer;
+        mytags[1].ti_Data := Longint(pas2c('Sys:'));
+    END;
+    IF win <> nil THEN begin
+        mytags[2].ti_Tag  := ASLFR_Window;
+        mytags[2].ti_Data := Longint(win);
+    END ELSE begin
+        mytags[2].ti_Tag  := TAG_IGNORE;
+    END;
+    IF win <> nil THEN begin
+        mytags[3].ti_Tag  := ASLFR_SleepWindow;
+        mytags[3].ti_Data := Longint(Byte(true));
+    END ELSE begin
+        mytags[3].ti_Tag  := TAG_IGNORE;
+    END;
+    IF title <> nil THEN begin
+        mytags[4].ti_Tag  := ASLFR_TitleText;
+        mytags[4].ti_Data := Longint(title);
+    END ELSE begin
+        mytags[4].ti_Tag  := TAG_IGNORE;
+    END;
+    IF thepatt <> nil THEN begin
+        mytags[5].ti_Tag  := ASLFR_InitialPattern;
+        mytags[5].ti_Data := Longint(thepatt);
+    END ELSE begin
+        mytags[5].ti_Tag  := TAG_IGNORE;
+    END;
+    IF thepatt <> nil THEN begin
+        mytags[6].ti_Tag  := ASLFR_DoPatterns;
+        mytags[6].ti_Data := Longint(Byte(true));
+    END ELSE begin
+        mytags[6].ti_Tag  := TAG_IGNORE;
+    END;
+    mytags[7].ti_Tag  := TAG_DONE;
+
+    fr := AllocAslRequest(ASL_FileRequest,@mytags);
+    IF fr <> NIL THEN BEGIN
+       IF AslRequest(fr,NIL) THEN BEGIN
+          IF (strlen(fr^.rf_Dir) >0) and (strlen(fr^.rf_File) > 0) THEN begin
+             strcopy(path,fr^.rf_Dir);
+             strcopy(fname,fr^.rf_File);
+             result := true;
+          END ELSE begin
+             result := false;
+          end;
+       END ELSE BEGIN
+          result := false;
+       END;
+       FreeAslRequest(fr);
+    END ELSE BEGIN
+       result := false;
+    END;
+    GetFileAsl := result;
+END;
+
+FUNCTION GetFontAsl(title : PChar;VAR finfo : tFPCFontInfo; win : Pointer): Boolean;
+
+VAR
+    fr : pFontRequester;
+    result : boolean;
+    mytags : ARRAY[0..14] OF tTagItem;
+
+BEGIN
+
+    result := false;
+    IF win <> nil THEN begin
+        mytags[0].ti_Tag  := ASLFR_Window;
+        mytags[0].ti_Data := Longint(win);
+    END ELSE begin
+        mytags[0].ti_Tag  := TAG_IGNORE;
+    END;
+    IF win <> nil THEN begin
+        mytags[1].ti_Tag  := ASLFR_SleepWindow;
+        mytags[1].ti_Data := Longint(Byte(true));
+    END ELSE begin
+        mytags[1].ti_Tag  := TAG_IGNORE;
+    END;
+    IF title <> nil THEN begin
+        mytags[2].ti_Tag  := ASLFR_TitleText;
+        mytags[2].ti_Data := Longint(title);
+    END ELSE begin
+        mytags[2].ti_Tag  := TAG_IGNORE;
+    END;
+    IF length(finfo.nfi_Name) > 0 THEN BEGIN
+        mytags[3].ti_Tag  := ASLFO_InitialName;
+        mytags[3].ti_Data := Longint(pas2c(finfo.nfi_Name));
+    END ELSE BEGIN
+        finfo.nfi_Name := 'topaz.font';
+        mytags[3].ti_Tag  := ASLFO_InitialName;
+        mytags[3].ti_Data := Longint(pas2c('topaz.font'));
+    END;
+    IF finfo.nfi_Size <= 4 THEN BEGIN
+        mytags[4].ti_Tag  := ASLFO_InitialSize;
+        mytags[4].ti_Data := 9;
+    END ELSE BEGIN
+        mytags[4].ti_Tag  := ASLFO_InitialSize;
+        mytags[4].ti_Data := Longint(finfo.nfi_Size);
+    END;
+    IF finfo.nfi_Style >= 0 THEN BEGIN
+        mytags[5].ti_Tag  := ASLFO_InitialStyle;
+        mytags[5].ti_Data := Longint(finfo.nfi_Style);
+    END ELSE BEGIN
+        mytags[5].ti_Tag  := TAG_IGNORE;
+    END;
+    IF finfo.nfi_Flags >= 0 THEN BEGIN
+        mytags[6].ti_Tag  := ASLFO_InitialFlags;
+        mytags[6].ti_Data := Longint(finfo.nfi_Flags);
+    END ELSE BEGIN
+        mytags[6].ti_Tag := TAG_IGNORE;
+    END;
+    IF finfo.nfi_BackPen >=0 THEN BEGIN
+        mytags[7].ti_Tag := ASLFO_InitialBackPen;
+        mytags[7].ti_Data := Longint(finfo.nfi_BackPen);
+    END ELSE BEGIN
+        mytags[7].ti_Tag := ASLFO_InitialBackPen;
+        mytags[7].ti_Data := 0;
+    END;
+    IF (finfo.nfi_FrontPen = 0) and (finfo.nfi_BackPen = 0) THEN BEGIN
+        mytags[8].ti_Tag := ASLFO_InitialFrontPen;
+        mytags[8].ti_Data := 1;
+    END ELSE BEGIN
+        mytags[8].ti_Tag := ASLFO_InitialFrontPen;
+        mytags[8].ti_Data := Longint(finfo.nfi_FrontPen);
+    END;
+    IF finfo.nfi_DrawMode >= 0 THEN BEGIN
+        mytags[9].ti_Tag := ASLFO_InitialDrawMode;
+        mytags[9].ti_Data := Longint(finfo.nfi_DrawMode);
+    END ELSE BEGIN
+        mytags[9].ti_Tag := ASLFO_InitialDrawMode;
+        mytags[9].ti_Data := 0;
+    END;
+    mytags[10].ti_Tag := ASLFO_DoFrontPen;
+    mytags[10].ti_Data := Longint(Byte(true));
+    mytags[11].ti_Tag := ASLFO_DoBackPen;
+    mytags[11].ti_Data := Longint(Byte(true));
+    mytags[12].ti_Tag := ASLFO_DoStyle;
+    mytags[12].ti_Data := Longint(Byte(true));
+    mytags[13].ti_Tag := ASLFO_DoDrawMode;
+    mytags[13].ti_Data := Longint(Byte(true));
+    mytags[14].ti_Tag := TAG_DONE;
+
+    fr := AllocAslRequest(ASL_FontRequest,@mytags);
+    IF fr <> NIL THEN BEGIN
+         IF AslRequest(fr,NIL) THEN BEGIN
+              WITH finfo DO BEGIN
+                  nfi_Name := strpas(fr^.fo_Attr.ta_Name);
+                  nfi_Size       := fr^.fo_Attr.ta_YSize;
+                  nfi_Style      := fr^.fo_Attr.ta_Style;
+                  nfi_Flags      := fr^.fo_Attr.ta_Flags;
+                  nfi_FrontPen   := fr^.fo_FrontPen;
+                  nfi_BackPen    := fr^.fo_BackPen;
+                  nfi_DrawMode   := fr^.fo_DrawMode;
+             END;
+             result := true;
+         END ELSE BEGIN
+             result := false;
+         END;
+         FreeAslRequest(fr);
+    END ELSE BEGIN
+        result := false;
+    END;
+    GetFontAsl := result;
+END;
+
+FUNCTION GetMultiAsl(title : PChar; VAR path : PChar;  VAR Thelist : pList; thepatt : PChar;win : Pointer): Boolean;
+
+VAR
+    fr : pFileRequester;
+    result : Boolean;
+    mytags : ARRAY[0..7] OF tTagItem;
+    index : Longint;
+    tempnode : pFPCNode;
+
+BEGIN
+        IF (strlen(path) > 0) and (FileType(path) = 2) THEN begin
+            mytags[0].ti_Tag  := ASLFR_InitialDrawer;
+            mytags[0].ti_Data := Longint(path);
+        END ELSE begin
+            mytags[0].ti_Tag  := ASLFR_InitialDrawer;
+            mytags[0].ti_Data := Longint(pas2c('Sys:'));
+        END;
+        IF win <> nil THEN begin
+            mytags[1].ti_Tag  := ASLFR_Window;
+            mytags[1].ti_Data := Longint(win);
+        END ELSE begin
+            mytags[1].ti_Tag  := TAG_IGNORE;
+        END;
+        IF win <> nil THEN begin
+            mytags[2].ti_Tag  := ASLFR_SleepWindow;
+            mytags[2].ti_Data := Longint(Byte(true));
+        END ELSE begin
+            mytags[2].ti_Tag  := TAG_IGNORE;
+        END;
+        IF title <> nil THEN begin
+            mytags[3].ti_Tag  := ASLFR_TitleText;
+            mytags[3].ti_Data := Longint(title);
+        END ELSE begin
+            mytags[3].ti_Tag  := TAG_IGNORE;
+        END;
+        IF thepatt <> nil THEN begin
+            mytags[4].ti_Tag  := ASLFR_InitialPattern;
+            mytags[4].ti_Data := Longint(thepatt);
+        END ELSE begin
+            mytags[4].ti_Tag  := TAG_IGNORE;
+        END;
+        IF thepatt <> nil THEN begin
+            mytags[5].ti_Tag  := ASLFR_DoPatterns;
+            mytags[5].ti_Data := Longint(Byte(true));
+        END ELSE begin
+            mytags[5].ti_Tag  := TAG_IGNORE;
+        END;
+        mytags[6].ti_Tag := ASLFR_DoMultiSelect;
+        mytags[6].ti_Data := Longint(Byte(true));
+        mytags[7].ti_Tag  := TAG_DONE;
+
+        fr := AllocAslRequest(ASL_FileRequest,@mytags);
+        IF fr <> NIL THEN BEGIN
+             IF AslRequest(fr,NIL) THEN BEGIN
+                 IF (strlen(fr^.rf_Dir) >0) THEN begin
+                    strcopy(path,fr^.rf_Dir);
+                    result := true;
+                    FOR index := 1 to (fr^.rf_NumArgs) do begin
+                        tempnode := AddNewnode(TheList,fr^.rf_ArgList^[index].wa_Name);
+                    end;
+                 END ELSE begin
+                    result := false;
+                 end;
+             END ELSE BEGIN
+                 result := false;
+             END;
+             FreeAslRequest(fr);
+        END ELSE BEGIN
+            result := false;
+        END;
+        GetMultiAsl := result;
+END;
+
+FUNCTION GetPathAsl(title : PChar; VAR path : PChar; win : Pointer): Boolean;
+
+VAR
+    fr : pFileRequester;
+    result : Boolean;
+    mytags : ARRAY[0..5] OF tTagItem;
+
+BEGIN
+    result := false;
+    IF (strlen(path) > 0) and (FileType(path) = 2) THEN begin
+        mytags[0].ti_Tag  := ASLFR_InitialDrawer;
+        mytags[0].ti_Data := Longint(path);
+    END ELSE begin
+        mytags[0].ti_Tag  := ASLFR_InitialDrawer;
+        mytags[0].ti_Data := Longint(pas2c('Sys:'));
+    END;
+    IF win <> nil THEN begin
+        mytags[1].ti_Tag  := ASLFR_Window;
+        mytags[1].ti_Data := Longint(win);
+    END ELSE begin
+        mytags[1].ti_Tag  := TAG_IGNORE;
+    END;
+    IF win <> nil THEN begin
+        mytags[2].ti_Tag  := ASLFR_SleepWindow;
+        mytags[2].ti_Data := Longint(Byte(true));
+    END ELSE begin
+        mytags[2].ti_Tag  := TAG_IGNORE;
+    END;
+    IF title <> nil THEN begin
+        mytags[3].ti_Tag  := ASLFR_TitleText;
+        mytags[3].ti_Data := Longint(title);
+    END ELSE begin
+        mytags[3].ti_Tag  := TAG_IGNORE;
+    END;
+    mytags[4].ti_Tag  := ASLFR_DrawersOnly;
+    mytags[4].ti_Data := Longint(Byte(true));
+    mytags[5].ti_Tag  := TAG_DONE;
+
+    fr := AllocAslRequest(ASL_FileRequest,@mytags);
+    IF fr <> NIL THEN BEGIN
+         IF AslRequest(fr,NIL) THEN BEGIN
+             IF (strlen(fr^.rf_Dir) >0) THEN begin
+                strcopy(path,fr^.rf_Dir);
+                result := true;
+             END ELSE begin
+                result := false;
+             end;
+         END ELSE BEGIN
+             result := false;
+         END;
+         FreeAslRequest(fr);
+    END ELSE BEGIN
+        result := false;
+    END;
+    GetPathAsl := result;
+END;
+
+FUNCTION SaveFileAsl(title : PChar; VAR path, fname : PChar; win : Pointer): Boolean;
+
+VAR
+    fr : pFileRequester;
+    result : Boolean;
+    mytags : ARRAY[0..6] OF tTagItem;
+
+BEGIN
+    result := false;
+    IF strlen(fname) >0 THEN begin
+        mytags[0].ti_Tag  := ASLFR_InitialFile;
+        mytags[0].ti_Data := Longint(fname);
+    END ELSE begin
+        mytags[0].ti_Tag := TAG_IGNORE;
+    END;
+    IF (strlen(path) > 0) and (FileType(path) = 2) THEN begin
+        mytags[1].ti_Tag  := ASLFR_InitialDrawer;
+        mytags[1].ti_Data := Longint(path);
+    END ELSE begin
+        mytags[1].ti_Tag  := ASLFR_InitialDrawer;
+        mytags[1].ti_Data := Longint(pas2c('Sys:'));
+    END;
+    IF win <> nil THEN begin
+        mytags[2].ti_Tag  := ASLFR_Window;
+        mytags[2].ti_Data := Longint(win);
+    END ELSE begin
+        mytags[2].ti_Tag  := TAG_IGNORE;
+    END;
+    IF win <> nil THEN begin
+        mytags[3].ti_Tag  := ASLFR_SleepWindow;
+        mytags[3].ti_Data := Longint(Byte(true));
+    END ELSE begin
+        mytags[3].ti_Tag  := TAG_IGNORE;
+    END;
+    IF title <> nil THEN begin
+        mytags[4].ti_Tag  := ASLFR_TitleText;
+        mytags[4].ti_Data := Longint(title);
+    END ELSE begin
+        mytags[4].ti_Tag  := TAG_IGNORE;
+    END;
+    mytags[5].ti_Tag := ASLFR_DoSaveMode;
+    mytags[5].ti_Data := Longint(Byte(true));
+    mytags[6].ti_Tag  := TAG_DONE;
+
+    fr := AllocAslRequest(ASL_FileRequest,@mytags);
+    IF fr <> NIL THEN BEGIN
+         IF AslRequest(fr,NIL) THEN BEGIN
+             IF (strlen(fr^.rf_Dir) >0) and (strlen(fr^.rf_File) > 0) THEN begin
+                strcopy(path,fr^.rf_Dir);
+                strcopy(fname,fr^.rf_File);
+                result := true;
+             END ELSE begin
+                result := false;
+             end;
+         END ELSE BEGIN
+             result := false;
+         END;
+         FreeAslRequest(fr);
+    END ELSE BEGIN
+        result := false;
+    END;
+    SaveFileAsl := result;
+END;
+
+
+FUNCTION GetFileAsl(title : String; VAR path, fname : PChar; thepatt : PChar;win : Pointer): Boolean;
+begin
+    GetFileAsl := GetFileAsl(pas2c(title),path,fname,thepatt,win);
+end;
+
+FUNCTION GetFileAsl(title : String; VAR path, fname : PChar; thepatt : String;win : Pointer): Boolean;
+begin
+    GetFileAsl := GetFileAsl(pas2c(title),path,fname,pas2c(thepatt),win);
+end;
+
+FUNCTION GetFileAsl(title : PChar; VAR path, fname : PChar; thepatt : String;win : Pointer): Boolean;
+begin
+    GetFileAsl := GetFileAsl(title,path,fname,pas2c(thepatt),win);
+end;
+
+FUNCTION GetFontAsl(title : String;VAR finfo : tFPCFontInfo; win : Pointer): Boolean;
+begin
+    GetFontAsl := GetFontAsl(pas2c(title),finfo,win);
+end;
+
+FUNCTION GetMultiAsl(title : String; VAR path : PChar;  VAR Thelist : pList; thepatt : PChar;win : Pointer): Boolean;
+begin
+    GetMultiAsl := GetMultiAsl(pas2c(title),path,TheList,thepatt,win);
+end;
+
+FUNCTION GetMultiAsl(title : String; VAR path : PChar;  VAR Thelist : pList; thepatt : String;win : Pointer): Boolean;
+begin
+    GetMultiAsl := GetMultiAsl(pas2c(title),path,TheList,pas2c(thepatt),win);
+end;
+
+FUNCTION GetMultiAsl(title : PChar; VAR path : PChar;  VAR Thelist : pList; thepatt : String;win : Pointer): Boolean;
+begin
+    GetMultiAsl := GetMultiAsl(title,path,TheList,pas2c(thepatt),win);
+end;
+
+FUNCTION GetPathAsl(title : String; VAR path : PChar; win : Pointer): Boolean;
+begin
+    GetPathAsl := GetPathAsl(pas2c(title),path,win);
+end;
+
+FUNCTION SaveFileAsl(title : String; VAR path, fname : PChar; win : Pointer): Boolean;
+begin
+    SaveFileAsl := SaveFileAsl(pas2c(title),path,fname,win);
+end;
+
+
+end.
+
+{
+  $Log$
+  Revision 1.1  2002-11-22 21:34:59  nils
+
+    * initial release
+
+}
+
+  
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

packages/extra/amunits/utilunits/hisoft.pas

@@ -0,0 +1,118 @@
+{
+    This file is part of the Free Pascal run time library.
+
+    A file in Amiga system run time library.
+    Copyright (c) 2002 by Nils Sjoholm
+    member of the Amiga RTL development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+ 
+ {
+ 	History:
+	
+	Made this unit to help porting from HS Pascal
+	to fpc. Feel free to add more stuff.
+	
+	09 Nov 2002.
+	
+	[email protected] Nils Sjoholm
+}
+
+unit hisoft;
+
+interface
+
+uses exec, gadtools,pastoc,amigados,intuition;
+
+type
+    ppbyte = pointer;
+
+const
+    NULL = 0;
+    TRUE_ = 1;
+    FALSE_ = 0;
+
+procedure MakeMenu(var mnm: tNewMenu;
+	nmType: byte;
+	nmLabel: string;
+	nmCommKey: string;
+	nmFlags: word;
+	nmMutualExclude: longint;
+	nmUserData: longint); 
+
+function ptrtopas(s : pchar): string;
+function FExpandLock( l : BPTR): String;
+Function CSCPAR(rk : pRemember; s : String) : STRPTR;
+
+implementation
+
+
+(*
+ * A little routine to fill in the members of a NewMenu struct
+ *
+ *)
+procedure MakeMenu(var mnm: tNewMenu;
+	nmType: byte;
+	nmLabel: string;
+	nmCommKey: string;
+	nmFlags: word;
+	nmMutualExclude: longint;
+	nmUserData: longint); 
+begin
+        mnm.nm_Type := nmType;
+        if nmLabel <> '' then
+           mnm.nm_Label := pas2c(nmLabel)
+        else mnm.nm_Label := nil;
+        if nmCommKey <> '' then
+           mnm.nm_CommKey := pas2c(nmCommKey)
+        else mnm.nm_CommKey := nil;
+        mnm.nm_Flags := nmFlags;
+        mnm.nm_MutualExclude := nmMutualExclude;
+        mnm.nm_UserData := pointer(nmUserData);
+end;
+
+function ptrtopas(s : pchar): string;
+begin
+   ptrtopas := strpas(s);
+end;
+
+function FExpandLock( l : BPTR): String;
+var
+   buffer : array[0..255] of char;
+begin
+   if l <> 0 then begin
+      if NameFromLock(l,buffer,255) then FExpandLock := strpas(buffer)
+      else FExpandLock := '';
+   end else FExpandLock := '';
+end;
+
+Function CSCPAR(rk : pRemember; s : String) : STRPTR;
+VAR
+	p : STRPTR;
+	
+begin
+  s := s + #0;
+  p := AllocRemember(rk, length(s), MEMF_CLEAR);
+  if p <> nil then
+  	move(s[1], p^, length(s));
+  CSCPAR := p;
+end;
+
+end.
+
+{
+  $Log$
+  Revision 1.1  2002-11-22 21:34:59  nils
+
+    * initial release
+
+}
+
+  

packages/extra/amunits/utilunits/linklist.pas

@@ -0,0 +1,813 @@
+{
+    This file is part of the Free Pascal run time library.
+
+    A file in Amiga system run time library.
+    Copyright (c) 1998-2002 by Nils Sjoholm
+    member of the Amiga RTL development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+unit linklist;
+
+{
+   A unit for an easy way to use exec linked lists
+   for Amiga. Can also be used for other platforms
+   as it is. I hope.
+   
+   27 Oct 1998.
+   [email protected]
+}
+
+interface
+
+uses
+{$ifdef Amiga}
+   Exec,amigalib,
+{$endif}
+   strings;
+
+{ $define showall}
+
+{$ifndef Amiga}
+type
+
+    pNode = ^tNode;
+    tNode = record
+        ln_Succ: pNode;
+        ln_Pred: pNode;
+        ln_Type: byte;
+        ln_Pri : shortint;
+        ln_Name: pchar;
+        end;
+
+    pList = ^tList;
+    tList = record
+        lh_Head: pNode;
+        lh_Tail: pNode;
+        lh_TailPred: pNode;
+        lh_Type: byte;
+        l_pad: byte;
+        end;
+
+{$endif}
+
+type
+    pFPCNode = ^tFPCNode;
+    tFPCNode = record
+        ln_Succ   : pNode;
+        ln_Pred   : pNode;
+        ln_Type   : Byte;
+        ln_Pri    : Shortint;
+        ln_Name   : PChar;
+{
+   Increase this record if you need more information
+   just add your own to the record. Don't forget to
+   change the functions or add your own functions.
+}
+        ln_Size   : Longint;
+        end;
+
+{$ifndef Amiga}
+procedure NewList (list: pList);
+procedure AddHead(list : pList; node : pNode);
+procedure AddTail(list : pList; node : pNode);
+procedure Insert(list : pList; node, lnode: pNode);
+procedure Remove(node : pNode);
+function RemHead(list : pList): pNode;
+function RemTail(list : pList): pNode;
+{$endif}
+
+FUNCTION AddNewNode(VAR fpclist : pList; Str : PChar): pFPCNode;
+FUNCTION AddNewNode(VAR fpclist : pList; Str : String): pFPCNode;
+PROCEDURE ClearList(VAR fpclist : pList);
+PROCEDURE CreateList(VAR fpclist : pList);
+FUNCTION CopyList(fpclist : pList): pList;
+PROCEDURE DeleteNode(ANode : pFPCNode);
+PROCEDURE DestroyList(VAR fpclist : pList);
+FUNCTION FindNodeData(fpclist : pList; data : PChar): pFPCNode;
+FUNCTION FindNodeData(fpclist : pList; data : String): pFPCNode;
+FUNCTION GetFirstNode(fpclist : pList): pFPCNode;
+FUNCTION GetLastNode(fpclist : pList): pFPCNode;
+FUNCTION GetNextNode( ANode : pFPCNode): pFPCNode;
+FUNCTION GetNodeData(Anode : pFPCNode): PChar;
+FUNCTION GetNodeNumber(fpclist : pList; num : Longint): pFPCNode;
+FUNCTION GetPrevNode( ANode : pFPCNode): pFPCNode;
+FUNCTION InsertNewNode(var fpclist : pList; data : PChar; Anode : pFPCNode): pFPCNode;
+FUNCTION InsertNewNode(var fpclist : pList; data : String; Anode : pFPCNode): pFPCNode;
+PROCEDURE ListToBuffer(fpclist : pList; VAR buf : PChar);
+FUNCTION MergeLists(firstlist , secondlist : pList): pList;
+PROCEDURE MoveNodeBottom(var fpclist: pList; ANode : pFPCNode);
+PROCEDURE MoveNodeDown(VAR fpclist : pList; ANode : pFPCNode);
+PROCEDURE MoveNodeTop(VAR fpclist: pList; ANode : pFPCNode);
+PROCEDURE MoveNodeUp(VAR fpclist : pList; ANode : pFPCNode);
+FUNCTION NodesInList(fpclist :  pList): Longint;
+PROCEDURE PrintList(fpclist : pList);
+PROCEDURE RemoveDupNode( VAR fpclist :  pList);
+PROCEDURE RemoveLastNode(VAR fpclist : pList);
+FUNCTION SizeOfList(fpclist : pList): Longint;
+PROCEDURE SortList(VAR fpclist: pList);
+FUNCTION UpDateNode(ANode : pFPCNode; data : PChar): BOOLEAN;
+FUNCTION UpDateNode(ANode : pFPCNode; data : String): BOOLEAN;
+
+function FileToList(thefile : PChar; var thelist : pList): boolean;
+function FileToList(thefile : String; var thelist : pList): boolean;
+function ListToFile(TheFile : PChar; thelist : pList): Boolean;
+function ListToFile(TheFile : String; thelist : pList): Boolean;
+
+implementation
+
+{$ifndef Amiga}
+procedure NewList (list: pList);
+begin
+    list^.lh_Head     := pNode(@list^.lh_Tail);
+    list^.lh_Tail     := NIL;
+    list^.lh_TailPred := pNode(@list^.lh_Head)
+end;
+
+
+procedure AddHead(list : pList; node : pNode);
+begin
+    node^.ln_Succ := list^.lh_Head;
+    node^.ln_Pred := pNode(@list^.lh_Head);
+    list^.lh_Head^.ln_Pred := node;
+    list^.lh_Head := node;
+end;
+
+procedure AddTail(list : pList; node : pNode);
+begin
+    node^.ln_Succ := pNode(@list^.lh_Tail);
+    node^.ln_Pred := list^.lh_TailPred;
+    list^.lh_TailPred^.ln_Succ := node;
+    list^.lh_TailPred := node;
+end;
+
+procedure Insert(list : pList; node : pNode; lnode: pNode);
+begin
+    {*
+     *  Insert node after lnode.  If lnode = NIL then insert
+     *  at head of list.
+     *}
+
+    if (lnode = NIL) then lnode := pNode(@list^.lh_Head);
+    node^.ln_Pred := lnode;
+    node^.ln_Succ := lnode^.ln_Succ;
+    lnode^.ln_Succ := node;
+    node^.ln_Succ^.ln_Pred := node;
+end;
+
+procedure Remove(node : pNode);
+begin
+    node^.ln_Succ^.ln_Pred := node^.ln_Pred;
+    node^.ln_Pred^.ln_Succ := node^.ln_Succ;
+    node^.ln_Succ := NIL;
+    node^.ln_Pred := NIL;
+end;
+
+function RemHead(list : pList): pNode;
+var
+    node : pNode;
+begin
+    node := list^.lh_Head;
+    if (node^.ln_Succ <> NIL) then begin
+        node^.ln_Succ^.ln_Pred := node^.ln_Pred;
+        node^.ln_Pred^.ln_Succ := node^.ln_Succ;
+        node^.ln_Succ := NIL;
+        node^.ln_Pred := NIL;
+    end else node := NIL;
+    RemHead := node;
+end;
+
+function RemTail(list : pList): pNode;
+var
+    node : pNode;
+begin
+    node := list^.lh_TailPred;
+    if (node^.ln_Pred <> NIL) then Remove(node)
+       else node := NIL;
+    RemTail := node;
+end;
+
+{$endif}
+
+FUNCTION AddNewNode(VAR fpclist : pList; Str : PChar): pFPCNode;
+VAR
+   tempnode : pFPCNode;
+BEGIN
+   New(tempnode);
+   tempnode^.ln_Name := StrAlloc(StrLen(Str)+1);
+   IF tempnode^.ln_Name <>  NIL THEN BEGIN
+      StrCopy(tempnode^.ln_Name,Str);
+      tempnode^.ln_Size := 0;
+      tempnode^.ln_Type := 0;
+      tempnode^.ln_Pri  := 0;
+      AddTail(fpclist,pNode(tempnode));
+      AddNewNode := tempnode;
+   END ELSE BEGIN
+      AddNewNode := NIL;
+   END;
+END;
+
+FUNCTION AddNewNode(VAR fpclist : pList; Str : String): pFPCNode;
+VAR
+   tempnode : pFPCNode;
+BEGIN
+   New(tempnode);
+   tempnode^.ln_Name := StrAlloc(Length(Str)+1);
+   IF tempnode^.ln_Name <>  NIL THEN BEGIN
+      StrPCopy(tempnode^.ln_Name,Str);
+      tempnode^.ln_Size := 0;
+      tempnode^.ln_Type := 0;
+      tempnode^.ln_Pri  := 0;
+      AddTail(fpclist,pNode(tempnode));
+      AddNewNode := tempnode;
+   END ELSE BEGIN
+      AddNewNode := NIL;
+   END;
+END;
+
+PROCEDURE ClearList(VAR fpclist : pList);
+VAR
+   tempnode : pFPCNode;
+   dummy    : pNode;
+BEGIN
+   WHILE fpclist^.lh_Head <> @fpclist^.lh_Tail DO BEGIN
+       tempnode := pFPCNode(fpclist^.lh_Head);
+       if tempnode <> nil then begin
+           if tempnode^.ln_Name <> nil then begin
+              StrDispose(tempnode^.ln_Name);
+           end;
+           dummy := RemHead(fpclist);
+           Dispose(tempnode);
+       end;
+   END;
+END;
+
+FUNCTION CopyList(fpclist : pList): pList;
+VAR
+    templist : pList;
+    tempnode : pFPCNode;
+    i, dummy : Longint;
+    added    : pFPCNode;
+BEGIN
+    CreateList(templist);
+    i := NodesInList(fpclist);
+    tempnode := pFPCNode(fpclist^.lh_Head);
+    FOR dummy := 1 TO i DO BEGIN
+       added := AddNewNode(templist,tempnode^.ln_Name);
+       tempnode := pFPCNode(tempnode^.ln_Succ);
+    END;
+    IF added = NIL THEN BEGIN
+       CopyList := NIL;
+    END ELSE BEGIN
+       CopyList := templist;
+    END;
+END;                        
+
+PROCEDURE CreateList(VAR fpclist : pList);
+BEGIN
+    New(fpclist);
+    NewList(fpclist);
+END;                         
+
+PROCEDURE DeleteNode(ANode : pFPCNode);
+BEGIN
+   IF Assigned(ANode)THEN BEGIN
+       IF Assigned(ANode^.ln_Name)THEN BEGIN
+            StrDispose(ANode^.ln_Name);
+       END;
+       Remove(pNode(ANode));
+       Dispose(ANode);
+   END;
+END;
+
+{ remove all nodes, list is killed }
+PROCEDURE DestroyList(VAR fpclist : pList);
+VAR
+   tempnode : pFPCNode;
+   dummy    : pNode;
+BEGIN
+ WHILE fpclist^.lh_Head <> @fpclist^.lh_Tail DO BEGIN
+       tempnode := pFPCNode(fpclist^.lh_Head);
+       if Assigned(tempnode) then begin
+           if Assigned(tempnode^.ln_Name) then begin
+              {$ifdef showall}
+                  write('releasing ');
+                  writeln(tempnode^.ln_Name);
+              {$endif}
+              StrDispose(tempnode^.ln_Name);
+           end;
+           dummy := RemHead(fpclist);
+           {$ifdef showall}
+              writeln('Disposing node');
+           {$endif}  
+           Dispose(tempnode);
+       end;
+   END;
+   if Assigned(fpclist) then begin
+      {$ifdef showall}
+          writeln('Disposing of list');
+      {$endif} 
+      Dispose(fpclist);
+      fpclist := nil;
+   end; 
+END;                                    
+
+FUNCTION FindNodeData(fpclist : pList; data : PChar): pFPCNode;
+VAR
+    temp : pFPCNode;
+    result : pFPCNode;
+BEGIN
+    result := NIL;
+    IF fpclist^.lh_Head^.ln_Succ <> NIL THEN BEGIN
+        temp := pFPCNode(fpclist^.lh_Head);
+        WHILE (temp^.ln_Succ <> NIL) DO BEGIN
+            IF (StrIComp(temp^.ln_Name,data)=0) THEN BEGIN
+                result := temp;
+                break;
+            END;
+            temp := pFPCNode(temp^.ln_Succ);
+        END;
+    END;
+    FindNodeData := result;
+END;
+
+FUNCTION FindNodeData(fpclist : pList; data : String): pFPCNode;
+VAR
+    temp : pFPCNode;
+    result : pFPCNode;
+    p : PChar;
+BEGIN
+    result := NIL;
+    p := StrAlloc(length(data)+1);
+    StrPCopy(p,data);
+    IF fpclist^.lh_Head^.ln_Succ <> NIL THEN BEGIN
+        temp := pFPCNode(fpclist^.lh_Head);
+        WHILE (temp^.ln_Succ <> NIL) DO BEGIN
+            IF (StrIComp(temp^.ln_Name,p)=0) THEN BEGIN
+                result := temp;
+                break;
+            END;
+            temp := pFPCNode(temp^.ln_Succ);
+        END;
+    END;
+    StrDispose(p);
+    FindNodeData := result;
+END;
+
+FUNCTION GetFirstNode(fpclist : pList): pFPCNode;
+var
+    head : pFPCNode;
+BEGIN
+    head := pFPCNode(fpclist^.lh_Head);
+    if head^.ln_Succ <> nil then begin
+        GetFirstNode := pFPCNode(head);
+    end else GetFirstNode := nil;
+END;
+
+FUNCTION GetLastNode(fpclist : pList): pFPCNode;
+var
+    tail : pFPCNode;
+BEGIN
+    tail := pFPCNode(fpclist^.lh_TailPred);
+    if tail^.ln_Pred <> nil then begin
+        GetLastNode := pFPCNode(tail);
+    end else GetLastNode := nil;
+END;       
+
+FUNCTION GetNextNode( ANode : pFPCNode): pFPCNode;
+var
+    next : pFPCNode;
+BEGIN
+    next := pFPCNode(ANode^.ln_Succ);
+    if next^.ln_Succ <> nil then begin
+       GetNextNode := pFPCNode(next);
+    end else GetNextNode := nil;
+END;   
+
+FUNCTION GetNodeData(Anode : pFPCNode): PChar;
+BEGIN
+   IF ANode <> NIL THEN BEGIN
+       IF ANode^.ln_Name <> NIL THEN BEGIN
+           GetNodeData := ANode^.ln_Name;
+       END ELSE BEGIN
+           GetNodeData := NIL;
+       END;
+   END;
+END;
+
+FUNCTION GetNodeNumber(fpclist : pList; num : Longint): pFPCNode;
+VAR
+   dummy : Longint;
+   tempnode : pFPCNode;
+BEGIN
+    IF num <= NodesInList(fpclist) then begin
+       tempnode := pFPCNode(fpclist^.lh_Head);
+       FOR dummy := 1 TO num DO BEGIN
+          tempnode := pFPCNode(tempnode^.ln_Succ);
+       END;
+       GetNodeNumber := pFPCNode(tempnode);
+    END ELSE BEGIN
+       GetNodeNumber := NIL;
+    END;
+END;                        
+
+FUNCTION GetPrevNode( ANode : pFPCNode): pFPCNode;
+var
+    prev : pFPCNode;
+BEGIN
+    prev := pFPCNode(ANode^.ln_Pred);
+    if prev^.ln_Pred <> nil then begin
+       GetPrevNode := pFPCNode(prev);
+    end else GetPrevNode := nil;
+END;   
+
+FUNCTION InsertNewNode(var fpclist : pList; data : PChar; Anode : pFPCNode): pFPCNode;
+VAR
+    dummy    : pFPCNode;
+BEGIN
+    dummy := AddNewNode(fpclist,data);
+    IF dummy <> NIL THEN BEGIN
+        IF (ANode <> NIL) THEN BEGIN
+            Remove(pNode(dummy));
+{$ifdef Amiga}
+            ExecInsert(fpclist,pNode(dummy),pNode(Anode));
+{$else}
+            Insert(fpclist,pNode(dummy),pNode(Anode));
+{$endif}
+        END;
+        InsertNewNode := dummy;
+    END ELSE begin
+        InsertNewNode := NIL;
+    END;
+END;
+
+FUNCTION InsertNewNode(var fpclist : pList; data : String; Anode : pFPCNode): pFPCNode;
+VAR
+    dummy    : pFPCNode;
+BEGIN
+    dummy := AddNewNode(fpclist,data);
+    IF dummy <> NIL THEN BEGIN
+        IF (ANode <> NIL) THEN BEGIN
+            Remove(pNode(dummy));
+{$ifdef Amiga}
+            ExecInsert(fpclist,pNode(dummy),pNode(Anode));
+{$else}
+            Insert(fpclist,pNode(dummy),pNode(Anode));
+{$endif}
+        END;
+        InsertNewNode := dummy;
+    END ELSE begin
+        InsertNewNode := NIL;
+    END;
+END;
+
+PROCEDURE ListToBuffer(fpclist : pList; VAR buf : PChar);
+VAR
+   i     : Longint;
+   dummy : Longint;
+   tempnode : pFPCNode;
+BEGIN
+   buf[0] := #0;
+   i := NodesInList(fpclist);
+   tempnode := pFPCNode(fpclist^.lh_Head);
+   FOR dummy := 1 TO i DO BEGIN
+      IF tempnode^.ln_Name <> NIL THEN BEGIN
+         strcat(buf,tempnode^.ln_Name);
+         IF dummy < i THEN BEGIN
+            StrCat(buf,PChar(';'#0));
+         END;
+      END;
+      tempnode := pFPCNode(tempnode^.ln_Succ);
+   END;
+END;
+
+FUNCTION MergeLists(firstlist , secondlist : pList): pList;
+VAR
+    templist : pList;
+    tempnode : pFPCNode;
+    i, dummy : Longint;
+    added    : pFPCNode;
+BEGIN
+    CreateList(templist);
+    i := NodesInList(firstlist);
+    tempnode := pFPCNode(firstlist^.lh_Head);
+    FOR dummy := 0 TO i DO BEGIN
+       added := AddNewNode(templist,tempnode^.ln_Name);
+       tempnode := pFPCNode(tempnode^.ln_Succ);
+    END;
+    IF added = NIL THEN BEGIN
+       MergeLists := NIL;
+    END ELSE BEGIN
+       i := NodesInList(secondlist);
+       tempnode := pFPCNode(secondlist^.lh_Head);
+       FOR dummy := 0 TO i DO BEGIN
+          added := AddNewNode(templist,tempnode^.ln_Name);
+          tempnode := pFPCNode(tempnode^.ln_Succ);
+       END;
+       IF added = NIL THEN BEGIN
+          MergeLists := NIL;
+       END ELSE BEGIN
+          MergeLists := templist;
+       END;
+    END;
+END;
+
+{ move a node to the bottom of the list }
+PROCEDURE MoveNodeBottom(var fpclist: pList; ANode : pFPCNode);
+
+BEGIN
+    IF ANode^.ln_Succ <> NIL THEN BEGIN
+        Remove(pNode(ANode));
+        AddTail(fpclist,pNode(ANode));
+    END;
+END;
+
+{ move a node down the list }
+PROCEDURE MoveNodeDown(VAR fpclist : pList; ANode : pFPCNode);
+VAR
+    suc : pFPCNode;
+BEGIN
+    suc := pFPCNode(ANode^.ln_Succ);
+    IF (ANode <> NIL) AND (suc <> NIL) THEN BEGIN
+        Remove(pNode(ANode));
+{$ifdef Amiga}
+        ExecInsert(fpclist,pNode(ANode),pNode(suc));
+{$else}
+        Insert(fpclist,pNode(ANode),pNode(suc));
+{$endif}
+    END;
+END;
+
+{ move a node up to the top of the list }
+PROCEDURE MoveNodeTop(VAR fpclist: pList; ANode : pFPCNode);
+BEGIN
+    IF ANode^.ln_Pred <> NIL THEN BEGIN
+        Remove(pNode(ANode));
+        AddHead(fpclist,pNode(ANode));
+    END;
+END;
+
+{ move a node up the list }
+PROCEDURE MoveNodeUp(VAR fpclist : pList; ANode : pFPCNode);
+VAR
+    prev : pFPCNode;
+BEGIN
+    prev := pFPCNode(Anode^.ln_Pred);
+    IF (ANode <> NIL) AND (prev <> NIL) THEN BEGIN
+        prev := pFPCNode(prev^.ln_Pred);
+        Remove(pNode(ANode));
+{$ifdef Amiga}
+        ExecInsert(fpclist,pNode(ANode),pNode(prev));
+{$else}
+        Insert(fpclist,pNode(ANode),pNode(prev));
+{$endif}
+    END;
+END;
+
+FUNCTION NodesInList(fpclist :  pList): Longint;
+VAR
+   tempnode : pFPCNode;
+   i        : Longint;
+BEGIN
+    i := 0;
+    tempnode := pFPCNode(fpclist^.lh_Head);
+    WHILE tempnode^.ln_Succ <> NIL DO BEGIN
+        tempnode := pFPCNode(tempnode^.ln_Succ);
+        INC(i);
+    END;
+    NodesInList := i;
+END;                    
+
+PROCEDURE PrintList(fpclist : pList);
+VAR
+   i     : Longint;
+   dummy : Longint;
+   tempnode : pFPCNode;
+BEGIN
+
+   i := NodesInList(fpclist);
+
+   tempnode := pFPCNode(fpclist^.lh_Head);
+   FOR dummy := 1 TO i DO BEGIN
+       IF tempnode^.ln_Name <> NIL THEN BEGIN
+          WriteLN(tempnode^.ln_Name);
+       END;
+       tempnode := pFPCNode(tempnode^.ln_Succ);
+   END;
+END;                        
+
+PROCEDURE RemoveDupNode( VAR fpclist :  pList);
+VAR
+   tempnode : pFPCNode;
+   nextnode : pFPCNode;
+BEGIN
+    tempnode := pFPCNode(fpclist^.lh_Head);
+
+    WHILE tempnode^.ln_Succ <> NIL DO BEGIN
+         nextnode := pFPCNode(tempnode^.ln_Succ);
+        IF (StrIComp(tempnode^.ln_Name,nextnode^.ln_Name)=0) THEN BEGIN
+            DeleteNode(tempnode);
+        END;
+        tempnode := nextnode;
+    END;
+END;
+
+PROCEDURE RemoveLastNode(VAR fpclist : pList);
+VAR
+   tempnode : pFPCNode;
+   dummy    : pNode;
+BEGIN
+   tempnode := pFPCNode(fpclist^.lh_TailPred);
+   if tempnode^.ln_Name <> nil then begin
+      StrDispose(tempnode^.ln_Name);
+   end;
+   dummy := RemTail(fpclist);
+   Dispose(tempnode);
+END;                       
+
+{ get the total size allocated by list }
+{ size is WITH ';' between the strings }
+FUNCTION SizeOfList(fpclist : pList): Longint;
+VAR
+   i     : Longint;
+   dummy : Longint;
+   tempnode : pFPCNode;
+   tsize    : Longint;
+BEGIN
+   tsize := 0;
+   i := NodesInList(fpclist);
+
+    tempnode := pFPCNode(fpclist^.lh_Head);
+    FOR dummy := 1 TO i DO BEGIN
+        IF tempnode^.ln_Name <> NIL THEN BEGIN
+            tsize := tsize + (StrLen(tempnode^.ln_Name)+1)
+        END;
+        tempnode := pFPCNode(tempnode^.ln_Succ);
+    END;
+    SizeOfList := tsize;
+END;
+
+{ sort the list using a bubble sort }
+PROCEDURE SortList(VAR fpclist: pList);
+
+VAR
+    notfinished : BOOLEAN;
+    first, second : pFPCNode;
+    n,i : Longint;
+
+BEGIN
+    IF fpclist^.lh_Head^.ln_Succ <> NIL THEN BEGIN
+        notfinished := True;
+        i := NodesInList(fpclist);
+        WHILE (notfinished) DO BEGIN
+            notfinished := FALSE;
+            first := pFPCNode(fpclist^.lh_Head);
+            IF first <> NIL THEN BEGIN
+                n := 1;
+                second := pFPCNode(first^.ln_Succ);
+                WHILE n <> i DO BEGIN
+                    n := n + 1;
+                    IF (StrIComp(first^.ln_Name,second^.ln_Name)>0) THEN BEGIN
+                        Remove(pNode(first));
+{$ifdef Amiga}
+                        ExecInsert(fpclist,pNode(first),pNode(second));
+{$else}
+                        Insert(fpclist,pNode(first),pNode(second));
+{$endif}
+                        notfinished := True;
+                    END ELSE
+                        first := second;
+                    second := pFPCNode(first^.ln_Succ);
+                END;
+            END;
+        END;
+    END;
+END;
+
+FUNCTION UpDateNode(ANode : pFPCNode; data : PChar): BOOLEAN;
+VAR
+   result : BOOLEAN;
+BEGIN
+    IF ANode^.ln_Succ <> NIL THEN BEGIN
+        IF ANode^.ln_Name <> NIL THEN BEGIN
+            StrDispose(ANode^.ln_Name);
+            ANode^.ln_Name := StrAlloc(StrLen(data)+1);
+            IF ANode^.ln_Name <> NIL THEN BEGIN
+                StrCopy(ANode^.ln_Name,data);
+                result := True;
+            END ELSE BEGIN
+                result := FALSE;
+            END;
+         END;
+     END;
+     UpDateNode := result;
+END;
+
+FUNCTION UpDateNode(ANode : pFPCNode; data : String): BOOLEAN;
+VAR
+   result : BOOLEAN;
+BEGIN
+    IF ANode^.ln_Succ <> NIL THEN BEGIN
+        IF ANode^.ln_Name <> NIL THEN BEGIN
+            StrDispose(ANode^.ln_Name);
+            ANode^.ln_Name := StrAlloc(Length(data)+1);
+            IF ANode^.ln_Name <> NIL THEN BEGIN
+                StrPCopy(ANode^.ln_Name,data);
+                result := True;
+            END ELSE BEGIN
+                result := FALSE;
+            END;
+         END;
+     END;
+     UpDateNode := result;
+END;
+
+function FileToList(thefile : PChar; var thelist : pList): boolean;
+begin
+    FileToList := FileToList(strpas(thefile), thelist);
+end;
+
+function FileToList(thefile : String; var thelist : pList): boolean;
+var
+   Inf : Text;
+   tempnode : pFPCNode;
+   buffer : PChar;
+   buf : Array [0..500] of Char;
+begin
+   buffer := @buf;
+   Assign(Inf, thefile);
+   {$I-}
+   Reset(Inf);
+   {$I+}
+   if IOResult = 0 then begin
+      while not eof(Inf) do begin
+      { I don't want end of lines here (for use with amiga listviews)
+        just change this if you need newline characters.
+      }
+         Read(Inf, buffer);
+         tempnode := AddNewNode(thelist,buffer);
+         Readln(inf, buffer);
+      end;
+      CLose(Inf);
+      FileToList := true;
+   end else FileToList := false;
+end;
+
+function ListToFile(TheFile : PChar; thelist : pList): Boolean;
+begin
+    ListToFile := ListToFile(strpas(TheFile), thelist);
+end;
+
+function ListToFile(TheFile : String; thelist : pList): Boolean;
+VAR
+    Out      : Text;
+    i        : Longint;
+    dummy    : Longint;
+    tempnode : pFPCNode;
+begin
+    Assign(Out, TheFile);
+    {$I-}
+    Rewrite(Out);
+    {$I+}
+    if IOResult = 0 then begin
+       i := NodesInList(thelist);
+       IF i > 0 THEN BEGIN
+          tempnode := pFPCNode(thelist^.lh_Head);
+          FOR dummy := 1 TO i DO BEGIN
+             IF tempnode^.ln_Name <> NIL THEN BEGIN
+                {
+                  Have to check the strlen here, if it's an
+                  empty pchar fpc will write out a #0
+                }
+                if strlen(tempnode^.ln_Name) > 0 then
+                   WriteLN(Out,tempnode^.ln_Name)
+                else writeln(Out);
+             END;
+             tempnode := pFPCNode(tempnode^.ln_Succ);
+          END;
+        END;
+        Close(Out);
+        ListToFile := True;
+    END Else ListToFile := False;
+END;
+
+
+end.
+
+{
+  $Log$
+  Revision 1.1  2002-11-22 21:34:59  nils
+
+    * initial release
+
+}
+
+  
+

packages/extra/amunits/utilunits/longarray.pas

@@ -0,0 +1,74 @@
+{
+    This file is part of the Free Pascal run time library.
+
+    A file in Amiga system run time library.
+    Copyright (c) 1998-2002 by Nils Sjoholm
+    member of the Amiga RTL development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+{
+    History:
+    
+    A simple unit that helps to build array of longint.
+    Uses array of const so don't forget to use 
+    $mode objfpc.
+
+    05 Nov 2002.
+
+    [email protected]
+}
+
+unit longarray;
+
+{$mode objfpc}
+
+interface
+
+function readinlongs(const args : array of const): pointer;
+
+implementation
+
+uses pastoc;
+
+var
+  argarray : array [0..20] of longint;
+
+function readinlongs(const args : array of const): pointer;
+var
+   i : longint;
+
+begin
+
+    for i := 0 to High(args) do begin
+        case args[i].vtype of
+	    vtinteger : argarray[i] := longint(args[i].vinteger);
+	    vtpchar   : argarray[i] := longint(args[i].vpchar);
+	    vtchar    : argarray[i] := longint(args[i].vchar);
+	    vtpointer : argarray[i] := longint(args[i].vpointer);
+	    vtstring  : argarray[i] := longint(pas2c(args[i].vstring^));
+	    vtboolean : argarray[i] := longint(byte(args[i].vboolean));
+        end;
+    end;
+    readinlongs := @argarray;
+end;
+
+end.
+
+{
+  $Log$
+  Revision 1.1  2002-11-22 21:34:59  nils
+
+    * initial release
+
+}
+
+  
+

packages/extra/amunits/utilunits/msgbox.pas

@@ -0,0 +1,81 @@
+{
+    This file is part of the Free Pascal run time library.
+
+    A file in Amiga system run time library.
+    Copyright (c) 1998-2002 by Nils Sjoholm
+    member of the Amiga RTL development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+unit MsgBox;
+
+interface
+
+
+
+FUNCTION MessageBox(tit,txt,gad:string) : LONGint;
+function MessageBox(tit,txt,gad:pchar):longint;
+
+implementation
+
+uses pastoc;
+type
+ pEasyStruct = ^tEasyStruct;
+   tEasyStruct = record
+    es_StructSize   : longint;  { should be sizeof (struct EasyStruct )}
+    es_Flags        : longint;  { should be 0 for now                  }
+    es_Title        : pchar;   { title of requester window            }
+    es_TextFormat   : pchar;   { 'printf' style formatting string     }
+    es_GadgetFormat : pchar;   { 'printf' style formatting string   }
+   END;
+
+FUNCTION EasyRequestArgs(window : pointer; easyStruct : pEasyStruct; idcmpPtr : longint; args : POINTER) : LONGINT;
+BEGIN
+  ASM
+    MOVE.L  A6,-(A7)
+    MOVEA.L window,A0
+    MOVEA.L easyStruct,A1
+    MOVEA.L idcmpPtr,A2
+    MOVEA.L args,A3
+    MOVEA.L _IntuitionBase,A6
+    JSR -588(A6)
+    MOVEA.L (A7)+,A6
+    MOVE.L  D0,@RESULT
+  END;
+END;
+
+FUNCTION MessageBox(tit,txt,gad:string) : LONGint;
+begin
+    MessageBox := MessageBox(pas2c(tit),pas2c(txt),pas2c(gad));
+end;
+
+FUNCTION MessageBox(tit,txt,gad:pchar) : LONGint;
+VAR
+  MyStruct : tEasyStruct;
+BEGIN
+ MyStruct.es_StructSize:=SizeOf(tEasyStruct);
+ MyStruct.es_Flags:=0;
+ MyStruct.es_Title:=(tit);
+ MyStruct.es_TextFormat:=(txt);
+ MyStruct.es_GadgetFormat:=(gad);
+ MessageBox := EasyRequestArgs(nil,@MyStruct,0,NIL);
+END;
+
+end.
+
+{
+  $Log$
+  Revision 1.1  2002-11-22 21:34:59  nils
+
+    * initial release
+
+}
+
+  

packages/extra/amunits/utilunits/pastoc.pas

@@ -0,0 +1,128 @@
+{
+    This file is part of the Free Pascal run time library.
+
+    A file in Amiga system run time library.
+    Copyright (c) 2000 by Nils Sjoholm
+    member of the Amiga RTL development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+unit PasToC;
+
+
+interface
+
+function Pas2C( s : String): PChar;
+
+implementation
+
+const
+   MEMF_ANY      = %000000000000000000000000;   { * Any type of memory will do * }
+   MEMF_PUBLIC   = %000000000000000000000001;
+
+   MEMF_CLEAR    = %000000010000000000000000;
+
+Type
+
+    ULONG = Longint;
+
+    pRemember = ^tRemember;
+    tRemember = record
+        NextRemember    : pRemember;
+        RememberSize    : ULONG;
+        Memory          : Pointer;
+    end;
+
+var
+    myrememberkey : pRemember;
+    remember_exit : pointer;
+
+FUNCTION fpcAllocRemember(VAR rememberKey : pRemember; size : ULONG; flags : ULONG) : POINTER;
+BEGIN
+  ASM
+    MOVE.L  A6,-(A7)
+    MOVEA.L rememberKey,A0
+    MOVE.L  size,D0
+    MOVE.L  flags,D1
+    MOVEA.L _IntuitionBase,A6
+    JSR -396(A6)
+    MOVEA.L (A7)+,A6
+    MOVE.L  D0,@RESULT
+  END;
+END;
+
+PROCEDURE fpcFreeRemember(VAR rememberKey : pRemember; reallyForget : LONGINT);
+BEGIN
+  ASM
+    MOVE.L  A6,-(A7)
+    MOVEA.L rememberKey,A0
+    MOVE.L  reallyForget,D0
+    MOVEA.L _IntuitionBase,A6
+    JSR -408(A6)
+    MOVEA.L (A7)+,A6
+  END;
+END;
+
+Function StringPcharCopy(Dest: PChar; Source: String):PChar;
+var
+   counter : byte;
+Begin
+   counter := 0;
+  { if empty pascal string  }
+  { then setup and exit now }
+  if Source = '' then
+  Begin
+    Dest[0] := #0;
+    StringPCharCopy := Dest;
+    exit;
+  end;
+  for counter:=1 to length(Source) do
+  begin
+    Dest[counter-1] := Source[counter];
+  end;
+  { terminate the string }
+  Dest[counter] := #0;
+  StringPcharCopy:=Dest;
+end;
+
+function Pas2C(s : string): PChar;
+var
+    themem : Pointer;
+begin
+    themem := fpcAllocRemember(myrememberkey,length(s)+1, MEMF_CLEAR or MEMF_PUBLIC);
+    if themem = nil then begin
+        writeln('Can''t allocate memory for string');
+        halt(20);
+    end else begin
+        StringPCharCopy(themem,s);
+        Pas2C := themem;
+    end;
+end;
+
+procedure ReleasePasToC;
+begin
+    ExitProc := remember_exit;
+    fpcFreeRemember(myrememberkey,1);
+end;
+
+begin
+    myrememberkey := nil;
+    remember_exit := ExitProc;
+    ExitProc := @ReleasePasToC;
+end.
+
+{
+  $Log$
+  Revision 1.1  2002-11-22 21:34:59  nils
+
+    * initial release
+
+}
+
+  

packages/extra/amunits/utilunits/pcq.pas

@@ -0,0 +1,443 @@
+
+unit pcq;
+
+{
+
+     A unit to help port program from pcq pascal.
+
+     These are some of the common C pchar functions.
+
+     Changed a few of the functions.
+
+     ToUpper,
+     ToLower,
+     strnieq,
+     strieq,
+     strnieq,
+     stricmp
+     and strnicmp
+
+     They all use the utility.library for the checking or
+     the conversion. The utility.library is opened by all
+     programs as of version 1.3 of PCQ, so you don't need
+     to do that.
+
+     THIS IS CHANGED!
+     Looks like the strcompare functions in utility and locale
+     is buggy so I have redone this functions to use an
+     internal strcompare instead.
+
+
+     Nils Sjoholm < [email protected]
+
+}
+
+interface
+
+uses exec,strings;
+
+function CheckBreak: boolean;
+
+Function isupper(c : Char) : Boolean;
+{
+    Returns True if the character is in A..Z
+}
+
+Function islower(c : Char) : Boolean;   
+{
+    Returns True if the character is in a..z
+}
+
+Function isalpha(c : Char) : Boolean;    
+{
+    Returns True if the character is in A..Z or a..z
+}
+
+Function isdigit(c : Char) : Boolean;    
+{
+    Returns True if the character is in 0..9
+}
+
+Function isalnum(c : Char) : Boolean;    
+{
+    Returns True if isalpha or isdigit is true
+}
+
+Function isspace(c : Char) : Boolean;  
+{
+    Returns true if the character is "white space", like a space,
+    form feed, line feed, carraige return, tab, whatever.
+}
+
+Function toupper(c : Char) : Char;   
+{
+    If the character is in a..z, the function returns the capital.
+    Otherwise it returns c. Not true, this function use the utility.library
+    to make the conversion.
+}
+
+Function tolower(c : Char) : Char;   
+{
+    If c is in A..Z, the function returns the lower case letter.
+    Otherwise it returns c. Not true this function use the utility.library
+    to make the conversion.
+}
+
+function lowercase(c : char) : char;
+{
+   If the character is in a..z, the function returns the capital.
+   Otherwise it returns c. Not true, this function use the utility.library
+   to make the conversion.
+}
+
+function lowercase(c : pchar): pchar;
+{
+   Will turn the pchar till lowercase.
+}
+
+function uppercase(c : char): char;
+{
+    If the character is in a..z, the function returns the capital.
+    Otherwise it returns c. Not true, this function use the utility.library
+    to make the conversion.
+}
+
+function uppercase(c: pchar): pchar;
+{
+    Will turn the pchar till capital letters.
+}
+
+Function streq(s1, s2 : pchar) : Boolean;    
+{
+    Returns True if s1 and s2 are the same.
+}
+
+Function strneq(s1, s2 : pchar; n : longint) : Boolean;    
+{
+    Returns True if the first n characters of s1 and s2 are identical.
+}
+
+Function strieq(s1, s2 : pchar) : Boolean;    
+{
+    The same as streq(), but is case insensitive.
+}
+
+Function strnieq(s1, s2 : pchar; n : longint) : Boolean;    
+{
+    The same as strneq(), but case insensitive.
+}
+
+Function strcmp(s1, s2 : pchar) : longint;    
+{
+    Returns an longint < 0 if s1 < s2, zero if they are equal, and > 0
+    if s1 > s2.  
+}
+
+Function stricmp(s1, s2 : pchar) : longint;
+{
+    The same as strcmp, but not case sensitive
+}
+
+Function strncmp(s1, s2 : pchar; n : longint) : longint;   
+{
+    Same as strcmp(), but only considers the first n characters.
+}
+
+Function strnicmp(s1, s2 : pchar; n : longint) : longint;    
+{
+    Same as strncmp, but not case sensitive
+}
+
+Procedure strcpy(s1, s2 : pchar);   
+{
+    Copies s2 into s1, appending a trailing zero.  This is the same
+    as C, but opposite from 1.0.  
+}
+Procedure strncpy(s1, s2 : pchar; n : integer);    
+{
+    Copies s2 into s1, with a maximum of n characters.  Appends a
+    trailing zero.
+}
+
+Procedure strncat(s1, s2 : pchar; n : integer);   
+{
+    Appends at most n characters from s2 onto s1.
+}
+
+Function strdup(s : pchar) : pchar;   
+{
+    This allocates a copy of the pchar 's', and returns a ptr
+}
+
+Function strpos(s1 : pchar; c : Char) : longint;   
+{
+    Return the position, starting at zero, of the first (leftmost)
+    occurance of c in s1.  If there is no c, it returns -1.
+}
+
+Function strrpos(s1 : pchar; c : Char) : longint;   
+{
+    Returns the longint position of the right-most occurance of c in s1.
+    If c is not in s1, it returns -1.
+}
+
+Function AllocString(l : longint) : pchar;    
+{
+    Allocates l bytes, and returns a pointer to the allocated memory.
+This memory is allocated through the new() function, so it will be returned
+to the system at the end of your program.  Note that the proper amount of RAM
+to allocate is strlen(s) + 1.
+}
+
+Procedure FreeString(s : pchar);   
+{
+    This returns memory allocated by AllocString to the system.  Since
+the Amiga is a multitasking computer, you should always return memory you
+don't need to the system.
+}
+
+implementation
+
+const
+     SIGBREAKF_CTRL_C = $1000;
+
+function CheckBreak: boolean;
+begin
+   { check for Ctrl-C break by user }
+   if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then Begin
+       SetSignal(0,SIGBREAKF_CTRL_C);
+       CheckBreak := true;
+   end else CheckBreak := false;
+end;
+
+Function isupper(c : Char) : Boolean;
+begin
+     if ((ord(c) >= 192) and (ord(c) <= 223)) or ((c >= 'A') and (c <= 'Z'))
+         then isupper := true
+     else isupper := false;
+end;
+
+Function islower(c : Char) : Boolean;   
+begin
+     if ((ord(c) >= 224) and (ord(c) <= 254)) or ((c >= 'a') and (c <= 'z'))
+         then islower := true
+     else islower := false;
+end;
+
+Function isalpha(c : Char) : Boolean;    
+begin
+     if ((ord(c) >= 192) and (ord(c) <= 223)) or ((c >= 'A') and (c <= 'Z'))
+     or ((ord(c) >= 224) and (ord(c) <= 254)) or ((c >= 'a') and (c <= 'z'))
+         then isalpha := true
+     else isalpha := false;
+end;
+
+Function isdigit(c : Char) : Boolean;    
+begin
+     if c in ['0'..'9'] then isdigit := true
+     else isdigit := false;
+end;
+
+Function isalnum(c : Char) : Boolean;    
+begin
+     if isalpha(c) or isdigit(c) then isalnum := true
+     else isalnum := false;
+end;
+
+Function isspace(c : Char) : Boolean;  
+begin
+     if c in [#9..#13,#32] then isspace := true
+     else isspace := false;
+end;
+
+Function toupper(c : Char) : Char;   
+begin
+    if ((ord(c) >= 224) and (ord(c) <= 254)) or ((c >= 'a') and (c <= 'z'))
+        then c := char(ord(c)-32);
+    toupper := c;
+end;
+
+Function tolower(c : Char) : Char;
+begin
+    if ((ord(c) >= 192) and (ord(c) <= 223)) or ((c >= 'A') and (c <= 'Z'))
+        then c := char(ord(c)+32);
+    tolower := c;
+end;
+
+function lowercase(c : char) : char;
+begin
+    lowercase := tolower(c);
+end;
+
+function lowercase(c : pchar): pchar;
+var
+    i : longint;
+begin
+    i := 0;
+    while c[i] <> #0 do begin
+        c[i] := tolower(c[i]);
+        i := succ(i);
+    end;
+    lowercase := c;
+end;
+
+function uppercase(c : char): char;
+begin
+    uppercase := toupper(c);
+end;
+
+function uppercase(c: pchar): pchar;
+var
+    i : longint;
+begin
+    i := 0;
+    while c[i] <> #0 do begin
+        c[i] := toupper(c[i]);
+        i := succ(i);
+    end;
+    uppercase := c;
+end;
+
+Function streq(s1, s2 : pchar) : Boolean;    
+begin
+    streq := (strcomp(s1,s2) = 0);
+end;
+
+Function strneq(s1, s2 : pchar; n : longint) : Boolean;    
+begin
+    strneq := (strlcomp(s1,s2,n) = 0);
+end;
+
+Function strieq(s1, s2 : pchar) : Boolean;    
+begin
+    s1 := uppercase(s1);
+    s2 := uppercase(s2);
+    strieq := (strcomp(s1,s2)=0);
+end;
+
+Function strnieq(s1, s2 : pchar; n : longint) : Boolean;    
+begin
+    s1 := uppercase(s1);
+    s2 := uppercase(s2);
+    strnieq := (strlcomp(s1,s2,n)=0);
+end;
+
+Function strcmp(s1, s2 : pchar) : longint;    
+begin
+    strcmp := strcomp(s1,s2);
+end;
+
+Function stricmp(s1, s2 : pchar) : longint;
+begin
+    s1 := uppercase(s1);
+    s2 := uppercase(s2);
+    stricmp := strcomp(s1,s2);
+end;
+
+Function strncmp(s1, s2 : pchar; n : longint) : longint;   
+begin
+    strncmp := strlcomp(s1,s2,n);
+end;
+
+Function strnicmp(s1, s2 : pchar; n : longint) : longint;    
+begin
+    s1 := uppercase(s1);
+    s2 := uppercase(s2);
+    strnicmp := strlcomp(s1,s2,n);
+end;
+
+Procedure strcpy(s1, s2 : pchar);   
+begin
+    strcopy(s1,s2)
+end;
+
+Procedure strncpy(s1, s2 : pchar; n : integer);    
+begin
+    strlcopy(s1,s2,n);
+end;
+
+Procedure strncat(s1, s2 : pchar; n : integer);   
+begin
+    strlcat(s1,s2,n);
+end;
+
+Function strdup(s : pchar) : pchar;   
+begin
+    strdup := StrNew(s); 
+end;
+
+Function strpos(s1 : pchar; c : Char) : longint;   
+  Var
+     count: Longint;
+  Begin
+
+   count := 0;
+   { As in Borland Pascal , if looking for NULL return null }
+   if c = #0 then
+   begin
+     strpos := -1;
+     exit;
+   end;
+   { Find first matching character of Ch in Str }
+   while S1[count] <> #0 do
+   begin
+     if C = S1[count] then
+      begin
+          strpos := count;
+          exit;
+      end;
+     Inc(count);
+   end;
+   { nothing found. }
+   strpos := -1;
+ end;
+
+
+Function strrpos(s1 : pchar; c : Char) : longint;   
+Var
+  count: Longint;
+  index: Longint;
+ Begin
+   count := Strlen(S1);
+   { As in Borland Pascal , if looking for NULL return null }
+   if c = #0 then
+   begin
+     strrpos := -1;
+     exit;
+   end;
+   Dec(count);
+   for index := count downto 0 do
+   begin
+     if C = S1[index] then
+      begin
+          strrpos := index;
+          exit;
+      end;
+   end;
+   { nothing found. }
+   strrpos := -1;
+ end;
+
+
+Function AllocString(l : longint) : pchar;    
+begin
+    AllocString := StrAlloc(l);
+end;
+
+Procedure FreeString(s : pchar);   
+begin
+    StrDispose(s);
+end;
+
+end.
+
+{
+  $Log$
+  Revision 1.1  2002-11-22 21:34:59  nils
+
+    * initial release
+
+}
+
+  
+

packages/extra/amunits/utilunits/systemvartags.pas

@@ -0,0 +1,398 @@
+unit systemvartags;
+{$mode objfpc}
+
+interface
+
+uses exec,amigados, amigaguide, asl, bullet, intuition, datatypes ,
+     gadtools, graphics, locale, lowlevel, realtime, 
+     workbench, utility, tagsarray;
+
+{    As of today boolean and char doesn't function in
+     array of const. Use ltrue and lfalse instead. You 
+     can just cast a char.
+     
+     [email protected]
+}
+          
+const
+     ltrue  : longint = 1;
+     lfalse : longint = 0;
+
+{
+     This is functions and procedures with array of const.
+     For use with fpc 1.0 and above.
+}
+
+{ functions from amigados. }
+FUNCTION AllocDosObjectTags(type_ : ULONG; Const argv : Array of Const) : POINTER;
+FUNCTION CreateNewProcTags(Const argv : Array of Const) : pProcess;
+FUNCTION NewLoadSegTags(file_ : pCHAR; Const argv : Array of Const) : LONGINT;
+FUNCTION SystemTags(command : pCHAR; Const argv : Array of Const) : LONGINT;
+   {  This one as well, an overlay function }
+FUNCTION SystemTags(command : string; Const argv : Array of Const) : LONGINT;
+
+{ functions from amigaguide. }
+FUNCTION AddAmigaGuideHost(h : pHook; name : pCHAR; Const argv : Array Of Const) : POINTER;
+FUNCTION OpenAmigaGuide(nag : pNewAmigaGuide; Const argv : Array Of Const) : POINTER;
+FUNCTION OpenAmigaGuideAsync(nag : pNewAmigaGuide; Const argv : Array Of Const) : POINTER;
+FUNCTION RemoveAmigaGuideHost(hh : POINTER; Const argv : Array Of Const) : LONGINT;
+FUNCTION SendAmigaGuideCmd(cl : POINTER; cmd : pCHAR; Const argv : Array Of Const) : LONGINT;
+FUNCTION SendAmigaGuideContext(cl : POINTER; Const argv : Array Of Const) : LONGINT;
+FUNCTION SetAmigaGuideAttrs(cl : POINTER; Const argv : Array Of Const) : LONGINT;
+FUNCTION SetAmigaGuideContext(cl : POINTER; id : ULONG; Const argv : Array Of Const) : LONGINT;
+
+{ functions from asl. }
+FUNCTION AllocAslRequestTags(reqType : ULONG; Const argv : Array Of Const) : POINTER;
+FUNCTION AslRequestTags(requester : POINTER; Const argv : Array Of Const) : BOOLEAN;
+
+{ functions from bullet }
+FUNCTION ObtainInfo(glyphEngine : pGlyphEngine; Const argv : Array Of Const) : ULONG;
+FUNCTION ReleaseInfo(glyphEngine : pGlyphEngine; Const argv : Array Of Const) : ULONG;
+FUNCTION SetInfo(glyphEngine : pGlyphEngine; Const argv : Array Of Const) : ULONG;
+
+{ functions from datatypes }
+FUNCTION GetDTAttrs(o : pObject_; Const argv : Array Of Const) : ULONG;
+FUNCTION NewDTObject(name : POINTER; Const argv : Array Of Const): POINTER;
+FUNCTION ObtainDataType(typ : ULONG; handle : POINTER; Const argv : Array Of Const) : pDataType;
+PROCEDURE RefreshDTObject(o : pObject_; win : pWindow; req : pRequester; Const argv : Array Of Const);
+FUNCTION SetDTAttrs(o : pObject_; win : pWindow; req : pRequester; Const argv : Array Of Const) : ULONG;
+
+{ functions from gadtools }
+FUNCTION CreateGadget(kind : ULONG; gad : pGadget; ng : pNewGadget; Const argv : Array Of Const) : pGadget;
+FUNCTION CreateMenus(newmenu : pNewMenu; Const argv : Array Of Const) : pMenu;
+PROCEDURE DrawBevelBox(rport : pRastPort; left : LONGINT; top : LONGINT; width : LONGINT; height : LONGINT; Const argv : Array Of Const);
+FUNCTION GetVisualInfo(screen : pScreen; Const argv : Array Of Const) : POINTER;
+FUNCTION GT_GetGadgetAttrs(gad : pGadget; win : pWindow; req : pRequester; Const argv : Array Of Const) : LONGINT;
+PROCEDURE GT_SetGadgetAttrs(gad : pGadget; win : pWindow; req : pRequester; Const argv : Array Of Const);
+FUNCTION LayoutMenuItems(firstitem : pMenuItem; vi : POINTER; Const argv : Array Of Const) : BOOLEAN;
+FUNCTION LayoutMenus(firstmenu : pMenu; vi : POINTER; Const argv : Array Of Const) : BOOLEAN;
+
+{ functions from graphics }
+FUNCTION AllocSpriteData(bm : pBitMap; Const argv : Array Of Const) : pExtSprite;
+FUNCTION BestModeID(Const argv : Array Of Const) : ULONG;
+FUNCTION ChangeExtSprite(vp : pViewPort; oldsprite : pExtSprite; newsprite : pExtSprite; Const argv : Array Of Const) : LONGINT;
+FUNCTION ExtendFontTags(font : pTextFont; Const argv : Array Of Const) : ULONG;
+FUNCTION GetExtSprite(ss : pExtSprite; Const argv : Array Of Const) : LONGINT;
+PROCEDURE GetRPAttrs(rp : pRastPort; Const argv : Array Of Const);
+FUNCTION ObtainBestPen(cm : pColorMap; r : ULONG; g : ULONG; b : ULONG; Const argv : Array Of Const) : LONGINT;
+PROCEDURE SetRPAttrs(rp : pRastPort; Const argv : Array Of Const);
+FUNCTION VideoControlTags(colorMap : pColorMap; Const argv : Array Of Const) : BOOLEAN;
+FUNCTION WeighTAMatchTags(reqTextAttr : pTextAttr; targetTextAttr : pTextAttr; Const argv : Array Of Const) : INTEGER;
+
+{ functions from intuition. }
+FUNCTION OpenScreenTags(newScreen : pNewScreen; tagList : array of const) : pScreen;
+FUNCTION OpenWindowTags(newWindow : pNewWindow; tagList : array of const) : pWindow;
+FUNCTION NewObject(classPtr : pIClass; classID : pCHAR; Const argv : Array Of Const) : POINTER;
+FUNCTION SetGadgetAttrs(gadget : pGadget; window : pWindow; requester : pRequester; Const argv : Array Of Const) : ULONG;
+FUNCTION NewObject(classPtr : pIClass; classID : string; Const argv : array of const ) : POINTER;
+
+{ from locale }
+FUNCTION OpenCatalog(locale : pLocale; name : pCHAR; Const argv : Array Of Const) : pCatalog;
+
+{ functions from lowlevel }
+FUNCTION SetJoyPortAttrs(portNumber : ULONG; Const argv : Array Of Const) : BOOLEAN;
+FUNCTION SystemControl(Const argv : Array Of Const) : ULONG;
+
+{ functions from realtime }
+FUNCTION CreatePlayer(Const argv : Array Of Const) : pPlayer;
+FUNCTION GetPlayerAttrs(player : pPlayer; Const argv : Array Of Const) : ULONG;
+FUNCTION SetPlayerAttrs(player : pPlayer; Const argv : Array Of Const) : BOOLEAN;
+
+{ from utility }
+function AllocNamedObject(name : STRPTR; Const argv : Array Of Const) : pNamedObject;
+
+{ functions from workbench }
+FUNCTION AddAppMenuItem(id : ULONG; userdata : ULONG; text_ : pCHAR; msgport : pMsgPort; Const argv : Array Of Const) : pAppMenuItem;
+FUNCTION AddAppWindow(id : ULONG; userdata : ULONG; window : pWindow; msgport : pMsgPort; Const argv : Array Of Const) : pAppWindow;
+
+implementation
+
+uses pastoc;
+
+FUNCTION AllocDosObjectTags(type_ : ULONG; Const argv : Array of Const) : POINTER;
+begin
+     AllocDosObjectTags := AllocDosObjectTagList(type_, readintags(argv));
+end;
+
+FUNCTION CreateNewProcTags(Const argv : Array of Const) : pProcess;
+begin
+     CreateNewProcTags := CreateNewProcTagList(readintags(argv));
+end;
+
+FUNCTION NewLoadSegTags(file_ : pCHAR; Const argv : Array of Const) : LONGINT;
+begin
+     NewLoadSegTags := NewLoadSegTagList(file_,readintags(argv));
+end;
+
+FUNCTION SystemTags(command : pCHAR; Const argv : Array of Const) : LONGINT;
+begin
+     SystemTags := SystemTagList(command,readintags(argv));
+end;
+
+FUNCTION SystemTags(command : string; Const argv : Array of Const) : LONGINT;
+begin
+     SystemTags := SystemTagList(command,readintags(argv));
+end;
+
+FUNCTION OpenScreenTags(newScreen : pNewScreen; tagList : array of const) : pScreen;
+begin
+    OpenScreenTags := OpenScreenTagList(newScreen, readintags(tagList));
+end;
+
+FUNCTION OpenWindowTags(newWindow : pNewWindow; tagList : array of const) : pWindow;
+begin
+    OpenWindowTags := OpenWindowTagList(newWindow, readintags(tagList));
+end;
+
+FUNCTION NewObject(classPtr : pIClass; classID : pCHAR; Const argv : Array Of Const) : POINTER;
+begin
+    NewObject := NewObjectA(classPtr,classID, readintags(argv));
+end;
+
+FUNCTION NewObject(classPtr : pIClass; classID : string; Const argv : array of const ) : POINTER;
+begin
+      NewObject := NewObjectA(classPtr,pas2c(classID),readintags(argv));
+end;
+
+FUNCTION SetGadgetAttrs(gadget : pGadget; window : pWindow; requester : pRequester; Const argv : Array Of Const) : ULONG;
+begin
+    SetGadgetAttrs := SetGadgetAttrsA(gadget,window,requester,readintags(argv));
+end;
+
+FUNCTION AddAmigaGuideHost(h : pHook; name : pCHAR; Const argv : Array Of Const) : POINTER;
+begin
+    AddAmigaGuideHost := AddAmigaGuideHostA(h,name,readintags(argv));
+end;
+
+FUNCTION OpenAmigaGuide(nag : pNewAmigaGuide; Const argv : Array Of Const) : POINTER;
+begin
+    OpenAmigaGuide := OpenAmigaGuideA(nag,readintags(argv));
+end;
+
+FUNCTION OpenAmigaGuideAsync(nag : pNewAmigaGuide; Const argv : Array Of Const) : POINTER;
+begin
+    OpenAmigaGuideAsync := OpenAmigaGuideAsyncA(nag,readintags(argv));
+end;
+
+FUNCTION RemoveAmigaGuideHost(hh : POINTER; Const argv : Array Of Const) : LONGINT;
+begin
+    RemoveAmigaGuideHost := RemoveAmigaGuideHostA(hh,readintags(argv));
+end;
+
+FUNCTION SendAmigaGuideCmd(cl : POINTER; cmd : pCHAR; Const argv : Array Of Const) : LONGINT;
+begin
+    SendAmigaGuideCmd := SendAmigaGuideCmdA(cl,cmd,readintags(argv));
+end;
+
+FUNCTION SendAmigaGuideContext(cl : POINTER; Const argv : Array Of Const) : LONGINT;
+begin
+    SendAmigaGuideContext := SendAmigaGuideContextA(cl,readintags(argv));
+end;
+
+FUNCTION SetAmigaGuideAttrs(cl : POINTER; Const argv : Array Of Const) : LONGINT;
+begin
+    SetAmigaGuideAttrs := SetAmigaGuideAttrsA(cl,readintags(argv));
+end;
+
+FUNCTION SetAmigaGuideContext(cl : POINTER; id : ULONG; Const argv : Array Of Const) : LONGINT;
+begin
+    SetAmigaGuideContext := SetAmigaGuideContextA(cl,id,readintags(argv));
+end;
+
+FUNCTION AllocAslRequestTags(reqType : ULONG; Const argv : Array Of Const) : POINTER;
+begin
+    AllocAslRequestTags := AllocAslRequest(reqType,readintags(argv));
+end;
+
+FUNCTION AslRequestTags(requester : POINTER; Const argv : Array Of Const) : BOOLEAN;
+begin
+    AslRequestTags := AslRequest(requester,readintags(argv));
+end;
+
+FUNCTION ObtainInfo(glyphEngine : pGlyphEngine; Const argv : Array Of Const) : ULONG;
+begin
+    ObtainInfo := ObtainInfoA(glyphEngine,readintags(argv));
+end;
+
+FUNCTION ReleaseInfo(glyphEngine : pGlyphEngine; Const argv : Array Of Const) : ULONG;
+begin
+    ReleaseInfo := releaseInfoA(glyphEngine,readintags(argv));
+end;
+
+FUNCTION SetInfo(glyphEngine : pGlyphEngine; Const argv : Array Of Const) : ULONG;
+begin
+    SetInfo := SetInfoA(glyphEngine,readintags(argv));
+end;
+
+FUNCTION GetDTAttrs(o : pObject_; Const argv : Array Of Const) : ULONG;
+begin
+    GetDTAttrs := GetDTAttrsA(o,readintags(argv));
+end;
+
+FUNCTION NewDTObject(name : POINTER; Const argv : Array Of Const): POINTER;
+begin
+    NewDTObject := NewDTObjectA(name,readintags(argv));
+end;
+
+FUNCTION ObtainDataType(typ : ULONG; handle : POINTER; Const argv : Array Of Const) : pDataType;
+begin
+    ObtainDataType := ObtainDataTypeA(typ,handle,readintags(argv));
+end;
+PROCEDURE RefreshDTObject(o : pObject_; win : pWindow; req : pRequester; Const argv : Array Of Const);
+begin
+    RefreshDTObjectA(o,win,req,readintags(argv));
+end;
+
+FUNCTION SetDTAttrs(o : pObject_; win : pWindow; req : pRequester; Const argv : Array Of Const) : ULONG;
+begin
+    SetDTAttrs := SetDTAttrsA(o,win,req,readintags(argv));
+end;
+
+FUNCTION CreateGadget(kind : ULONG; gad : pGadget; ng : pNewGadget; Const argv : Array Of Const) : pGadget;
+begin
+    CreateGadget := CreateGadgetA(kind,gad,ng,readintags(argv));
+end;
+
+FUNCTION CreateMenus(newmenu : pNewMenu; Const argv : Array Of Const) : pMenu;
+begin
+    CreateMenus := CreateMenusA(newmenu,readintags(argv));
+end;
+
+PROCEDURE DrawBevelBox(rport : pRastPort; left : LONGINT; top : LONGINT; width : LONGINT; height : LONGINT; Const argv : Array Of Const);
+begin
+    DrawBevelBoxA(rport,left,top,width,height,readintags(argv));
+end;
+
+FUNCTION GetVisualInfo(screen : pScreen; Const argv : Array Of Const) : POINTER;
+begin
+    GetVisualInfo := GetVisualInfoA(screen,readintags(argv));
+end;
+
+FUNCTION GT_GetGadgetAttrs(gad : pGadget; win : pWindow; req : pRequester; Const argv : Array Of Const) : LONGINT;
+begin
+    GT_GetGadgetAttrs := GT_GetGadgetAttrsA(gad,win,req,readintags(argv));
+end;
+
+PROCEDURE GT_SetGadgetAttrs(gad : pGadget; win : pWindow; req : pRequester; Const argv : Array Of Const);
+begin
+    GT_SetGadgetAttrsA(gad,win,req,readintags(argv));
+end;
+
+FUNCTION LayoutMenuItems(firstitem : pMenuItem; vi : POINTER; Const argv : Array Of Const) : BOOLEAN;
+begin
+    LayoutMenuItems := LayoutMenuItemsA(firstitem,vi,readintags(argv));
+end;
+
+FUNCTION LayoutMenus(firstmenu : pMenu; vi : POINTER; Const argv : Array Of Const) : BOOLEAN;
+begin
+    LayoutMenus := LayoutMenusA(firstmenu,vi,readintags(argv));
+end;
+
+FUNCTION AllocSpriteData(bm : pBitMap; Const argv : Array Of Const) : pExtSprite;
+begin
+    AllocSpriteData := AllocSpriteDataA(bm,readintags(argv));
+end;
+
+FUNCTION BestModeID(Const argv : Array Of Const) : ULONG;
+begin
+    BestModeID := BestModeIDA(readintags(argv));
+end;
+
+FUNCTION ChangeExtSprite(vp : pViewPort; oldsprite : pExtSprite; newsprite : pExtSprite; Const argv : Array Of Const) : LONGINT;
+begin
+    ChangeExtSprite := ChangeExtSpriteA(vp,oldsprite,newsprite,readintags(argv));
+end;
+
+FUNCTION ExtendFontTags(font : pTextFont; Const argv : Array Of Const) : ULONG;
+begin
+    ExtendFontTags := ExtendFont(font,readintags(argv));
+end;
+
+FUNCTION GetExtSprite(ss : pExtSprite; Const argv : Array Of Const) : LONGINT;
+begin
+    GetExtSprite := GetExtSpriteA(ss,readintags(argv));
+end;
+
+PROCEDURE GetRPAttrs(rp : pRastPort; Const argv : Array Of Const);
+begin
+    GetRPAttrsA(rp,readintags(argv));
+end;
+
+FUNCTION ObtainBestPen(cm : pColorMap; r : ULONG; g : ULONG; b : ULONG; Const argv : Array Of Const) : LONGINT;
+begin
+    ObtainBestPen := ObtainBestPenA(cm,r,g,b,readintags(argv));
+end;
+
+PROCEDURE SetRPAttrs(rp : pRastPort; Const argv : Array Of Const);
+begin
+    SetRPAttrsA(rp,readintags(argv));
+end;
+
+FUNCTION VideoControlTags(colorMap : pColorMap; Const argv : Array Of Const) : BOOLEAN;
+begin
+    VideoControlTags := VideoControl(colorMap,readintags(argv));
+end;
+
+FUNCTION WeighTAMatchTags(reqTextAttr : pTextAttr; targetTextAttr : pTextAttr; Const argv : Array Of Const) : INTEGER;
+begin
+    WeighTAMatchTags := WeighTAMatch(reqTextAttr,targetTextAttr,readintags(argv));
+end;
+
+FUNCTION OpenCatalog(locale : pLocale; name : pCHAR; Const argv : Array Of Const) : pCatalog;
+begin
+    OpenCatalog := OpenCatalogA(locale,name,readintags(argv));
+end;
+
+FUNCTION SetJoyPortAttrs(portNumber : ULONG; Const argv : Array Of Const) : BOOLEAN;
+begin
+    SetJoyPortAttrs := SetJoyPortAttrsA(portNumber,readintags(argv));
+end;
+
+FUNCTION SystemControl(Const argv : Array Of Const) : ULONG;
+begin
+    SystemControl := SystemControlA(readintags(argv));
+end;
+
+FUNCTION CreatePlayer(Const argv : Array Of Const) : pPlayer;
+begin
+    CreatePlayer := CreatePlayerA(readintags(argv));
+end;
+
+FUNCTION GetPlayerAttrs(player : pPlayer; Const argv : Array Of Const) : ULONG;
+begin
+    GetPlayerAttrs := GetPlayerAttrsA(player,readintags(argv));
+end;
+
+FUNCTION SetPlayerAttrs(player : pPlayer; Const argv : Array Of Const) : BOOLEAN;
+begin
+    SetPlayerAttrs := SetPlayerAttrsA(player,readintags(argv));
+end;
+
+function AllocNamedObject(name : STRPTR; Const argv : Array Of Const) : pNamedObject;
+begin
+    AllocNamedObject := AllocNamedObjectA(name,readintags(argv));
+end;
+
+FUNCTION AddAppMenuItem(id : ULONG; userdata : ULONG; text_ : pCHAR; msgport : pMsgPort; Const argv : Array Of Const) : pAppMenuItem;
+begin
+    AddAppMenuItem := AddAppMenuItemA(id,userdata,text_,msgport,readintags(argv));
+end;
+
+FUNCTION AddAppWindow(id : ULONG; userdata : ULONG; window : pWindow; msgport : pMsgPort; Const argv : Array Of Const) : pAppWindow;
+begin
+    AddAppWindow := AddAppWindowA(id,userdata,window,msgport,readintags(argv));
+end;
+
+
+
+end.
+
+{
+  $Log$
+  Revision 1.1  2002-11-22 21:34:59  nils
+
+    * initial release
+
+}
+
+  

packages/extra/amunits/utilunits/tagsarray.pas

@@ -0,0 +1,87 @@
+{
+    This file is part of the Free Pascal run time library.
+
+    A file in Amiga system run time library.
+    Copyright (c) 2002 by Nils Sjoholm
+    member of the Amiga RTL development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+{
+     History:
+
+     First version of this unit.
+     Just use this unit when you want to
+     use taglist. Remember that you have
+     to use $mode objfpc in your programs.
+
+     09 Nov 2002
+
+     [email protected]
+}
+
+unit tagsarray;
+{$mode objfpc}
+
+
+interface
+
+uses Exec, Utility;
+
+const
+    ltrue : longint = 1;
+    lfalse : longint = 0;
+
+
+function readintags(const args : array of const): pTagItem;
+
+implementation
+
+uses pastoc;
+
+var
+   mytags : array [0..200] of ttagitem;
+
+function readintags(const args : array of const): pTagItem;
+var
+    i : longint;
+    ii : longint;
+begin
+    ii := 0;
+    for i := 0 to high(args) do begin
+         if (not odd(i)) then begin
+	      mytags[ii].ti_tag := longint(Args[i].vinteger);
+         end else begin
+	     case Args[i].vtype of
+	          vtinteger : mytags[ii].ti_data := longint(Args[i].vinteger);
+                  vtboolean : mytags[ii].ti_data := longint(byte(Args[i].vboolean));
+		  vtpchar   : mytags[ii].ti_data := longint(Args[i].vpchar);
+		  vtchar    : mytags[ii].ti_data := longint(Args[i].vchar);
+		  vtstring  : mytags[ii].ti_data := longint(pas2c(Args[i].vstring^));
+		  vtpointer : mytags[ii].ti_data := longint(Args[i].vpointer);
+             end;
+	     inc(ii);
+         end;
+    end;
+    readintags := @mytags;
+end;
+
+end.
+
+{
+  $Log$
+  Revision 1.1  2002-11-22 21:34:59  nils
+
+    * initial release
+
+}
+
+  
+

packages/extra/amunits/utilunits/timerutils.pas

@@ -0,0 +1,116 @@
+{
+    This file is part of the Free Pascal run time library.
+
+    A file in Amiga system run time library.
+    Copyright (c) 1998-2002 by Nils Sjoholm
+    member of the Amiga RTL development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+unit timerutils;
+
+{
+   History:
+
+   First version of this unit.
+   06 Sep 2000.
+   [email protected]
+
+}
+
+
+interface
+
+uses exec, timer, amigalib;
+
+Function CreateTimer(theUnit : longint) : pTimeRequest;
+Function SetTimer(WhichTimer : pTimeRequest;
+			Seconds, Microseconds : longint) : pMsgPort;
+Procedure WaitTimer(WhichTimer : pTimeRequest;
+			Seconds, Microseconds : longint);
+Procedure DeleteTimer(WhichTimer : pTimeRequest);
+
+implementation
+
+Function CreateTimer(theUnit : longint) : pTimeRequest;
+var
+    Error : longint;
+    TimerPort : pMsgPort;
+    TimeReq : pTimeRequest;
+begin
+    TimerPort := CreatePort(Nil, 0);
+    if TimerPort = Nil then 
+	CreateTimer := Nil;
+    TimeReq := pTimeRequest(CreateExtIO(TimerPort,sizeof(tTimeRequest)));
+    if TimeReq = Nil then begin
+	DeletePort(TimerPort);
+	CreateTimer := Nil;
+    end; 
+    Error := OpenDevice(TIMERNAME, theUnit, pIORequest(TimeReq), 0);
+    if Error <> 0 then begin
+	DeleteExtIO(pIORequest(TimeReq));
+	DeletePort(TimerPort);
+	CreateTimer := Nil;
+    end;
+    TimerBase := pointer(TimeReq^.tr_Node.io_Device); 
+    CreateTimer := pTimeRequest(TimeReq);
+end;
+
+Function SetTimer(WhichTimer : pTimeRequest; Seconds, Microseconds : longint) : pMsgPort;
+var
+    TempPort : pMsgPort;
+begin
+    with WhichTimer^ do begin
+	TempPort := tr_Node.io_Message.mn_ReplyPort;
+	tr_Node.io_Command := TR_ADDREQUEST;	{ add a new timer request }
+	tr_Time.tv_Secs := Seconds;		{ seconds }
+	tr_Time.tv_Micro := Microseconds;		{ microseconds }
+        SendIO(pIORequest(WhichTimer));
+	SetTimer := TempPort;
+    end;
+end;
+
+Procedure WaitTimer(WhichTimer : pTimeRequest;
+			Seconds, Microseconds : longint);
+var
+    Error : Integer;
+begin
+    with WhichTimer^ do begin
+	tr_Node.io_Command := TR_ADDREQUEST;	{ add a new timer request }
+	tr_Time.tv_Secs := Seconds;		{ seconds }
+	tr_Time.tv_Micro := Microseconds;		{ microseconds }
+	Error := DoIO(pIORequest(WhichTimer));
+    end;
+end;
+
+Procedure DeleteTimer(WhichTimer : pTimeRequest);
+var
+    WhichPort : pMsgPort;
+begin
+    
+    WhichPort := WhichTimer^.tr_Node.io_Message.mn_ReplyPort;
+    if assigned(WhichTimer) then begin
+        CloseDevice(pIORequest(WhichTimer));
+        DeleteExtIO(pIORequest(WhichTimer));
+    end;
+    if assigned(WhichPort) then
+        DeletePort(WhichPort);
+end;
+
+end.
+
+{
+  $Log$
+  Revision 1.1  2002-11-22 21:34:59  nils
+
+    * initial release
+
+}
+
+  

packages/extra/amunits/utilunits/vartags.pas

@@ -0,0 +1,584 @@
+{
+    This file is part of the Free Pascal run time library.
+
+    A file in Amiga system run time library.
+    Copyright (c) 2000 by Nils Sjoholm
+    member of the Amiga RTL development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+unit vartags;
+
+
+{
+
+  This is I hope, a unit that will go away when fpc 
+  have array of const. For now it will help to create
+  taglists for the functions that need it. 
+  25 Jan 2000.
+
+  Added const ltrue and lfalse, for work with taglists.
+  16 Jul 2000.
+
+  Moved SetTags and TagItem from tagutils.inc to this
+  unit.
+  Removed tagutils.inc from amigainc.
+  23 Jul 2000.
+
+  Use tagsarray instead.
+  09 Nov 2002.
+  
+  [email protected]
+
+}
+
+
+{
+  Here is an example on how to use TAGS.
+  
+    win := OpenWindowTagList(NIL, TAGS(
+                             WA_Width,  400,
+                             WA_Activate,    ltrue,
+                             WA_Height, 100,
+                             WA_CloseGadget, ltrue,
+                             WA_Title,  Longstr('Menu Test Window'),
+                             WA_IDCMP,  IDCMP_CLOSEWINDOW or IDCMP_MENUPICK,
+                             TAG_END));
+    
+}
+
+interface
+
+uses utility;
+
+type long = longint;
+
+const
+{  
+   This consts is for taglists, no need to cast
+   longint(byte(true)). Just use ltrue instead.
+}
+   ltrue : longint =  1;
+   lfalse : longint = 0;
+
+var
+   argbuff : array[0..30] of tTagItem;
+
+function LongStr(const s : string) : Longint;
+
+procedure SetTags(ti : pTagItem; item, data : Longint);
+function TagItem(item, data : Longint): tTagItem;
+
+function TAGS(a,b,c:long):pointer;
+function TAGS(a,b,c,d,e:long):pointer;
+function TAGS(a,b,c,d,e,f,g:long):pointer;
+function TAGS(a,b,c,d,e,f,g,h,i:long):pointer;
+function TAGS(a,b,c,d,e,f,g,h,i,j,k:long):pointer;
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m:long):pointer;
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o:long):pointer;
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q:long):pointer;
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s:long):pointer;
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u:long):pointer;
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w:long):pointer;
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,z:long):pointer;
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,v,w,x,z,aa,bb,cc:long):pointer;
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,v,w,x,z,aa,bb,cc,
+              dd,ee:long):pointer;
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,v,w,x,z,aa,bb,cc,
+              dd,ee,ff,gg:long):pointer;
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,v,w,x,z,aa,bb,cc,
+              dd,ee,ff,gg,hh,ii:long):pointer;
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,v,w,x,z,aa,bb,cc,
+              dd,ee,ff,gg,hh,ii,jj,kk:long):pointer;
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,v,w,x,z,aa,bb,cc,
+              dd,ee,ff,gg,hh,ii,jj,kk,ll,mm:long):pointer;
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,v,w,x,z,aa,bb,cc,
+              dd,ee,ff,gg,hh,ii,jj,kk,ll,mm,nn,oo:long):pointer;
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,v,w,x,z,aa,bb,cc,
+              dd,ee,ff,gg,hh,ii,jj,kk,ll,mm,nn,oo,pp,qq:long):pointer;
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,v,w,x,z,aa,bb,cc,
+              dd,ee,ff,gg,hh,ii,jj,kk,ll,mm,nn,oo,pp,qq,rr,ss:long):pointer;
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,v,w,x,z,aa,bb,cc,
+              dd,ee,ff,gg,hh,ii,jj,kk,ll,mm,nn,oo,pp,qq,rr,ss,tt,uu:long):pointer;
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,v,w,x,z,aa,bb,cc,
+              dd,ee,ff,gg,hh,ii,jj,kk,ll,mm,nn,oo,pp,qq,rr,ss,tt,uu,vv,ww:long):pointer;
+
+implementation
+
+uses pastoc;
+
+procedure SetTags(ti : pTagItem; item, data : Longint);
+begin
+    with ti^ do begin
+       ti_Tag := item;
+       ti_Data := data;
+    end;
+end; 
+
+function TagItem(item, data : Longint): tTagItem;
+var
+   temp : tTagItem;
+begin
+   with temp do begin
+      ti_Tag := item;
+      ti_Data := data;
+   end;
+   TagItem := temp;
+end;
+
+function LongStr(const s : string) : Longint;
+begin
+   LongStr := Longint(Pas2C(s));
+end;
+
+function TAGS(a,b,c:long):pointer;
+begin
+    argbuff[0] := TagItem(a,b);
+    argbuff[1].ti_Tag := c;
+    TAGS := @argbuff;
+end;
+
+function TAGS(a,b,c,d,e:long):pointer;
+begin
+    argbuff[0] := TagItem(a,b);
+    argbuff[1] := TagItem(c,d);
+    argbuff[2].ti_Tag := e;
+    TAGS := @argbuff;
+end;
+
+function TAGS(a,b,c,d,e,f,g:long):pointer;
+begin
+    argbuff[0] := TagItem(a,b);
+    argbuff[1] := TagItem(c,d);
+    argbuff[2] := TagItem(e,f);
+    argbuff[3].ti_Tag := g;
+    TAGS := @argbuff;
+end;
+
+function TAGS(a,b,c,d,e,f,g,h,i:long):pointer;
+begin
+    argbuff[0] := TagItem(a,b);
+    argbuff[1] := TagItem(c,d);
+    argbuff[2] := TagItem(e,f);
+    argbuff[3] := TagItem(g,h);
+    argbuff[4].ti_Tag := i;
+    TAGS := @argbuff;
+end;
+
+function TAGS(a,b,c,d,e,f,g,h,i,j,k:long):pointer;
+begin
+    argbuff[0] := TagItem(a,b);
+    argbuff[1] := TagItem(c,d);
+    argbuff[2] := TagItem(e,f);
+    argbuff[3] := TagItem(g,h);
+    argbuff[4] := TagItem(i,j);
+    argbuff[5].ti_Tag := k;
+    TAGS := @argbuff;
+end;
+
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m:long):pointer;
+begin
+    argbuff[0] := TagItem(a,b);
+    argbuff[1] := TagItem(c,d);
+    argbuff[2] := TagItem(e,f);
+    argbuff[3] := TagItem(g,h);
+    argbuff[4] := TagItem(i,j);
+    argbuff[5] := TagItem(k,l);
+    argbuff[6].ti_Tag := m;
+    TAGS := @argbuff;
+end;
+
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o:long):pointer;
+begin
+    argbuff[0] := TagItem(a,b);
+    argbuff[1] := TagItem(c,d);
+    argbuff[2] := TagItem(e,f);
+    argbuff[3] := TagItem(g,h);
+    argbuff[4] := TagItem(i,j);
+    argbuff[5] := TagItem(k,l);
+    argbuff[6] := TagItem(m,n);
+    argbuff[7].ti_Tag := o;
+    TAGS := @argbuff;
+end;
+
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q:long):pointer;
+begin
+    argbuff[0] := TagItem(a,b);
+    argbuff[1] := TagItem(c,d);
+    argbuff[2] := TagItem(e,f);
+    argbuff[3] := TagItem(g,h);
+    argbuff[4] := TagItem(i,j);
+    argbuff[5] := TagItem(k,l);
+    argbuff[6] := TagItem(m,n);
+    argbuff[7] := TagItem(o,p);
+    argbuff[8].ti_Tag := q;
+    TAGS := @argbuff;
+end;
+
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s:long):pointer;
+begin
+    argbuff[0] := TagItem(a,b);
+    argbuff[1] := TagItem(c,d);
+    argbuff[2] := TagItem(e,f);
+    argbuff[3] := TagItem(g,h);
+    argbuff[4] := TagItem(i,j);
+    argbuff[5] := TagItem(k,l);
+    argbuff[6] := TagItem(m,n);
+    argbuff[7] := TagItem(o,p);
+    argbuff[8] := TagItem(q,r);
+    argbuff[9].ti_Tag := s;
+    TAGS := @argbuff;
+end;
+
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u:long):pointer;
+begin
+    argbuff[0] := TagItem(a,b);
+    argbuff[1] := TagItem(c,d);
+    argbuff[2] := TagItem(e,f);
+    argbuff[3] := TagItem(g,h);
+    argbuff[4] := TagItem(i,j);
+    argbuff[5] := TagItem(k,l);
+    argbuff[6] := TagItem(m,n);
+    argbuff[7] := TagItem(o,p);
+    argbuff[8] := TagItem(q,r);
+    argbuff[9] := TagItem(s,t);
+    argbuff[10].ti_Tag := u;
+    TAGS := @argbuff;
+end;
+
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w:long):pointer;
+begin
+    argbuff[0] := TagItem(a,b);
+    argbuff[1] := TagItem(c,d);
+    argbuff[2] := TagItem(e,f);
+    argbuff[3] := TagItem(g,h);
+    argbuff[4] := TagItem(i,j);
+    argbuff[5] := TagItem(k,l);
+    argbuff[6] := TagItem(m,n);
+    argbuff[7] := TagItem(o,p);
+    argbuff[8] := TagItem(q,r);
+    argbuff[9] := TagItem(s,t);
+    argbuff[10] := TagItem(u,v);
+    argbuff[11].ti_Tag := w;
+    TAGS := @argbuff;
+end;
+
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,z:long):pointer;
+begin
+    argbuff[0] := TagItem(a,b);
+    argbuff[1] := TagItem(c,d);
+    argbuff[2] := TagItem(e,f);
+    argbuff[3] := TagItem(g,h);
+    argbuff[4] := TagItem(i,j);
+    argbuff[5] := TagItem(k,l);
+    argbuff[6] := TagItem(m,n);
+    argbuff[7] := TagItem(o,p);
+    argbuff[8] := TagItem(q,r);
+    argbuff[9] := TagItem(s,t);
+    argbuff[10] := TagItem(u,v);
+    argbuff[11] := TagItem(w,x);
+    argbuff[12].ti_Tag := z;
+    TAGS := @argbuff;
+end;
+
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,v,w,x,z,aa,bb,cc:long):pointer;
+begin
+    argbuff[0] := TagItem(a,b);
+    argbuff[1] := TagItem(c,d);
+    argbuff[2] := TagItem(e,f);
+    argbuff[3] := TagItem(g,h);
+    argbuff[4] := TagItem(i,j);
+    argbuff[5] := TagItem(k,l);
+    argbuff[6] := TagItem(m,n);
+    argbuff[7] := TagItem(o,p);
+    argbuff[8] := TagItem(q,r);
+    argbuff[9] := TagItem(s,t);
+    argbuff[10] := TagItem(v,w);
+    argbuff[11] := TagItem(x,z);
+    argbuff[12] := TagItem(aa,bb);
+    argbuff[13].ti_Tag := cc;
+    TAGS := @argbuff;
+end;
+
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,v,w,x,z,aa,bb,cc,
+              dd,ee:long):pointer;
+begin
+    argbuff[0] := TagItem(a,b);
+    argbuff[1] := TagItem(c,d);
+    argbuff[2] := TagItem(e,f);
+    argbuff[3] := TagItem(g,h);
+    argbuff[4] := TagItem(i,j);
+    argbuff[5] := TagItem(k,l);
+    argbuff[6] := TagItem(m,n);
+    argbuff[7] := TagItem(o,p);
+    argbuff[8] := TagItem(q,r);
+    argbuff[9] := TagItem(s,t);
+    argbuff[10] := TagItem(v,w);
+    argbuff[11] := TagItem(x,z);
+    argbuff[12] := TagItem(aa,bb);
+    argbuff[13] := TagItem(cc,dd);
+    argbuff[14].ti_Tag := ee;
+    TAGS := @argbuff;
+end;
+
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,v,w,x,z,aa,bb,cc,
+              dd,ee,ff,gg:long):pointer;
+begin
+    argbuff[0] := TagItem(a,b);
+    argbuff[1] := TagItem(c,d);
+    argbuff[2] := TagItem(e,f);
+    argbuff[3] := TagItem(g,h);
+    argbuff[4] := TagItem(i,j);
+    argbuff[5] := TagItem(k,l);
+    argbuff[6] := TagItem(m,n);
+    argbuff[7] := TagItem(o,p);
+    argbuff[8] := TagItem(q,r);
+    argbuff[9] := TagItem(s,t);
+    argbuff[10] := TagItem(v,w);
+    argbuff[11] := TagItem(x,z);
+    argbuff[12] := TagItem(aa,bb);
+    argbuff[13] := TagItem(cc,dd);
+    argbuff[14] := TagItem(ee,ff);
+    argbuff[14].ti_Tag := gg;
+    TAGS := @argbuff;
+end;
+
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,v,w,x,z,aa,bb,cc,
+              dd,ee,ff,gg,hh,ii:long):pointer;
+begin
+    argbuff[0] := TagItem(a,b);
+    argbuff[1] := TagItem(c,d);
+    argbuff[2] := TagItem(e,f);
+    argbuff[3] := TagItem(g,h);
+    argbuff[4] := TagItem(i,j);
+    argbuff[5] := TagItem(k,l);
+    argbuff[6] := TagItem(m,n);
+    argbuff[7] := TagItem(o,p);
+    argbuff[8] := TagItem(q,r);
+    argbuff[9] := TagItem(s,t);
+    argbuff[10] := TagItem(v,w);
+    argbuff[11] := TagItem(x,z);
+    argbuff[12] := TagItem(aa,bb);
+    argbuff[13] := TagItem(cc,dd);
+    argbuff[14] := TagItem(ee,ff);
+    argbuff[15] := TagItem(gg,hh);
+    argbuff[16].ti_Tag := ii;
+    TAGS := @argbuff;
+end;
+
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,v,w,x,z,aa,bb,cc,
+              dd,ee,ff,gg,hh,ii,jj,kk:long):pointer;
+begin
+    argbuff[0] := TagItem(a,b);
+    argbuff[1] := TagItem(c,d);
+    argbuff[2] := TagItem(e,f);
+    argbuff[3] := TagItem(g,h);
+    argbuff[4] := TagItem(i,j);
+    argbuff[5] := TagItem(k,l);
+    argbuff[6] := TagItem(m,n);
+    argbuff[7] := TagItem(o,p);
+    argbuff[8] := TagItem(q,r);
+    argbuff[9] := TagItem(s,t);
+    argbuff[10] := TagItem(v,w);
+    argbuff[11] := TagItem(x,z);
+    argbuff[12] := TagItem(aa,bb);
+    argbuff[13] := TagItem(cc,dd);
+    argbuff[14] := TagItem(ee,ff);
+    argbuff[15] := TagItem(gg,hh);
+    argbuff[16] := TagItem(ii,jj);
+    argbuff[17].ti_Tag := kk;
+    TAGS := @argbuff;
+end;
+
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,v,w,x,z,aa,bb,cc,
+              dd,ee,ff,gg,hh,ii,jj,kk,ll,mm:long):pointer;
+begin
+    argbuff[0] := TagItem(a,b);
+    argbuff[1] := TagItem(c,d);
+    argbuff[2] := TagItem(e,f);
+    argbuff[3] := TagItem(g,h);
+    argbuff[4] := TagItem(i,j);
+    argbuff[5] := TagItem(k,l);
+    argbuff[6] := TagItem(m,n);
+    argbuff[7] := TagItem(o,p);
+    argbuff[8] := TagItem(q,r);
+    argbuff[9] := TagItem(s,t);
+    argbuff[10] := TagItem(v,w);
+    argbuff[11] := TagItem(x,z);
+    argbuff[12] := TagItem(aa,bb);
+    argbuff[13] := TagItem(cc,dd);
+    argbuff[14] := TagItem(ee,ff);
+    argbuff[15] := TagItem(gg,hh);
+    argbuff[16] := TagItem(ii,jj);
+    argbuff[17] := TagItem(kk,ll);
+    argbuff[18].ti_Tag := mm;
+    TAGS := @argbuff;
+end;
+
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,v,w,x,z,aa,bb,cc,
+              dd,ee,ff,gg,hh,ii,jj,kk,ll,mm,nn,oo:long):pointer;
+begin
+    argbuff[0] := TagItem(a,b);
+    argbuff[1] := TagItem(c,d);
+    argbuff[2] := TagItem(e,f);
+    argbuff[3] := TagItem(g,h);
+    argbuff[4] := TagItem(i,j);
+    argbuff[5] := TagItem(k,l);
+    argbuff[6] := TagItem(m,n);
+    argbuff[7] := TagItem(o,p);
+    argbuff[8] := TagItem(q,r);
+    argbuff[9] := TagItem(s,t);
+    argbuff[10] := TagItem(v,w);
+    argbuff[11] := TagItem(x,z);
+    argbuff[12] := TagItem(aa,bb);
+    argbuff[13] := TagItem(cc,dd);
+    argbuff[14] := TagItem(ee,ff);
+    argbuff[15] := TagItem(gg,hh);
+    argbuff[16] := TagItem(ii,jj);
+    argbuff[17] := TagItem(kk,ll);
+    argbuff[18] := TagItem(mm,nn);
+    argbuff[19].ti_Tag := oo;
+    TAGS := @argbuff;
+end;
+
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,v,w,x,z,aa,bb,cc,
+              dd,ee,ff,gg,hh,ii,jj,kk,ll,mm,nn,oo,pp,qq:long):pointer;
+begin
+    argbuff[0] := TagItem(a,b);
+    argbuff[1] := TagItem(c,d);
+    argbuff[2] := TagItem(e,f);
+    argbuff[3] := TagItem(g,h);
+    argbuff[4] := TagItem(i,j);
+    argbuff[5] := TagItem(k,l);
+    argbuff[6] := TagItem(m,n);
+    argbuff[7] := TagItem(o,p);
+    argbuff[8] := TagItem(q,r);
+    argbuff[9] := TagItem(s,t);
+    argbuff[10] := TagItem(v,w);
+    argbuff[11] := TagItem(x,z);
+    argbuff[12] := TagItem(aa,bb);
+    argbuff[13] := TagItem(cc,dd);
+    argbuff[14] := TagItem(ee,ff);
+    argbuff[15] := TagItem(gg,hh);
+    argbuff[16] := TagItem(ii,jj);
+    argbuff[17] := TagItem(kk,ll);
+    argbuff[18] := TagItem(mm,nn);
+    argbuff[19] := TagItem(oo,pp);
+    argbuff[20].ti_Tag := qq;
+    TAGS := @argbuff;
+end;
+
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,v,w,x,z,aa,bb,cc,
+              dd,ee,ff,gg,hh,ii,jj,kk,ll,mm,nn,oo,pp,qq,rr,ss:long):pointer;
+begin
+    argbuff[0] := TagItem(a,b);
+    argbuff[1] := TagItem(c,d);
+    argbuff[2] := TagItem(e,f);
+    argbuff[3] := TagItem(g,h);
+    argbuff[4] := TagItem(i,j);
+    argbuff[5] := TagItem(k,l);
+    argbuff[6] := TagItem(m,n);
+    argbuff[7] := TagItem(o,p);
+    argbuff[8] := TagItem(q,r);
+    argbuff[9] := TagItem(s,t);
+    argbuff[10] := TagItem(v,w);
+    argbuff[11] := TagItem(x,z);
+    argbuff[12] := TagItem(aa,bb);
+    argbuff[13] := TagItem(cc,dd);
+    argbuff[14] := TagItem(ee,ff);
+    argbuff[15] := TagItem(gg,hh);
+    argbuff[16] := TagItem(ii,jj);
+    argbuff[17] := TagItem(kk,ll);
+    argbuff[18] := TagItem(mm,nn);
+    argbuff[19] := TagItem(oo,pp);
+    argbuff[20] := TagItem(qq,rr);
+    argbuff[21].ti_Tag := ss;
+    TAGS := @argbuff;
+end;
+
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,v,w,x,z,aa,bb,cc,
+              dd,ee,ff,gg,hh,ii,jj,kk,ll,mm,nn,oo,pp,qq,rr,ss,tt,uu:long):pointer;
+begin
+    argbuff[0] := TagItem(a,b);
+    argbuff[1] := TagItem(c,d);
+    argbuff[2] := TagItem(e,f);
+    argbuff[3] := TagItem(g,h);
+    argbuff[4] := TagItem(i,j);
+    argbuff[5] := TagItem(k,l);
+    argbuff[6] := TagItem(m,n);
+    argbuff[7] := TagItem(o,p);
+    argbuff[8] := TagItem(q,r);
+    argbuff[9] := TagItem(s,t);
+    argbuff[10] := TagItem(v,w);
+    argbuff[11] := TagItem(x,z);
+    argbuff[12] := TagItem(aa,bb);
+    argbuff[13] := TagItem(cc,dd);
+    argbuff[14] := TagItem(ee,ff);
+    argbuff[15] := TagItem(gg,hh);
+    argbuff[16] := TagItem(ii,jj);
+    argbuff[17] := TagItem(kk,ll);
+    argbuff[18] := TagItem(mm,nn);
+    argbuff[19] := TagItem(oo,pp);
+    argbuff[20] := TagItem(qq,rr);
+    argbuff[21] := TagItem(ss,tt);
+    argbuff[22].ti_Tag := uu;
+    TAGS := @argbuff;
+end;
+
+function TAGS(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,v,w,x,z,aa,bb,cc,
+              dd,ee,ff,gg,hh,ii,jj,kk,ll,mm,nn,oo,pp,qq,rr,ss,tt,uu,vv,ww:long):pointer;
+begin
+    argbuff[0] := TagItem(a,b);
+    argbuff[1] := TagItem(c,d);
+    argbuff[2] := TagItem(e,f);
+    argbuff[3] := TagItem(g,h);
+    argbuff[4] := TagItem(i,j);
+    argbuff[5] := TagItem(k,l);
+    argbuff[6] := TagItem(m,n);
+    argbuff[7] := TagItem(o,p);
+    argbuff[8] := TagItem(q,r);
+    argbuff[9] := TagItem(s,t);
+    argbuff[10] := TagItem(v,w);
+    argbuff[11] := TagItem(x,z);
+    argbuff[12] := TagItem(aa,bb);
+    argbuff[13] := TagItem(cc,dd);
+    argbuff[14] := TagItem(ee,ff);
+    argbuff[15] := TagItem(gg,hh);
+    argbuff[16] := TagItem(ii,jj);
+    argbuff[17] := TagItem(kk,ll);
+    argbuff[18] := TagItem(mm,nn);
+    argbuff[19] := TagItem(oo,pp);
+    argbuff[20] := TagItem(qq,rr);
+    argbuff[21] := TagItem(ss,tt);
+    argbuff[22] := TagItem(uu,vv);
+    argbuff[23].ti_Tag := ww;
+    TAGS := @argbuff;
+end;
+
+
+end.
+
+{
+  $Log$
+  Revision 1.1  2002-11-22 21:34:59  nils
+
+    * initial release
+
+}
+
+  
+
+
+
+
+
+
+
+

packages/extra/amunits/utilunits/wbargs.pas

@@ -0,0 +1,102 @@
+{
+    This file is part of the Free Pascal run time library.
+
+    A file in Amiga system run time library.
+    Copyright (c) 1998-2002 by Nils Sjoholm
+    member of the Amiga RTL development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+{
+     The boolean WBStarted is in system.
+     Just check the value of system.WBStarted
+     or just WBStarted, if it is true then you
+     started from workbench.
+}
+
+unit WBArgs;
+
+interface
+
+uses workbench,amigados;
+
+function GetStartupMsg: pWBStartup;
+function ProgramName: string;
+function WBArgCount: integer;
+function GetWBArg(num : Integer): STRING;
+
+implementation
+
+function GetStartupMsg: pWBStartup;
+begin
+    if system._WBenchMsg <> nil then
+        GetStartupMsg := pWBStartup(_WBenchMsg)
+    else
+       GetStartupMsg := nil;
+end;
+
+function ProgramName: string;
+var
+    WBMsg : pWBStartup;
+    buffer : array[0..255] of char;
+begin
+    WBMsg := GetStartupMsg;
+    if WBMsg <> nil then begin
+       ProgramName := strpas(WBMsg^.sm_ArgList^[1].wa_Name);
+    end else begin
+       if GetprogramName(buffer,255) then begin
+           ProgramName := strpas(buffer);
+       end else begin
+           ProgramName := '';
+       end;
+    end;
+end;
+
+function WBArgCount: integer;
+var
+   WBMsg : pWBStartup;
+begin
+   WBMsg := GetStartupMsg;
+   if WBMsg <> nil then
+       WBArgCount := WBMsg^.sm_NumArgs -1
+   else WBArgCount := 0;
+end;
+
+function GetWBArg(num : Integer): string;
+var
+    WBMsg : pWBStartup;
+    param : Integer;
+begin
+    WBMsg := GetStartupMsg;
+    if WBMsg <> nil then begin
+       param := WBMsg^.sm_NumArgs;
+    end else begin
+       param := 0;
+    end;
+    if (param > 0) AND (num <= param) then begin
+       GetWBArg := strpas(WBMsg^.sm_ArgList^[num+1].wa_Name);
+    end else begin
+       GetWBArg := '';
+    end;
+end;
+
+end.
+
+{
+  $Log$
+  Revision 1.1  2002-11-22 21:34:59  nils
+
+    * initial release
+
+}
+
+  
+
+