Amiga: First Version of crt for Amiga

git-svn-id: trunk@43814 -

packages/rtl-console/fpmake.pp

@@ -16,7 +16,7 @@ Const
   KVMAll       = [emx,go32v2,msdos,netware,netwlibc,os2,win32,win64,win16]+UnixLikes+AllAmigaLikeOSes;
 
   // all full KVMers have crt too, except Amigalikes
-  CrtOSes      = KVMALL+[WatCom]-[aros,morphos,amiga];
+  CrtOSes      = KVMALL+[WatCom]-[aros,morphos];
   KbdOSes      = KVMALL;
   VideoOSes    = KVMALL;
   MouseOSes    = KVMALL;

packages/rtl-console/src/amiga/crt.pp

@@ -1,6 +1,7 @@
 {
     This file is part of the Free Pascal run time library.
     Copyright (c) 1999-2000 by Nils Sjoholm and Carl Eric Codere
+    Copyright (c) 2019 by Free Pascal development team
 
     See the file COPYING.FPC, included in this distribution,
     for details about the copyright.
@@ -11,915 +12,534 @@
 
  **********************************************************************}
 
+unit crt;
 
-unit Crt;
-
-{--------------------------------------------------------------------}
-{ LEFT TO DO:                                                        }
-{--------------------------------------------------------------------}
-{ o Write special characters are not recognized                      }
-{ o Write does not take care of window coordinates yet.              }
-{ o Read does not recognize the special editing characters           }
-{ o Read does not take care of window coordinates yet.               }
-{ o Readkey extended scancode is not correct yet                     }
-{ o Color mapping only works for 4 colours                           }
-{ o ClrScr, DeleteLine, InsLine do not work with window coordinates  }
-{--------------------------------------------------------------------}
-
-
-
-Interface
-
-Const
-{ Controlling consts }
-  Flushing=false;                       {if true then don't buffer output}
-  ScreenWidth  = 80;
-  ScreenHeight = 25;
+interface
 
 {$i crth.inc}
 
-Implementation
+implementation
 
 uses
-  exec, amigados, conunit, intuition;
+  exec, amigados, conunit, intuition, agraphics;
 
 var
-  maxcols,maxrows : longint;
-
-CONST
-  { This is used to make sure that readkey returns immediately }
-  { if keypressed was used beforehand.                         }
-  KeyPress : char = #0;
-  _LVODisplayBeep = -96;
-
-(*
-Type
-
-    pInfoData = ^tInfoData;
-    tInfoData = packed record
-        id_NumSoftErrors        : Longint;      { number of soft errors on disk }
-        id_UnitNumber           : Longint;      { Which unit disk is (was) mounted on }
-        id_DiskState            : Longint;      { See defines below }
-        id_NumBlocks            : Longint;      { Number of blocks on disk }
-        id_NumBlocksUsed        : Longint;      { Number of block in use }
-        id_BytesPerBlock        : Longint;
-        id_DiskType             : Longint;      { Disk Type code }
-        id_VolumeNode           : Longint;         { BCPL pointer to volume node }
-        id_InUse                : Longint;      { Flag, zero if not in use }
-    end;
-
-{ *  List Node Structure.  Each member in a list starts with a Node * }
-
-  pNode = ^tNode;
-  tNode = packed Record
-    ln_Succ,                { * Pointer to next (successor) * }
-    ln_Pred  : pNode;       { * Pointer to previous (predecessor) * }
-    ln_Type  : Byte;
-    ln_Pri   : Shortint;    { * Priority, for sorting * }
-    ln_Name  : PChar;       { * ID string, null terminated * }
-  End;  { * Note: Integer aligned * }
-
-{ normal, full featured list }
-
-    pList = ^tList;
-    tList = packed record
-    lh_Head     : pNode;
-    lh_Tail     : pNode;
-    lh_TailPred : pNode;
-    lh_Type     : Byte;
-    l_pad       : Byte;
-    end;
+  MaxCols, MaxRows: LongInt;
 
-    pMsgPort = ^tMsgPort;
-    tMsgPort = packed record
-    mp_Node     : tNode;
-    mp_Flags    : Byte;
-    mp_SigBit   : Byte;      { signal bit number    }
-    mp_SigTask  : Pointer;   { task to be signalled (TaskPtr) }
-    mp_MsgList  : tList;     { message linked list  }
-    end;
-
-    pMessage = ^tMessage;
-    tMessage = packed record
-    mn_Node       : tNode;
-    mn_ReplyPort  : pMsgPort;   { message reply port }
-    mn_Length     : Word;       { message len in bytes }
-    end;
-
-    pIOStdReq = ^tIOStdReq;
-    tIOStdReq = packed record
-    io_Message  : tMessage;
-    io_Device   : Pointer;      { device node pointer  }
-    io_Unit     : Pointer;      { unit (driver private)}
-    io_Command  : Word;         { device command }
-    io_Flags    : Byte;
-    io_Error    : Shortint;     { error or warning num }
-    io_Actual   : Longint;      { actual number of bytes transferred }
-    io_Length   : Longint;      { requested number bytes transferred}
-    io_Data     : Pointer;      { points to data area }
-    io_Offset   : Longint;      { offset for block structured devices }
-    end;
-
-    pIntuiMessage = ^tIntuiMessage;
-    tIntuiMessage = packed record
-        ExecMessage     : tMessage;
-        IClass          : Longint;
-        Code            : Word;
-        Qualifier       : Word;
-        IAddress        : Pointer;
-        MouseX,
-        MouseY          : Word;
-        Seconds,
-        Micros          : Longint;
-        IDCMPWindow     : Pointer;
-        SpecialLink     : pIntuiMessage;
-    end;
-
-    pWindow = ^tWindow;
-    tWindow = packed record
-        NextWindow      : pWindow;      { for the linked list in a screen }
-        LeftEdge,
-        TopEdge         : Integer;      { screen dimensions of window }
-        Width,
-        Height          : Integer;      { screen dimensions of window }
-        MouseY,
-        MouseX          : Integer;      { relative to upper-left of window }
-        MinWidth,
-        MinHeight       : Integer;      { minimum sizes }
-        MaxWidth,
-        MaxHeight       : Word;         { maximum sizes }
-        Flags           : Longint;      { see below for defines }
-        MenuStrip       : Pointer;      { the strip of Menu headers }
-        Title           : PChar;        { the title text for this window }
-        FirstRequest    : Pointer;      { all active Requesters }
-        DMRequest       : Pointer;      { double-click Requester }
-        ReqCount        : Integer;      { count of reqs blocking Window }
-        WScreen         : Pointer;      { this Window's Screen }
-        RPort           : Pointer;      { this Window's very own RastPort }
-        BorderLeft,
-        BorderTop,
-        BorderRight,
-        BorderBottom    : Shortint;
-        BorderRPort     : Pointer;
-        FirstGadget     : Pointer;
-        Parent,
-        Descendant      : pWindow;
-        Pointer_        : Pointer;      { sprite data }
-        PtrHeight       : Shortint;     { sprite height (not including sprite padding) }
-        PtrWidth        : Shortint;     { sprite width (must be less than or equal to 16) }
-        XOffset,
-        YOffset         : Shortint;     { sprite offsets }
-        IDCMPFlags      : Longint;      { User-selected flags }
-        UserPort,
-        WindowPort      : pMsgPort;
-        MessageKey      : pIntuiMessage;
-        DetailPen,
-        BlockPen        : Byte;         { for bar/border/gadget rendering }
-        CheckMark       : Pointer;
-        ScreenTitle     : PChar;        { if non-null, Screen title when Window is active }
-        GZZMouseX       : Integer;
-        GZZMouseY       : Integer;
-        GZZWidth        : Integer;
-        GZZHeight       : Word;
-        ExtData         : Pointer;
-        UserData        : Pointer;      { general-purpose pointer to User data extension }
-        WLayer          : Pointer;
-        IFont           : Pointer;
-        MoreFlags       : Longint;
-    end;
-*)
-    const
-
-    M_LNM               = 20;           { linefeed newline mode }
-    PMB_ASM     = M_LNM + 1;    { internal storage bit for AS flag }
-    PMB_AWM     = PMB_ASM + 1;  { internal storage bit for AW flag }
-    MAXTABS     = 80;
-    IECLASS_MAX = $15;
-
-(*
-type
-
-    pKeyMap = ^tKeyMap;
-    tKeyMap = packed record
-        km_LoKeyMapTypes        : Pointer;
-        km_LoKeyMap             : Pointer;
-        km_LoCapsable           : Pointer;
-        km_LoRepeatable         : Pointer;
-        km_HiKeyMapTypes        : Pointer;
-        km_HiKeyMap             : Pointer;
-        km_HiCapsable           : Pointer;
-        km_HiRepeatable         : Pointer;
-    end;
-
-
-
-    pConUnit = ^tConUnit;
-    tConUnit = packed record
-        cu_MP   : tMsgPort;
-        { ---- read only variables }
-        cu_Window       : Pointer;      { (WindowPtr) intuition window bound to this unit }
-        cu_XCP          : Integer;        { character position }
-        cu_YCP          : Integer;
-        cu_XMax         : Integer;        { max character position }
-        cu_YMax         : Integer;
-        cu_XRSize       : Integer;        { character raster size }
-        cu_YRSize       : Integer;
-        cu_XROrigin     : Integer;        { raster origin }
-        cu_YROrigin     : Integer;
-        cu_XRExtant     : Integer;        { raster maxima }
-        cu_YRExtant     : Integer;
-        cu_XMinShrink   : Integer;        { smallest area intact from resize process }
-        cu_YMinShrink   : Integer;
-        cu_XCCP         : Integer;        { cursor position }
-        cu_YCCP         : Integer;
-
-   { ---- read/write variables (writes must must be protected) }
-   { ---- storage for AskKeyMap and SetKeyMap }
-
-        cu_KeyMapStruct : tKeyMap;
-
-   { ---- tab stops }
-
-        cu_TabStops     : Array [0..MAXTABS-1] of Word;
-                                { 0 at start, -1 at end of list }
-
-   { ---- console rastport attributes }
-
-        cu_Mask         : Shortint;
-        cu_FgPen        : Shortint;
-        cu_BgPen        : Shortint;
-        cu_AOLPen       : Shortint;
-        cu_DrawMode     : Shortint;
-        cu_AreaPtSz     : Shortint;
-        cu_AreaPtrn     : Pointer;      { cursor area pattern }
-        cu_Minterms     : Array [0..7] of Byte; { console minterms }
-        cu_Font         : Pointer;      { (TextFontPtr) }
-        cu_AlgoStyle    : Byte;
-        cu_TxFlags      : Byte;
-        cu_TxHeight     : Word;
-        cu_TxWidth      : Word;
-        cu_TxBaseline   : Word;
-        cu_TxSpacing    : Word;
-
-   { ---- console MODES and RAW EVENTS switches }
-
-        cu_Modes        : Array [0..(PMB_AWM+7) div 8 - 1] of Byte;
-                                { one bit per mode }
-        cu_RawEvents    : Array [0..(IECLASS_MAX+7) div 8 - 1] of Byte;
-    end;
-*)
 const
+  CD_CURRX = 1;
+  CD_CURRY = 2;
+  CD_MAXX  = 3;
+  CD_MAXY  = 4;
+  // Special Character for commands to console
+  CSI = Chr($9b);
 
-
-   CD_CURRX =  1;
-   CD_CURRY =  2;
-   CD_MAXX  =  3;
-   CD_MAXY  =  4;
-
-   CSI      = chr($9b);
-
-   SIGBREAKF_CTRL_C = 4096;
-
-{function AllocVec( size, reqm : Longint ): Pointer;
+var
+  // Pens for Front/Backcolors (must be 0-7)
+  RedPen: LongInt = -1;
+  FreeRed: Boolean = False;
+  GreenPen: LongInt = -1;
+  FreeGreen: Boolean = False;
+  // multiple keys
+  LastKeys: string = '';
+
+function SendActionPacket(Port: PMsgPort; Arg: BPTR): LongInt;
+var
+  ReplyPort: PMsgPort;
+  Packet: PStandardPacket;
+  Ret: NativeInt;
 begin
-   asm
-       MOVE.L  A6,-(A7)
-       MOVE.L  size,d0
-       MOVE.L  reqm,d1
-       MOVE.L  _ExecBase, A6
-       JSR -684(A6)
-       MOVE.L  (A7)+,A6
-       MOVE.L  d0,@RESULT
-   end;
-end;
+  SendActionPacket := 0;
+  ReplyPort := CreateMsgPort;
+  if not Assigned(ReplyPort) then
+    Exit;
 
+  Packet := AllocMem(SizeOf(TStandardPacket));
 
-function DoPkt(ID : pMsgPort;
-               Action, Param1, Param2,
-               Param3, Param4, Param5 : Longint) : Longint;
-begin
-   asm
-       MOVEM.L d2/d3/d4/d5/d6/d7/a6,-(A7)
-       MOVE.L  ID,d1
-       MOVE.L  Action,d2
-       MOVE.L  Param1,d3
-       MOVE.L  Param2,d4
-       MOVE.L  Param3,d5
-       MOVE.L  Param4,d6
-       MOVE.L  Param5,d7
-       MOVE.L  _DOSBase,A6
-       JSR -240(A6)
-       MOVEM.L (A7)+,d2/d3/d4/d5/d6/d7/a6
-       MOVE.L  d0,@RESULT
-   end;
-end;
+  if not Assigned(Packet) then
+  begin
+    DeleteMsgPort(ReplyPort);
+    Exit;
+  end;
 
-procedure FreeVec( memory : Pointer );
-begin
-   asm
-       MOVE.L  A6,-(A7)
-       MOVE.L  memory,a1
-       MOVE.L  _ExecBase,A6
-       JSR -690(A6)
-       MOVE.L  (A7)+,A6
-   end;
-end;
+  Packet^.sp_Msg.mn_Node.ln_Name := @(Packet^.sp_Pkt);
+  Packet^.sp_Pkt.dp_Link := @(Packet^.sp_Msg);
+  Packet^.sp_Pkt.dp_Port := ReplyPort;
+  Packet^.sp_Pkt.dp_Type := ACTION_DISK_INFO;
+  Packet^.sp_Pkt.dp_Arg1 := NativeInt(Arg);
 
+  PutMsg(Port, PMessage(Packet));
+  WaitPort(ReplyPort);
+  GetMsg(ReplyPort);
 
-function GetConsoleTask : pMsgPort;
-begin
-   asm
-       MOVE.L  A6,-(A7)
-       MOVE.L  _DOSBase,A6
-       JSR -510(A6)
-       MOVE.L  (A7)+,A6
-       MOVE.L  d0,@RESULT
-   end;
-end;
+  Ret := Packet^.sp_Pkt.dp_Res1;
 
+  FreeMem(Packet);
+  DeleteMsgPort(ReplyPort);
 
-function GetMsg(port : pMsgPort): pMessage;
-begin
-   asm
-       MOVE.L  A6,-(A7)
-       MOVE.L  port,a0
-       MOVE.L  _ExecBase,A6
-       JSR -372(A6)
-       MOVE.L  (A7)+,A6
-       MOVE.L  d0,@RESULT
-   end;
+  SendActionPacket := Ret;
 end;
 
-function ModifyIDCMP(window : pWindow;
-                     IDCMPFlags : Longint) : Boolean;
-begin
-   asm
-       MOVE.L  A6,-(A7)
-       MOVE.L  window,a0
-       MOVE.L  IDCMPFlags,d0
-       MOVE.L  _IntuitionBase,A6
-       JSR -150(A6)
-       MOVE.L  (A7)+,A6
-       TST.L   d0
-       bne     @success
-       bra     @end
-   @success:
-       move.b  #1,d0
-   @end:
-       move.b  d0,@RESULT
-   end;
-end;
+function OpenInfo: PInfoData;
+var
+  Port: PMsgPort;
+  Info: PInfoData;
+  Bptr1: BPTR;
+begin
+  Info := PInfoData(AllocMem(SizeOf(TInfoData)));
+
+  if Assigned(Info) then
+  begin
+    Port := PFileHandle(BADDR(DosInput()))^.fh_Type;
+    //GetConsoleTask;
+    Bptr1  := MKBADDR(Info);
+
+    if Assigned(Port) then
+    begin
+      if SendActionPacket(Port, Bptr1) = 0 then
+        Port := nil;
+    end;
 
-procedure ReplyMsg(mess : pMessage);
-begin
-   asm
-       MOVE.L  A6,-(A7)
-       MOVE.L  mess,a1
-       MOVE.L  _ExecBase,A6
-       JSR -378(A6)
-       MOVE.L  (A7)+,A6
-   end;
-end;
-
-
-function WaitPort(port : pMsgPort): pMessage;
-begin
-   asm
-       MOVE.L  A6,-(A7)
-       MOVE.L  port,a0
-       MOVE.L  _ExecBase,A6
-       JSR -384(A6)
-       MOVE.L  (A7)+,A6
-       MOVE.L  d0,@RESULT
-   end;
-end;
-
-procedure Delay_(ticks : Longint);
-begin
-   asm
-       MOVE.L  A6,-(A7)
-       MOVE.L  ticks,d1
-       MOVE.L  _DOSBase,A6
-       JSR -198(A6)
-       MOVE.L  (A7)+,A6
-   end;
+    if Port = nil then
+    begin
+      FreeMem(Info);
+      Info := nil;
+    end;
+  end;
+  OpenInfo := Info;
 end;
 
-function SetSignal(newSignals, signalMask : Longint) : Longint;
+procedure CloseInfo(var Info: PInfoData);
 begin
-   asm
-       MOVE.L  A6,-(A7)
-       MOVE.L  newSignals,d0
-       MOVE.L  signalMask,d1
-       MOVE.L  _ExecBase,A6
-       JSR -306(A6)
-       MOVE.L  (A7)+,A6
-       MOVE.L  d0,@RESULT
-   end;
-end;}
+  if Assigned(Info) then
+  begin
+    FreeMem(Info);
+    Info := nil;
+  end;
+end;
 
-function OpenInfo : pInfoData;
+function ConData(Modus: Byte): Integer;
 var
-   port     :  pMsgPort;
-   info     :  pInfoData;
-   bptr, d4, d5, d6, d7 :  Longint;
-begin
-   info  := pInfoData(AllocVec(SizeOf(tInfoData), 1));
-
-   if info <> nil then begin
-      port  := GetConsoleTask;
-      bptr  := Longint(info) shr 2;
-
-      if port <> nil then begin
-         if DoPkt(port, $19, bptr, d4, d5, d6, d7) <> 0 then info := pInfoData(bptr shl 2)
-         else port := nil;
-      end;
-
-      if port = nil then begin
-         FreeVec(info);
-         info := nil;
-      end;
-   end;
-
-   OpenInfo := info;
+  Info:  PInfoData;
+  TheUnit: PConUnit;
+  Pos: Longint;
+begin
+  pos := 1;
+  Info := OpenInfo;
+
+  if Assigned(Info) then
+  begin
+    TheUnit := PConUnit((PIoStdReq(Info^.id_InUse))^.io_Unit);
+    case modus of
+      CD_CURRX: pos := TheUnit^.cu_XCP;
+      CD_CURRY: pos := TheUnit^.cu_YCP;
+      CD_MAXX: pos := TheUnit^.cu_XMax;
+      CD_MAXY: pos := TheUnit^.cu_YMax;
+    end;
+    CloseInfo(Info);
+  end;
+  ConData := Pos + 1;
 end;
 
-procedure CloseInfo(var info : pInfoData);
+function WhereX: TCrtCoord;
 begin
-   if info <> nil then begin
-      FreeVec(info);
-      info := nil;
-   end;
+  WhereX := Byte(ConData(CD_CURRX)) - WindMinX;
 end;
 
-function ConData(modus : byte) : integer;
-var
-   info  :  pInfoData;
-   theunit  :  pConUnit;
-   pos   :  Longint;
+function RealX: Byte;
 begin
-   pos   := 1;
-   info  := OpenInfo;
-
-   if info <> nil then begin
-      theunit  := pConUnit((pIoStdReq(info^.id_InUse))^.io_Unit);
-
-      case modus of
-         CD_CURRX :  pos   := theunit^.cu_XCP;
-         CD_CURRY :  pos   := theunit^.cu_YCP;
-         CD_MAXX  :  pos   := theunit^.cu_XMax;
-         CD_MAXY  :  pos   := theunit^.cu_YMax;
-      end;
-
-      CloseInfo(info);
-   end;
-
-   ConData := pos + 1;
+  RealX := Byte(ConData(CD_CURRX));
 end;
 
-function WhereX : tcrtcoord;
+function RealY: Byte;
 begin
-   WhereX := Byte(ConData(CD_CURRX))-lo(windmin);
+  RealY := Byte(ConData(CD_CURRY));
 end;
 
-function realx: byte;
+function WhereY: TCrtCoord;
 begin
-   RealX := Byte(ConData(CD_CURRX));
+  WhereY := Byte(ConData(CD_CURRY)) - WindMinY;
 end;
 
-function realy: byte;
+function ScreenCols: Integer;
 begin
- RealY := Byte(ConData(CD_CURRY));
+  Screencols := ConData(CD_MAXX);
 end;
 
-function WhereY : tcrtcoord;
+function ScreenRows: Integer;
 begin
-   WhereY := Byte(ConData(CD_CURRY))-hi(windmin);
+  ScreenRows := ConData(CD_MAXY);
 end;
 
-function screencols : integer;
+procedure RealGotoXY(x, y: Integer);
 begin
-   screencols := ConData(CD_MAXX);
+  Write(CSI, y, ';', x, 'H');
 end;
 
-function screenrows : integer;
+procedure GotoXY(x, y: TCrtCoord);
 begin
-   screenrows := ConData(CD_MAXY);
+  if y + WindMinY - 2 >= WindMaxY then
+    y := WindMaxY - WindMinY + 1;
+  if x + WindMinX - 2 >= WindMaxX then
+    x := WindMaxX - WindMinX + 1;
+  Write(CSI, y + WindMinY, ';', x + WindMinX, 'H');
 end;
 
-
- procedure Realgotoxy(x,y : integer);
- begin
-       Write(CSI, y, ';', x, 'H');
- end;
-
-
- procedure gotoxy(x,y : tcrtcoord);
- begin
-        if (x<1) then
-          x:=1;
-        if (y<1) then
-          y:=1;
-        if y+hi(windmin)-2>=hi(windmax) then
-          y:=hi(windmax)-hi(windmin)+1;
-        if x+lo(windmin)-2>=lo(windmax) then
-          x:=lo(windmax)-lo(windmin)+1;
-        Write(CSI, y+hi(windmin), ';', x+lo(windmin), 'H');
- end;
-
-
 procedure CursorOff;
 begin
-   Write(CSI,'0 p');
+  Write(CSI,'0 p');
 end;
 
 procedure CursorOn;
 begin
-   Write(CSI,'1 p');
+  Write(CSI,' p');
 end;
 
 procedure ClrScr;
 begin
-   Write(Chr($0c));
+  Write(Chr($0c));
 end;
 
-function ReadKey : char;
-const
-   IDCMP_VANILLAKEY = $00200000;
-   IDCMP_RAWKEY     = $00000400;
+function WaitForKey: string;
 var
-   info  :  pInfoData;
-   win   :  pWindow;
-   imsg  :  pIntuiMessage;
-   msg   :  pMessage;
-   key   :  char;
-   idcmp, vanil   :  Longint;
-begin
-   key   := #0;
-   if KeyPress <> #0 then
-    Begin
-      ReadKey:=KeyPress;
-      KeyPress:=#0;
-      exit;
-    end;
-   info  := OpenInfo;
-
-   if info <> nil then begin
-      win   := pWindow(pConUnit((pIoStdReq(info^.id_InUse))^.io_Unit)^.cu_Window);
-      idcmp := win^.IDCMPFlags;
-      vanil := IDCMP_VANILLAKEY or IDCMP_RAWKEY;
-
-      ModifyIDCMP(win, (idcmp or vanil));
-
-      repeat
-         msg   := WaitPort(win^.UserPort);
-         imsg  := pIntuiMessage(GetMsg(win^.UserPort));
-
-         if (imsg^.IClass = IDCMP_VANILLAKEY) then
-              key := char(imsg^.Code)
-         else
-         if (imsg^.IClass = IDCMP_RAWKEY) then
-              key := char(imsg^.Code);
-
-         ReplyMsg(pMessage(imsg));
-      until key <> #0;
-
-      repeat
-         msg   := GetMsg(win^.UserPort);
-
-         if msg <> nil then ReplyMsg(msg);
-      until msg = nil;
-
-      ModifyIDCMP(win, idcmp);
-
-      CloseInfo(info);
-   end;
-
-   ReadKey := key;
+  OutP: BPTR; // Output file handle
+  Res: Char; // Char to get fropm console
+  Key: string; // result
+begin
+  Key := '';
+  OutP := DosOutput();
+  SetMode(OutP, 1); // change to Raw Mode
+  // Special for AROS
+  // AROS always sends a #184, #185 or #0, ignore them
+  repeat
+    Res := #0;
+    DosRead(OutP, @Res, 1);
+    if not (Ord(Res) in [184, 185, 0]) then
+      Break;
+    Delay(1);
+  until False;
+  // get the key
+  Key := Res;
+  // Check if Special OP
+  if Res = CSI then
+  begin
+    repeat
+      Res := #0;
+      DosRead(OutP, @Res, 1);
+      if Ord(Res) in [184, 185, 0] then // just to make sure on AROS that it ends when nothing left
+        Break;
+      if Ord(Res) = 126 then // end marker
+        Break;
+      Key := Key + Res; // add to final string
+      // stop on cursor, they have no end marker...
+      case Ord(Res) of
+        64..69,83,84: Break;
+      end;
+    until False;
+  end;
+  // set result
+  WaitForKey := Key;
+  // set back mode to CON:
+  SetMode(OutP, 0);
 end;
 
-function KeyPressed : Boolean;
+type
+  TKeyMap = record
+    con: string;
+    c1: Char;
+    c2: Char;
+  end;
 const
-   IDCMP_VANILLAKEY = $00200000;
-   IDCMP_RAWKEY     = $00000400;
+  KeyMapping: array[0..17] of TKeyMap =
+    ((con: #155'0'; c1: #0; c2:#59;), // F1
+     (con: #155'1'; c1: #0; c2:#60;), // F2
+     (con: #155'2'; c1: #0; c2:#61;), // F3
+     (con: #155'3'; c1: #0; c2:#62;), // F4
+     (con: #155'4'; c1: #0; c2:#63;), // F5
+     (con: #155'5'; c1: #0; c2:#64;), // F6
+     (con: #155'6'; c1: #0; c2:#65;), // F7
+     (con: #155'7'; c1: #0; c2:#66;), // F8
+     (con: #155'8'; c1: #0; c2:#67;), // F9
+     (con: #155'9'; c1: #0; c2:#68;), // F10
+     (con: #155'20'; c1: #0; c2:#133;), // F11
+     (con: #155'21'; c1: #0; c2:#134;), // F12
+
+     (con: #155'41'; c1: #0; c2:#73;), // Page Up
+     (con: #155'42'; c1: #0; c2:#81;), // Page Down
+
+     (con: #155'A'; c1: #0; c2:#72;), // Cursor Up
+     (con: #155'B'; c1: #0; c2:#80;), // Cursor Down
+     (con: #155'C'; c1: #0; c2:#77;), // Cursor Right
+     (con: #155'D'; c1: #0; c2:#75;)  // Cursor Left
+     );
+
+function ReadKey: Char;
 var
-   info  :  pInfoData;
-   win   :  pWindow;
-   imsg  :  pIntuiMessage;
-   msg   :  pMessage;
-   idcmp, vanil   :  Longint;
-   ispressed : Boolean;
-begin
-   KeyPress := #0;
-   ispressed := False;
-   info  := OpenInfo;
-
-   if info <> nil then begin
-      win   := pWindow(pConUnit((pIoStdReq(info^.id_InUse))^.io_Unit)^.cu_Window);
-      idcmp := win^.IDCMPFlags;
-      vanil := IDCMP_VANILLAKEY or IDCMP_RAWKEY;
-
-      ModifyIDCMP(win, (idcmp or vanil));
-
-      msg   := WaitPort(win^.UserPort);
-      imsg  := pIntuiMessage(GetMsg(win^.UserPort));
-
-      if (imsg^.IClass = IDCMP_VANILLAKEY) or (imsg^.IClass = IDCMP_RAWKEY) then
-      Begin
-        ispressed := true;
-        KeyPress := char(imsg^.Code)
-      end;
-
-      ReplyMsg(pMessage(imsg));
-
-      repeat
-         msg   := GetMsg(win^.UserPort);
-
-         if msg <> nil then ReplyMsg(msg);
-      until msg = nil;
-
-      ModifyIDCMP(win, idcmp);
+  Res: string;
+  i: Integer;
+begin
+  // we got a key to sent
+  if Length(LastKeys) > 0 then
+  begin
+    ReadKey := LastKeys[1];
+    Delete(LastKeys, 1, 1);
+    Exit;
+  end;
+  Res := WaitForKey;
+  // Search for Map Key
+  for i := 0 to High(KeyMapping) do
+  begin
+    if KeyMapping[i].Con = Res then
+    begin
+      ReadKey := KeyMapping[i].c1;
+      if KeyMapping[i].c2 <> #0 then
+        LastKeys := KeyMapping[i].c2;
+      Exit;
+    end;
+  end;
+  ReadKey := Res[1];
+end;
 
-      CloseInfo(info);
-   end;
 
-   KeyPressed := ispressed;
+// Wait for Key, does not work for AROS currently
+// because WaitForChar ALWAYS returns even no key is pressed, but this
+// is clearly an AROS bug
+function KeyPressed : Boolean;
+var
+  OutP: BPTR;
+begin
+  if Length(LastKeys) > 0 then
+  begin
+    KeyPressed := True;
+    Exit;
+  end;
+  OutP := DosOutput();
+  SetMode(OutP, 1);
+  // Wait one millisecond for the key (-1 = timeout)
+  {$if defined(MorphOS) or defined(Amiga68k))}
+  KeyPressed := WaitForChar(OutP, 1);
+  {$else}
+  KeyPressed := WaitForChar(OutP, 1) <> 0;
+  {$endif}
+  SetMode(OutP, 0);
+end;
+
+function ConvertColor(Color: Byte): Byte;
+begin
+  Color := Color and $f; // make sure we are in the 0..7 range
+  // make some color mappings
+  case Color of
+     White: ConvertColor := 2;
+     Black: ConvertColor := 1;
+     Blue: ConvertColor := 3;
+     LightGray: ConvertColor := 0;
+     Red: ConvertColor := RedPen;
+     Green: ConvertColor := GreenPen;
+  else
+    ConvertColor := Color;
+  end;
+end;
+
+function ConvertColorBack(Color: Byte): Byte;
+begin
+  Color := Color and $f;
+  case Color of
+     2 : ConvertColorBack := White;
+     1: ConvertColorBack := Black;
+     3: ConvertColorBack := Blue;
+     0: ConvertColorBack := LightGray;
+  else
+    if Color = RedPen then ConvertColorBack := Red else
+    if color = GreenPen then ConvertColorBack := Green else
+    ConvertColorBack := Color;
+  end;
 end;
 
 procedure TextColor(color : byte);
 begin
-   TextAttr := (TextAttr and $70) or color;
-   Write(CSI, '3', color, 'm');
+  Color := ConvertColor(Color);
+  TextAttr := (TextAttr and $70) or Color;
+  Write(CSI, '3', color, 'm');
 end;
 
 procedure TextBackground(color : byte);
 begin
-   Textattr:=(textattr and $8f) or ((color and $7) shl 4);
-   Write(CSI, '4', color, 'm');
+  Color := ConvertColor(Color);
+  Textattr:=(textattr and $8f) or ((Color and $7) shl 4);
+  Write(CSI, '4', color, 'm');
 end;
 
-procedure Window(X1,Y1,X2,Y2: Byte);
- begin
-   if (x1<1) or (x2>screencols) or (y2>screenrows) or
-     (x1>x2) or (y1>y2) then
-       exit;
-   windmin:=(x1-1) or ((y1-1) shl 8);
-   windmax:=(x2-1) or ((y2-1) shl 8);
-   gotoxy(1,1);
- end;
-
+function GetTextBackground: Byte;
+var
+  Info: PInfoData;
+  Pen: Byte;
+begin
+  pen := 1;
+  Info := OpenInfo;
+  if Assigned(Info)then
+  begin
+    Pen := PConUnit((PIoStdReq(Info^.id_InUse))^.io_Unit)^.cu_BgPen;
+    Pen := ConvertColorBack(Pen);
+    CloseInfo(Info);
+  end;
+  GetTextBackground := Pen;
+end;
 
+function GetTextColor: Byte;
+var
+  Info: PInfoData;
+  Pen: Byte;
+begin
+  Pen := 1;
+  Info := OpenInfo;
+  if Assigned(info) then
+  begin
+    Pen := PConUnit((PIoStdReq(Info^.id_InUse))^.io_Unit)^.cu_FgPen;
+    Pen := ConvertColorBack(Pen);
+    CloseInfo(Info);
+  end;
+  GetTextColor := Pen;
+end;
 
+procedure Window(X1,Y1,X2,Y2: Byte);
+begin
+  if x1 < 1 then
+    x1 := 1;
+  if y1 < 1 then
+    y1 := 1;
+  if (x2 > ScreenCols) or (y2 > ScreenRows) or (x1 > x2) or (y1 > y2) then
+    Exit;
+  WindMinX := x1 - 1;
+  WindMinY := y1 - 1;
+  WindMaxX := x2 - 1;
+  WindMaxY := y2 - 1;
+  GotoXY(1, 1);
+end;
 
 
 procedure DelLine;
 begin
-   Write(CSI,'X');
+  Write(CSI,'X');
 end;
 
 procedure ClrEol;
 begin
-   Write(CSI,'K');
+  Write(CSI,'K');
 end;
 
 procedure InsLine;
 begin
-   Write(CSI,'1 L');
+  Write(CSI,'1 L');
 end;
 
-procedure cursorbig;
+procedure CursorBig;
 begin
 end;
 
-procedure lowvideo;
+procedure LowVideo;
 begin
 end;
 
-procedure highvideo;
+procedure HighVideo;
 begin
 end;
 
-procedure nosound;
+procedure NoSound;
 begin
 end;
 
-procedure sound(hz : word);
+procedure Sound(hz: Word);
 begin
 end;
 
-procedure delay(ms : Word);
-var
-    dummy : Longint;
+procedure NormVideo;
 begin
-    dummy := trunc((real(ms) / 1000.0) * 50.0);
-    DOSDelay(dummy);
 end;
 
-{function CheckBreak : boolean;
+procedure AssignCrt(var F: Text);
 begin
-   if (SetSignal(0, 0) and SIGBREAKF_CTRL_C) = SIGBREAKF_CTRL_C then
-      CheckBreak := true
-   else
-      CheckBreak := false;
-end;}
-
-procedure textmode(mode : word);
-begin
-       lastmode:=mode;
-       mode:=mode and $ff;
-       windmin:=0;
-       windmax:=(screencols-1) or ((screenrows-1) shl 8);
-       maxcols:=screencols;
-       maxrows:=screenrows;
 end;
 
-procedure normvideo;
+procedure Delay(ms: Word);
+var
+  Dummy: Longint;
 begin
+  dummy := Trunc((ms / 1000.0) * 50.0);
+  DOSDelay(dummy);
 end;
 
-function GetTextBackground : byte;
-var
-   info  :  pInfoData;
-   pen   :  byte;
+procedure TextMode(Mode: word);
 begin
-   pen   := 1;
-   info  := OpenInfo;
-
-   if info <> nil then begin
-      pen   := pConUnit((pIoStdReq(info^.id_InUse))^.io_Unit)^.cu_BgPen;
-
-      CloseInfo(info);
-   end;
-
-   GetTextBackground := pen;
+  LastMode := Mode;
+  Mode := Mode and $ff;
+  MaxCols := ScreenCols;
+  MaxRows := ScreenRows;
+  WindMinX := 0;
+  WindMinY := 0;
+  WindMaxX := MaxCols - 1;
+  WindMaxY := MaxRows - 1;
 end;
 
-function GetTextColor : byte;
-var
-   info  :  pInfoData;
-   pen   :  byte;
-begin
-   pen   := 1;
-   info  := OpenInfo;
-
-   if info <> nil then begin
-      pen   := pConUnit((pIoStdReq(info^.id_InUse))^.io_Unit)^.cu_FgPen;
-
-      CloseInfo(info);
-   end;
-
-   GetTextColor   := pen;
-end;
-
-
-{*****************************************************************************
-                          Read and Write routines
-*****************************************************************************}
-{ Problem here: Currently all these routines are not implemented because of how }
-{ the console device works. Because w low level write is required to change the }
-{ position of the cursor, and since the CrtWrite is assigned as the standard    }
-{ write routine, a recursive call will occur                                    }
-
-{ How to fix this:                                                              }
-{  At startup make a copy of the Output handle, and then use this copy to make  }
-{  low level positioning calls. This does not seem to work yet.                 }
-
-
-
-   Function CrtWrite(var f : textrec):integer;
-
-      var
-         i,col,row : longint;
-         c : char;
-         buf: array[0..1] of char;
-
-      begin
-         col:=realx;
-         row:=realy;
-         inc(row);
-         inc(col);
-         for i:=0 to f.bufpos-1 do
-           begin
-              c:=f.buffer[i];
-              case ord(c) of
-                 10 : begin
-                         inc(row);
-                      end;
-                 13 : begin
-                         col:=lo(windmin)+1;
-                     end;
-                 8 : if col>lo(windmin)+1 then
-                       begin
-                          dec(col);
-                       end;
-                 7 : begin
-                         { beep }
-                         asm
-                           move.l a6,d6               { save base pointer    }
-                           move.l _IntuitionBase,a6   { set library base     }
-                           sub.l  a0,a0
-                           jsr    _LVODisplayBeep(a6)
-                           move.l d6,a6               { restore base pointer }
-                         end;
-                      end;
-              else
-                 begin
-                   buf[0]:=c;
-                   realgotoxy(row,col);
-                   {do_write(f.handle,longint(@buf[0]),1);}
-                   inc(col);
-                 end;
-              end;
-              if col>lo(windmax)+1 then
-                begin
-                   col:=lo(windmin)+1;
-                   inc(row);
-                end;
-              while row>hi(windmax)+1 do
-                begin
-                   delline;
-                   dec(row);
-                end;
-           end;
-         f.bufpos:=0;
-         realgotoxy(row-1,col-1);
-         CrtWrite:=0;
-      end;
-
-   Function CrtClose(Var F: TextRec): Integer;
-     Begin
-       F.Mode:=fmClosed;
-       CrtClose:=0;
-     End;
-
-   Function CrtOpen(Var F: TextRec): Integer;
-     Begin
-       If F.Mode = fmOutput Then
-        CrtOpen:=0
-       Else
-        CrtOpen:=5;
-     End;
-
-   Function CrtRead(Var F: TextRec): Integer;
-     Begin
-       {f.bufend:=do_read(f.handle,longint(f.bufptr),f.bufsize);}
-       f.bufpos:=0;
-       CrtRead:=0;
-     End;
-
-   Function CrtInOut(Var F: TextRec): Integer;
-     Begin
-       Case F.Mode of
-        fmInput: CrtInOut:=CrtRead(F);
-        fmOutput: CrtInOut:=CrtWrite(F);
-       End;
-     End;
-
-   procedure assigncrt(var f : text);
-     begin
-   {     TextRec(F).Mode:=fmClosed;
-        TextRec(F).BufSize:=SizeOf(TextBuf);
-        TextRec(F).BufPtr:=@TextRec(F).Buffer;
-        TextRec(F).BufPos:=0;
-        TextRec(F).OpenFunc:=@CrtOpen;
-        TextRec(F).InOutFunc:=@CrtInOut;
-        TextRec(F).FlushFunc:=@CrtInOut;
-        TextRec(F).CloseFunc:=@CrtClose;
-        TextRec(F).Name[0]:='.';
-        TextRec(F).Name[1]:=#0;}
-     end;
-
-
+function GetClosestPen(r,g,b: Byte): ShortInt;
 var
-  old_exit : pointer;
-
-procedure crt_exit;
-begin
-  { Restore default colors }
+  i: Byte;
+  cm: PColorMap;
+  AR, AG, AB: Byte;
+  Col: LongInt;
+  MinDist, Dist: LongInt;
+begin
+  GetClosestPen := -1;
+  cm := IntuitionBase^.ActiveScreen^.ViewPort.ColorMap;
+  MinDist := MaxInt;
+  for i := 2 to 7 do
+  begin
+    Col := GetRGB4(CM, i);
+    if Col = -1 then
+      Continue;
+    AR := (Col shr 8) and $F;
+    AR := AR or (AR shl 4);
+    AG := (Col shr 4) and $F;
+    AG := AG or (AR shl 4);
+    AB := (Col shr 0) and $F;
+    AB := AB or (AR shl 4);
+    Dist := Abs(AR-r) + Abs(AG-g) + Abs(AB-b);
+    if Dist < MinDist then
+    begin
+      GetClosestPen := i;
+      MinDist := Dist;
+    end;
+  end;
+end;
+
+initialization
+  // Init Colors, (until now only Red and Green)
+  RedPen := ObtainPen(IntuitionBase^.ActiveScreen^.ViewPort.ColorMap, 7, $FFFFFFFF, 0, 0, 0);
+  FreeRed := RedPen >= 0;
+  if not FreeRed then
+    RedPen := GetClosestPen($ff,00,00);
+  //
+  GreenPen := ObtainPen(IntuitionBase^.ActiveScreen^.ViewPort.ColorMap, 6, 0, $FFFFFFFF, 0, 0);
+  FreeGreen := GreenPen >= 0;
+  if not FreeRed then
+    GreenPen := GetClosestPen(00,$ff,00);
+
+  // load system variables to temporary variables to save time
+  MaxCols := ScreenCols;
+  MaxRows := ScreenRows;
+  // Set the initial text attributes
+  // Text background
+  Textattr:=(textattr and $8f) or ((GetTextBackGround and $7) shl 4);
+  // Text foreground
+  TextAttr := (TextAttr and $70) or GetTextColor;
+  // set output window
+  WindMaxX := MaxCols - 1;
+  WindMaxY := MaxRows - 1;
+
+finalization
+  if FreeRed then
+    ReleasePen(IntuitionBase^.ActiveScreen^.ViewPort.ColorMap, RedPen);
+  if FreeGreen then
+    ReleasePen(IntuitionBase^.ActiveScreen^.ViewPort.ColorMap, GreenPen);
   write(CSI,'0m');
-  exitproc:=old_exit;
-end;
-
-
-Begin
-   old_exit:=exitproc;
-   exitproc:=@crt_exit;
-   { load system variables to temporary variables to save time }
-   maxcols:=screencols;
-   maxrows:=screenrows;
-   { Set the initial text attributes }
-   { Text background }
-   Textattr:=(textattr and $8f) or ((GetTextBackGround and $7) shl 4);
-   { Text foreground }
-   TextAttr := (TextAttr and $70) or GetTextColor;
-   { set output window }
-   windmax:=(maxcols-1) or (( maxrows-1) shl 8);
-
-
-   { Get a copy of the standard      }
-   { output handle, and when using   }
-   { direct console calls, use this  }
-   { handle instead.                 }
-{   assigncrt(Output);
-   TextRec(Output).mode:=fmOutput;}
+  CursorOn;
 end.