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

--- Merging r43812 into '.':

Browse Source 
U    packages/amunits/src/coreunits/console.pas
U    packages/amunits/src/coreunits/conunit.pas
--- Recording mergeinfo for merge of r43812 into '.':
 U   .
--- Merging r43814 into '.':
U    packages/rtl-console/fpmake.pp
U    packages/rtl-console/src/amiga/crt.pp
--- Recording mergeinfo for merge of r43814 into '.':
 G   .
--- Merging r43815 into '.':
U    packages/arosunits/fpmake.pp
A    packages/arosunits/src/console.pas
A    packages/arosunits/src/conunit.pas
U    packages/morphunits/fpmake.pp
A    packages/morphunits/src/console.pas
A    packages/morphunits/src/conunit.pas
U    packages/os4units/fpmake.pp
A    packages/os4units/src/console.pas
A    packages/os4units/src/conunit.pas
G    packages/rtl-console/fpmake.pp
A    packages/rtl-console/src/amicommon/crt.pp
D    packages/rtl-console/src/amiga
--- Recording mergeinfo for merge of r43815 into '.':
 G   .
--- Merging r43827 into '.':
G    packages/rtl-console/fpmake.pp
U    packages/rtl-console/src/amicommon/crt.pp
--- Recording mergeinfo for merge of r43827 into '.':
 G   .
--- Merging r43847 into '.':
G    packages/rtl-console/src/amicommon/crt.pp
--- Recording mergeinfo for merge of r43847 into '.':
 G   .
--- Merging r43854 into '.':
G    packages/rtl-console/src/amicommon/crt.pp
--- Recording mergeinfo for merge of r43854 into '.':
 G   .
--- Merging r43876 into '.':
G    packages/rtl-console/src/amicommon/crt.pp
--- Recording mergeinfo for merge of r43876 into '.':
 G   .

# revisions: 43812,43814,43815,43827,43847,43854,43876

git-svn-id: branches/fixes_3_2@43959 -
This commit is contained in:
marco 2020-01-16 17:33:51 +00:00
parent d79fe2a393
commit 01cb09e1a0
15 changed files with 1727 additions and 1078 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
.gitattributes vendored
View File

@ -1097,6 +1097,8 @@ packages/arosunits/src/amigados.pas svneol=native#text/plain
packages/arosunits/src/asl.pas svneol=native#text/plain packages/arosunits/src/asl.pas svneol=native#text/plain
packages/arosunits/src/clipboard.pas svneol=native#text/plain packages/arosunits/src/clipboard.pas svneol=native#text/plain
packages/arosunits/src/commodities.pas svneol=native#text/pascal packages/arosunits/src/commodities.pas svneol=native#text/pascal
packages/arosunits/src/console.pas svneol=native#text/plain
packages/arosunits/src/conunit.pas svneol=native#text/plain
packages/arosunits/src/cybergraphics.pas svneol=native#text/plain packages/arosunits/src/cybergraphics.pas svneol=native#text/plain
packages/arosunits/src/datatypes.pas svneol=native#text/pascal packages/arosunits/src/datatypes.pas svneol=native#text/pascal
packages/arosunits/src/diskfont.pas svneol=native#text/plain packages/arosunits/src/diskfont.pas svneol=native#text/plain
@ -6277,6 +6279,8 @@ packages/morphunits/src/asl.pas svneol=native#text/plain
packages/morphunits/src/cgxvideo.pas svneol=native#text/plain packages/morphunits/src/cgxvideo.pas svneol=native#text/plain
packages/morphunits/src/clipboard.pas svneol=native#text/plain packages/morphunits/src/clipboard.pas svneol=native#text/plain
packages/morphunits/src/commodities.pas svneol=native#text/pascal packages/morphunits/src/commodities.pas svneol=native#text/pascal
packages/morphunits/src/console.pas svneol=native#text/plain
packages/morphunits/src/conunit.pas svneol=native#text/plain
packages/morphunits/src/cybergraphics.pas svneol=native#text/plain packages/morphunits/src/cybergraphics.pas svneol=native#text/plain
packages/morphunits/src/datatypes.pas svneol=native#text/plain packages/morphunits/src/datatypes.pas svneol=native#text/plain
packages/morphunits/src/diskfont.pas svneol=native#text/plain packages/morphunits/src/diskfont.pas svneol=native#text/plain
@ -6769,6 +6773,8 @@ packages/os4units/src/agraphics.pas svneol=native#text/pascal
packages/os4units/src/amigados.pas svneol=native#text/pascal packages/os4units/src/amigados.pas svneol=native#text/pascal
packages/os4units/src/asl.pas svneol=native#text/pascal packages/os4units/src/asl.pas svneol=native#text/pascal
packages/os4units/src/clipboard.pas svneol=native#text/pascal packages/os4units/src/clipboard.pas svneol=native#text/pascal
packages/os4units/src/console.pas svneol=native#text/plain
packages/os4units/src/conunit.pas svneol=native#text/plain
packages/os4units/src/cybergraphics.pas svneol=native#text/pascal packages/os4units/src/cybergraphics.pas svneol=native#text/pascal
packages/os4units/src/datatypes.pas svneol=native#text/pascal packages/os4units/src/datatypes.pas svneol=native#text/pascal
packages/os4units/src/diskfont.pas svneol=native#text/pascal packages/os4units/src/diskfont.pas svneol=native#text/pascal
@ -7386,11 +7392,11 @@ packages/rtl-console/Makefile svneol=native#text/plain
packages/rtl-console/Makefile.fpc svneol=native#text/plain packages/rtl-console/Makefile.fpc svneol=native#text/plain
packages/rtl-console/Makefile.fpc.fpcmake svneol=native#text/plain packages/rtl-console/Makefile.fpc.fpcmake svneol=native#text/plain
packages/rtl-console/fpmake.pp svneol=native#text/plain packages/rtl-console/fpmake.pp svneol=native#text/plain
packages/rtl-console/src/amicommon/crt.pp svneol=native#text/plain
packages/rtl-console/src/amicommon/keyboard.pp svneol=native#text/plain packages/rtl-console/src/amicommon/keyboard.pp svneol=native#text/plain
packages/rtl-console/src/amicommon/mouse.pp svneol=native#text/plain packages/rtl-console/src/amicommon/mouse.pp svneol=native#text/plain
packages/rtl-console/src/amicommon/video.pp svneol=native#text/plain packages/rtl-console/src/amicommon/video.pp svneol=native#text/plain
packages/rtl-console/src/amicommon/videodata.inc svneol=native#text/plain packages/rtl-console/src/amicommon/videodata.inc svneol=native#text/plain
packages/rtl-console/src/amiga/crt.pp svneol=native#text/plain
packages/rtl-console/src/emx/crt.pp svneol=native#text/plain packages/rtl-console/src/emx/crt.pp svneol=native#text/plain
packages/rtl-console/src/go32v2/crt.pp svneol=native#text/plain packages/rtl-console/src/go32v2/crt.pp svneol=native#text/plain
packages/rtl-console/src/go32v2/keyboard.pp svneol=native#text/plain packages/rtl-console/src/go32v2/keyboard.pp svneol=native#text/plain

141
packages/amunits/src/coreunits/console.pas
View File

@ -18,112 +18,103 @@
To call the two routines defined below, you'll need to set To call the two routines defined below, you'll need to set
ConsoleBase to an appropriate value. ConsoleBase to an appropriate value.
Added the define use_amiga_smartlink.
13 Jan 2003.
nils.sjoholm@mailbox.swipnet.se Nils Sjoholm nils.sjoholm@mailbox.swipnet.se Nils Sjoholm
} }
unit console; unit console;
INTERFACE interface
uses exec, inputevent, keymap;
uses
exec, inputevent, keymap;
const const
{***** Console commands *****} {***** Console commands *****}
CD_ASKKEYMAP = CMD_NONSTD + 0;
CD_ASKKEYMAP = CMD_NONSTD + 0; CD_SETKEYMAP = CMD_NONSTD + 1;
CD_SETKEYMAP = CMD_NONSTD + 1; CD_ASKDEFAULTKEYMAP = CMD_NONSTD + 2;
CD_ASKDEFAULTKEYMAP = CMD_NONSTD + 2; CD_SETDEFAULTKEYMAP = CMD_NONSTD + 3;
CD_SETDEFAULTKEYMAP = CMD_NONSTD + 3;
{***** SGR parameters *****} {***** SGR parameters *****}
SGR_PRIMARY = 0; SGR_PRIMARY = 0;
SGR_BOLD = 1; SGR_BOLD = 1;
SGR_ITALIC = 3; SGR_ITALIC = 3;
SGR_UNDERSCORE = 4; SGR_UNDERSCORE = 4;
SGR_NEGATIVE = 7; SGR_NEGATIVE = 7;
SGR_NORMAL = 22; { default foreground color, not bold } SGR_NORMAL = 22; // default foreground color, not bold
SGR_NOTITALIC = 23; SGR_NOTITALIC = 23;
SGR_NOTUNDERSCORE = 24; SGR_NOTUNDERSCORE = 24;
SGR_POSITIVE = 27; SGR_POSITIVE = 27;
{ these names refer to the ANSI standard, not the implementation } { these names refer to the ANSI standard, not the implementation }
SGR_BLACK = 30; SGR_BLACK = 30;
SGR_RED = 31; SGR_RED = 31;
SGR_GREEN = 32; SGR_GREEN = 32;
SGR_YELLOW = 33; SGR_YELLOW = 33;
SGR_BLUE = 34; SGR_BLUE = 34;
SGR_MAGENTA = 35; SGR_MAGENTA = 35;
SGR_CYAN = 36; SGR_CYAN = 36;
SGR_WHITE = 37; SGR_WHITE = 37;
SGR_DEFAULT = 39; SGR_DEFAULT = 39;
SGR_BLACKBG = 40; SGR_BLACKBG = 40;
SGR_REDBG = 41; SGR_REDBG = 41;
SGR_GREENBG = 42; SGR_GREENBG = 42;
SGR_YELLOWBG = 43; SGR_YELLOWBG = 43;
SGR_BLUEBG = 44; SGR_BLUEBG = 44;
SGR_MAGENTABG = 45; SGR_MAGENTABG = 45;
SGR_CYANBG = 46; SGR_CYANBG = 46;
SGR_WHITEBG = 47; SGR_WHITEBG = 47;
SGR_DEFAULTBG = 49; SGR_DEFAULTBG = 49;
{ these names refer to the implementation, they are the preferred } { these names refer to the implementation, they are the preferred }
{ names for use with the Amiga console device. } { names for use with the Amiga console device. }
SGR_CLR0 = 30; SGR_CLR0 = 30;
SGR_CLR1 = 31; SGR_CLR1 = 31;
SGR_CLR2 = 32; SGR_CLR2 = 32;
SGR_CLR3 = 33; SGR_CLR3 = 33;
SGR_CLR4 = 34; SGR_CLR4 = 34;
SGR_CLR5 = 35; SGR_CLR5 = 35;
SGR_CLR6 = 36; SGR_CLR6 = 36;
SGR_CLR7 = 37; SGR_CLR7 = 37;
SGR_CLR0BG = 40;
SGR_CLR1BG = 41;
SGR_CLR2BG = 42;
SGR_CLR3BG = 43;
SGR_CLR4BG = 44;
SGR_CLR5BG = 45;
SGR_CLR6BG = 46;
SGR_CLR7BG = 47;
SGR_CLR0BG = 40;
SGR_CLR1BG = 41;
SGR_CLR2BG = 42;
SGR_CLR3BG = 43;
SGR_CLR4BG = 44;
SGR_CLR5BG = 45;
SGR_CLR6BG = 46;
SGR_CLR7BG = 47;
{***** DSR parameters *****} {***** DSR parameters *****}
DSR_CPR = 6;
DSR_CPR = 6;
{***** CTC parameters *****} {***** CTC parameters *****}
CTC_HSETTAB = 0;
CTC_HSETTAB = 0; CTC_HCLRTAB = 2;
CTC_HCLRTAB = 2; CTC_HCLRTABSALL = 5;
CTC_HCLRTABSALL = 5;
{***** TBC parameters *****} {***** TBC parameters *****}
TBC_HCLRTAB = 0;
TBC_HCLRTAB = 0; TBC_HCLRTABSALL = 3;
TBC_HCLRTABSALL = 3;
{***** SM and RM parameters *****} {***** SM and RM parameters *****}
M_LNM = 20; // linefeed newline mode
M_ASM = '>1'; // auto scroll mode
M_AWM = '?7'; // auto wrap mode
M_LNM = 20; { linefeed newline mode } var
M_ASM = '>1'; { auto scroll mode } ConsoleDevice: PDevice = nil;
M_AWM = '?7'; { auto wrap mode }
VAR ConsoleDevice : pDevice; function CDInputHandler(Events: PInputEvent location 'a0'; ConsoleDev: PLibrary location 'a1'): PInputEvent; syscall ConsoleDevice 042;
function RawKeyConvert(Events: PInputEvent location 'a0'; Buffer: PCHAR location 'a1'; Length: LongInt location 'd1'; KeyMap: PKeyMap location 'a2'): LongInt; syscall ConsoleDevice 048;
FUNCTION CDInputHandler(events : pInputEvent location 'a0'; consoleDev : pLibrary location 'a1') : pInputEvent; syscall ConsoleDevice 042; implementation
FUNCTION RawKeyConvert(events : pInputEvent location 'a0'; buffer : pCHAR location 'a1'; length : LONGINT location 'd1'; keyMap : pKeyMap location 'a2') : LONGINT; syscall ConsoleDevice 048;
IMPLEMENTATION end.
END. (* UNIT CONSOLE *)

131
packages/amunits/src/coreunits/conunit.pas
View File

@ -13,97 +13,82 @@
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************} **********************************************************************}
{
History:
Changed integer > smallint.
09 Feb 2003.
}
unit conunit; unit conunit;
INTERFACE interface
uses exec, console, keymap, inputevent; uses
exec, console, keymap, inputevent, intuition, agraphics;
const const
{ ---- console unit numbers for OpenDevice() } { ---- console unit numbers for OpenDevice() }
CONU_LIBRARY = -1; { no unit, just fill in IO_DEVICE field } CONU_LIBRARY = -1; // no unit, just fill in IO_DEVICE field
CONU_STANDARD = 0; { standard unmapped console } CONU_STANDARD = 0; // standard unmapped console
{ ---- New unit numbers for OpenDevice() - (V36) } { ---- New unit numbers for OpenDevice() - (V36) }
CONU_CHARMAP = 1; // bind character map to console
CONU_CHARMAP = 1; { bind character map to console } CONU_SNIPMAP = 3; // bind character map w/ snip to console
CONU_SNIPMAP = 3; { bind character map w/ snip to console }
{ ---- New flag defines for OpenDevice() - (V37) } { ---- New flag defines for OpenDevice() - (V37) }
CONFLAG_DEFAULT = 0;
CONFLAG_NODRAW_ON_NEWSIZE = 1;
CONFLAG_DEFAULT = 0; PMB_ASM = M_LNM + 1; // internal storage bit for AS flag
CONFLAG_NODRAW_ON_NEWSIZE = 1; PMB_AWM = PMB_ASM + 1; // internal storage bit for AW flag
MAXTABS = 80;
PMB_ASM = M_LNM + 1; { internal storage bit for AS flag }
PMB_AWM = PMB_ASM + 1; { internal storage bit for AW flag }
MAXTABS = 80;
type type
{$PACKRECORDS 2}
PConUnit = ^TConUnit;
TConUnit = record
cu_MP: TMsgPort;
{ ---- read only variables }
cu_Window: PWindow; // Intuition window bound to this unit
cu_XCP: SmallInt; // character position
cu_YCP: SmallInt;
cu_XMax: SmallInt; // max character position
cu_YMax: SmallInt;
cu_XRSize: SmallInt; // character raster size
cu_YRSize: SmallInt;
cu_XROrigin: SmallInt; // raster origin
cu_YROrigin: SmallInt;
cu_XRExtant: SmallInt; // raster maxima
cu_YRExtant: SmallInt;
cu_XMinShrink: SmallInt; // smallest area intact from resize process
cu_YMinShrink: SmallInt;
cu_XCCP: SmallInt; // cursor position
cu_YCCP: SmallInt;
pConUnit = ^tConUnit; { ---- read/write variables (writes must must be protected) }
tConUnit = record { ---- storage for AskKeyMap and SetKeyMap }
cu_MP : tMsgPort; cu_KeyMapStruct: TKeyMap;
{ ---- read only variables } { ---- tab stops }
cu_Window : Pointer; { (WindowPtr) intuition window bound to this unit } cu_TabStops: array[0..MAXTABS - 1] of Word; // 0 at start, 0xFFFF at end of list
cu_XCP : smallint; { character position }
cu_YCP : smallint;
cu_XMax : smallint; { max character position }
cu_YMax : smallint;
cu_XRSize : smallint; { character raster size }
cu_YRSize : smallint;
cu_XROrigin : smallint; { raster origin }
cu_YROrigin : smallint;
cu_XRExtant : smallint; { raster maxima }
cu_YRExtant : smallint;
cu_XMinShrink : smallint; { smallest area intact from resize process }
cu_YMinShrink : smallint;
cu_XCCP : smallint; { cursor position }
cu_YCCP : smallint;
{ ---- read/write variables (writes must must be protected) } // ---- console rastport attributes
{ ---- storage for AskKeyMap and SetKeyMap } cu_Mask: ShortInt;
cu_FgPen: ShortInt;
cu_BgPen: ShortInt;
cu_AOLPen: ShortInt;
cu_DrawMode: ShortInt;
cu_Obsolete1: ShortInt; // was cu_AreaPtSz -- not used in V36
cu_Obsolete2: APTR; // was cu_AreaPtrn -- not used in V36
cu_Minterms: array[0..7] of Byte; // console minterms
cu_Font: PTextFont;
cu_AlgoStyle: Byte;
cu_TxFlags: Byte;
cu_TxHeight: Word;
cu_TxWidth: Word;
cu_TxBaseline: Word;
cu_TxSpacing: Word;
cu_KeyMapStruct : tKeyMap; { ---- 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;
{ ---- tab stops } implementation
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;
IMPLEMENTATION
end. end.

2
packages/arosunits/fpmake.pp
View File

@ -56,6 +56,8 @@ begin
T:=P.Targets.AddUnit('commodities.pas'); T:=P.Targets.AddUnit('commodities.pas');
T:=P.Targets.AddUnit('datatypes.pas'); T:=P.Targets.AddUnit('datatypes.pas');
T:=P.Targets.AddUnit('serial.pas'); T:=P.Targets.AddUnit('serial.pas');
T:=P.Targets.AddUnit('console.pas');
T:=P.Targets.AddUnit('conunit.pas');
{$ifndef ALLPACKAGES} {$ifndef ALLPACKAGES}
Run; Run;

124
packages/arosunits/src/console.pas Normal file
View File

@ -0,0 +1,124 @@
{
This file is part of the Free Pascal run time library.
A file in Amiga system run time library.
Copyright (c) 1998-2003 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.
**********************************************************************}
{
To call the two routines defined below, you'll need to set
ConsoleBase to an appropriate value.
nils.sjoholm@mailbox.swipnet.se Nils Sjoholm
}
unit console;
interface
uses
exec, inputevent, keymap, utility, amigados;
const
{***** Console commands *****}
CD_ASKKEYMAP = CMD_NONSTD + 0;
CD_SETKEYMAP = CMD_NONSTD + 1;
CD_ASKDEFAULTKEYMAP = CMD_NONSTD + 2;
CD_SETDEFAULTKEYMAP = CMD_NONSTD + 3;
{***** SGR parameters *****}
SGR_PRIMARY = 0;
SGR_BOLD = 1;
SGR_ITALIC = 3;
SGR_UNDERSCORE = 4;
SGR_NEGATIVE = 7;
SGR_NORMAL = 22; // default foreground color, not bold
SGR_NOTITALIC = 23;
SGR_NOTUNDERSCORE = 24;
SGR_POSITIVE = 27;
{ these names refer to the ANSI standard, not the implementation }
SGR_BLACK = 30;
SGR_RED = 31;
SGR_GREEN = 32;
SGR_YELLOW = 33;
SGR_BLUE = 34;
SGR_MAGENTA = 35;
SGR_CYAN = 36;
SGR_WHITE = 37;
SGR_DEFAULT = 39;
SGR_BLACKBG = 40;
SGR_REDBG = 41;
SGR_GREENBG = 42;
SGR_YELLOWBG = 43;
SGR_BLUEBG = 44;
SGR_MAGENTABG = 45;
SGR_CYANBG = 46;
SGR_WHITEBG = 47;
SGR_DEFAULTBG = 49;
{ these names refer to the implementation, they are the preferred }
{ names for use with the Amiga console device. }
SGR_CLR0 = 30;
SGR_CLR1 = 31;
SGR_CLR2 = 32;
SGR_CLR3 = 33;
SGR_CLR4 = 34;
SGR_CLR5 = 35;
SGR_CLR6 = 36;
SGR_CLR7 = 37;
SGR_CLR0BG = 40;
SGR_CLR1BG = 41;
SGR_CLR2BG = 42;
SGR_CLR3BG = 43;
SGR_CLR4BG = 44;
SGR_CLR5BG = 45;
SGR_CLR6BG = 46;
SGR_CLR7BG = 47;
{***** DSR parameters *****}
DSR_CPR = 6;
{***** CTC parameters *****}
CTC_HSETTAB = 0;
CTC_HCLRTAB = 2;
CTC_HCLRTABSALL = 5;
{***** TBC parameters *****}
TBC_HCLRTAB = 0;
TBC_HCLRTABSALL = 3;
{***** SM and RM parameters *****}
M_LNM = 20; // linefeed newline mode
M_ASM = '>1'; // auto scroll mode
M_AWM = '?7'; // auto wrap mode
var
ConsoleDevice: PDevice = nil;
function CDInputHandler(Events: PInputEvent; CDIhData: APTR): PInputEvent; syscall ConsoleDevice 7;
function RawKeyConvert(Events: PInputEvent; Buffer: PChar; Length: LongInt; KeyMap: PKeyMap): LongInt; syscall ConsoleDevice 8;
function GetConSnip(): APTR; syscall ConsoleDevice 84;
function SetConSnip(Param: APTR): LongInt; syscall ConsoleDevice 88;
procedure AddConSnipHook(Hook: PHook); syscall ConsoleDevice 92;
procedure RemConSnipHook(Hook: PHook); syscall ConsoleDevice 96;
implementation
end.

94
packages/arosunits/src/conunit.pas Normal file
View File

@ -0,0 +1,94 @@
{
This file is part of the Free Pascal run time library.
A file in Amiga system run time library.
Copyright (c) 1998 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 conunit;
interface
uses
exec, console, keymap, inputevent, intuition, agraphics;
const
{ ---- console unit numbers for OpenDevice() }
CONU_LIBRARY = -1; // no unit, just fill in IO_DEVICE field
CONU_STANDARD = 0; // standard unmapped console
{ ---- New unit numbers for OpenDevice() - (V36) }
CONU_CHARMAP = 1; // bind character map to console
CONU_SNIPMAP = 3; // bind character map w/ snip to console
{ ---- New flag defines for OpenDevice() - (V37) }
CONFLAG_DEFAULT = 0;
CONFLAG_NODRAW_ON_NEWSIZE = 1;
PMB_ASM = M_LNM + 1; // internal storage bit for AS flag
PMB_AWM = PMB_ASM + 1; // internal storage bit for AW flag
MAXTABS = 80;
type
{$PACKRECORDS 2}
PConUnit = ^TConUnit;
TConUnit = record
cu_MP: TMsgPort;
{ ---- read only variables }
cu_Window: PWindow; // Intuition window bound to this unit
cu_XCP: SmallInt; // character position
cu_YCP: SmallInt;
cu_XMax: SmallInt; // max character position
cu_YMax: SmallInt;
cu_XRSize: SmallInt; // character raster size
cu_YRSize: SmallInt;
cu_XROrigin: SmallInt; // raster origin
cu_YROrigin: SmallInt;
cu_XRExtant: SmallInt; // raster maxima
cu_YRExtant: SmallInt;
cu_XMinShrink: SmallInt; // smallest area intact from resize process
cu_YMinShrink: SmallInt;
cu_XCCP: SmallInt; // cursor position
cu_YCCP: SmallInt;
{ ---- 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, 0xFFFF at end of list
// ---- console rastport attributes
cu_Mask: ShortInt;
cu_FgPen: ShortInt;
cu_BgPen: ShortInt;
cu_AOLPen: ShortInt;
cu_DrawMode: ShortInt;
cu_Obsolete1: ShortInt; // was cu_AreaPtSz -- not used in V36
cu_Obsolete2: APTR; // was cu_AreaPtrn -- not used in V36
cu_Minterms: array[0..7] of Byte; // console minterms
cu_Font: PTextFont;
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;
implementation
end.

2
packages/morphunits/fpmake.pp
View File

@ -61,6 +61,8 @@ begin
T:=P.Targets.AddUnit('locale.pas'); T:=P.Targets.AddUnit('locale.pas');
T:=P.Targets.AddUnit('commodities.pas'); T:=P.Targets.AddUnit('commodities.pas');
T:=P.Targets.AddUnit('serial.pas'); T:=P.Targets.AddUnit('serial.pas');
T:=P.Targets.AddUnit('console.pas');
T:=P.Targets.AddUnit('conunit.pas');
{$ifndef ALLPACKAGES} {$ifndef ALLPACKAGES}
Run; Run;

120
packages/morphunits/src/console.pas Normal file
View File

@ -0,0 +1,120 @@
{
This file is part of the Free Pascal run time library.
A file in Amiga system run time library.
Copyright (c) 1998-2003 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.
**********************************************************************}
{
To call the two routines defined below, you'll need to set
ConsoleBase to an appropriate value.
nils.sjoholm@mailbox.swipnet.se Nils Sjoholm
}
unit console;
interface
uses
exec, inputevent, keymap;
const
{***** Console commands *****}
CD_ASKKEYMAP = CMD_NONSTD + 0;
CD_SETKEYMAP = CMD_NONSTD + 1;
CD_ASKDEFAULTKEYMAP = CMD_NONSTD + 2;
CD_SETDEFAULTKEYMAP = CMD_NONSTD + 3;
{***** SGR parameters *****}
SGR_PRIMARY = 0;
SGR_BOLD = 1;
SGR_ITALIC = 3;
SGR_UNDERSCORE = 4;
SGR_NEGATIVE = 7;
SGR_NORMAL = 22; // default foreground color, not bold
SGR_NOTITALIC = 23;
SGR_NOTUNDERSCORE = 24;
SGR_POSITIVE = 27;
{ these names refer to the ANSI standard, not the implementation }
SGR_BLACK = 30;
SGR_RED = 31;
SGR_GREEN = 32;
SGR_YELLOW = 33;
SGR_BLUE = 34;
SGR_MAGENTA = 35;
SGR_CYAN = 36;
SGR_WHITE = 37;
SGR_DEFAULT = 39;
SGR_BLACKBG = 40;
SGR_REDBG = 41;
SGR_GREENBG = 42;
SGR_YELLOWBG = 43;
SGR_BLUEBG = 44;
SGR_MAGENTABG = 45;
SGR_CYANBG = 46;
SGR_WHITEBG = 47;
SGR_DEFAULTBG = 49;
{ these names refer to the implementation, they are the preferred }
{ names for use with the Amiga console device. }
SGR_CLR0 = 30;
SGR_CLR1 = 31;
SGR_CLR2 = 32;
SGR_CLR3 = 33;
SGR_CLR4 = 34;
SGR_CLR5 = 35;
SGR_CLR6 = 36;
SGR_CLR7 = 37;
SGR_CLR0BG = 40;
SGR_CLR1BG = 41;
SGR_CLR2BG = 42;
SGR_CLR3BG = 43;
SGR_CLR4BG = 44;
SGR_CLR5BG = 45;
SGR_CLR6BG = 46;
SGR_CLR7BG = 47;
{***** DSR parameters *****}
DSR_CPR = 6;
{***** CTC parameters *****}
CTC_HSETTAB = 0;
CTC_HCLRTAB = 2;
CTC_HCLRTABSALL = 5;
{***** TBC parameters *****}
TBC_HCLRTAB = 0;
TBC_HCLRTABSALL = 3;
{***** SM and RM parameters *****}
M_LNM = 20; // linefeed newline mode
M_ASM = '>1'; // auto scroll mode
M_AWM = '?7'; // auto wrap mode
var
ConsoleDevice: PDevice = nil;
function CDInputHandler(Events: PInputEvent location 'a0'; ConsoleDev: PLibrary location 'a1'): PInputEvent; syscall ConsoleDevice 42;
function RawKeyConvert(Events: PInputEvent location 'a0'; Buffer: PChar location 'a1'; Length: LongInt location 'd1'; KeyMap: PKeyMap location 'a2'): LongInt; syscall ConsoleDevice 48;
implementation
end.

94
packages/morphunits/src/conunit.pas Normal file
View File

@ -0,0 +1,94 @@
{
This file is part of the Free Pascal run time library.
A file in Amiga system run time library.
Copyright (c) 1998 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 conunit;
interface
uses
exec, console, keymap, inputevent, intuition, agraphics;
const
{ ---- console unit numbers for OpenDevice() }
CONU_LIBRARY = -1; // no unit, just fill in IO_DEVICE field
CONU_STANDARD = 0; // standard unmapped console
{ ---- New unit numbers for OpenDevice() - (V36) }
CONU_CHARMAP = 1; // bind character map to console
CONU_SNIPMAP = 3; // bind character map w/ snip to console
{ ---- New flag defines for OpenDevice() - (V37) }
CONFLAG_DEFAULT = 0;
CONFLAG_NODRAW_ON_NEWSIZE = 1;
PMB_ASM = M_LNM + 1; // internal storage bit for AS flag
PMB_AWM = PMB_ASM + 1; // internal storage bit for AW flag
MAXTABS = 80;
type
{$PACKRECORDS 2}
PConUnit = ^TConUnit;
TConUnit = record
cu_MP: TMsgPort;
{ ---- read only variables }
cu_Window: PWindow; // Intuition window bound to this unit
cu_XCP: SmallInt; // character position
cu_YCP: SmallInt;
cu_XMax: SmallInt; // max character position
cu_YMax: SmallInt;
cu_XRSize: SmallInt; // character raster size
cu_YRSize: SmallInt;
cu_XROrigin: SmallInt; // raster origin
cu_YROrigin: SmallInt;
cu_XRExtant: SmallInt; // raster maxima
cu_YRExtant: SmallInt;
cu_XMinShrink: SmallInt; // smallest area intact from resize process
cu_YMinShrink: SmallInt;
cu_XCCP: SmallInt; // cursor position
cu_YCCP: SmallInt;
{ ---- 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, 0xFFFF at end of list
// ---- console rastport attributes
cu_Mask: ShortInt;
cu_FgPen: ShortInt;
cu_BgPen: ShortInt;
cu_AOLPen: ShortInt;
cu_DrawMode: ShortInt;
cu_Obsolete1: ShortInt; // was cu_AreaPtSz -- not used in V36
cu_Obsolete2: APTR; // was cu_AreaPtrn -- not used in V36
cu_Minterms: array[0..7] of Byte; // console minterms
cu_Font: PTextFont;
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;
implementation
end.

2
packages/os4units/fpmake.pp
View File

@ -52,6 +52,8 @@ begin
T:=P.Targets.AddUnit('locale.pas'); T:=P.Targets.AddUnit('locale.pas');
T:=P.Targets.AddUnit('datatypes.pas'); T:=P.Targets.AddUnit('datatypes.pas');
T:=P.Targets.AddUnit('serial.pas'); T:=P.Targets.AddUnit('serial.pas');
T:=P.Targets.AddUnit('console.pas');
T:=P.Targets.AddUnit('conunit.pas');
{$ifndef ALLPACKAGES} {$ifndef ALLPACKAGES}
Run; Run;

125
packages/os4units/src/console.pas Normal file
View File

@ -0,0 +1,125 @@
{
This file is part of the Free Pascal run time library.
A file in Amiga system run time library.
Copyright (c) 1998-2003 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.
**********************************************************************}
{
To call the two routines defined below, you'll need to set
ConsoleBase to an appropriate value.
nils.sjoholm@mailbox.swipnet.se Nils Sjoholm
}
unit console;
interface
uses
exec, inputevent, keymap;
const
{***** Console commands *****}
CD_ASKKEYMAP = CMD_NONSTD + 0;
CD_SETKEYMAP = CMD_NONSTD + 1;
CD_ASKDEFAULTKEYMAP = CMD_NONSTD + 2;
CD_SETDEFAULTKEYMAP = CMD_NONSTD + 3;
{***** SGR parameters *****}
SGR_PRIMARY = 0;
SGR_BOLD = 1;
SGR_ITALIC = 3;
SGR_UNDERSCORE = 4;
SGR_NEGATIVE = 7;
SGR_NORMAL = 22; // default foreground color, not bold
SGR_NOTITALIC = 23;
SGR_NOTUNDERSCORE = 24;
SGR_POSITIVE = 27;
{ these names refer to the ANSI standard, not the implementation }
SGR_BLACK = 30;
SGR_RED = 31;
SGR_GREEN = 32;
SGR_YELLOW = 33;
SGR_BLUE = 34;
SGR_MAGENTA = 35;
SGR_CYAN = 36;
SGR_WHITE = 37;
SGR_DEFAULT = 39;
SGR_BLACKBG = 40;
SGR_REDBG = 41;
SGR_GREENBG = 42;
SGR_YELLOWBG = 43;
SGR_BLUEBG = 44;
SGR_MAGENTABG = 45;
SGR_CYANBG = 46;
SGR_WHITEBG = 47;
SGR_DEFAULTBG = 49;
{ these names refer to the implementation, they are the preferred }
{ names for use with the Amiga console device. }
SGR_CLR0 = 30;
SGR_CLR1 = 31;
SGR_CLR2 = 32;
SGR_CLR3 = 33;
SGR_CLR4 = 34;
SGR_CLR5 = 35;
SGR_CLR6 = 36;
SGR_CLR7 = 37;
SGR_CLR0BG = 40;
SGR_CLR1BG = 41;
SGR_CLR2BG = 42;
SGR_CLR3BG = 43;
SGR_CLR4BG = 44;
SGR_CLR5BG = 45;
SGR_CLR6BG = 46;
SGR_CLR7BG = 47;
{***** DSR parameters *****}
DSR_CPR = 6;
{***** CTC parameters *****}
CTC_HSETTAB = 0;
CTC_HCLRTAB = 2;
CTC_HCLRTABSALL = 5;
{***** TBC parameters *****}
TBC_HCLRTAB = 0;
TBC_HCLRTABSALL = 3;
{***** SM and RM parameters *****}
M_LNM = 20; // linefeed newline mode
M_ASM = '>1'; // auto scroll mode
M_AWM = '?7'; // auto wrap mode
var
ConsoleDevice: PDevice = nil;
IConsoleDevice: Pointer = nil;
function CDInputHandler(Events: PInputEvent; ConsoleDev: PLibrary): PInputEvent; syscall IConsoleDevice 76;
function RawKeyConvert(Events: PInputEvent; Buffer: PChar; Length: LongInt; KeyMap: PKeyMap): LongInt; syscall IConsoleDevice 80;
function GetConSnip(): APTR; syscall ConsoleDevice 9;
function SetConSnip(Param: APTR): LongInt; syscall ConsoleDevice 10;
procedure AddConSnipHook(Hook: PHook); syscall ConsoleDevice 11;
procedure RemConSnipHook(Hook: PHook); syscall ConsoleDevice 12;
implementation
end.

94
packages/os4units/src/conunit.pas Normal file
View File

@ -0,0 +1,94 @@
{
This file is part of the Free Pascal run time library.
A file in Amiga system run time library.
Copyright (c) 1998 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 conunit;
interface
uses
exec, console, keymap, inputevent, intuition, agraphics;
const
{ ---- console unit numbers for OpenDevice() }
CONU_LIBRARY = -1; // no unit, just fill in IO_DEVICE field
CONU_STANDARD = 0; // standard unmapped console
{ ---- New unit numbers for OpenDevice() - (V36) }
CONU_CHARMAP = 1; // bind character map to console
CONU_SNIPMAP = 3; // bind character map w/ snip to console
{ ---- New flag defines for OpenDevice() - (V37) }
CONFLAG_DEFAULT = 0;
CONFLAG_NODRAW_ON_NEWSIZE = 1;
PMB_ASM = M_LNM + 1; // internal storage bit for AS flag
PMB_AWM = PMB_ASM + 1; // internal storage bit for AW flag
MAXTABS = 80;
type
{$PACKRECORDS 2}
PConUnit = ^TConUnit;
TConUnit = record
cu_MP: TMsgPort;
{ ---- read only variables }
cu_Window: PWindow; // Intuition window bound to this unit
cu_XCP: SmallInt; // character position
cu_YCP: SmallInt;
cu_XMax: SmallInt; // max character position
cu_YMax: SmallInt;
cu_XRSize: SmallInt; // character raster size
cu_YRSize: SmallInt;
cu_XROrigin: SmallInt; // raster origin
cu_YROrigin: SmallInt;
cu_XRExtant: SmallInt; // raster maxima
cu_YRExtant: SmallInt;
cu_XMinShrink: SmallInt; // smallest area intact from resize process
cu_YMinShrink: SmallInt;
cu_XCCP: SmallInt; // cursor position
cu_YCCP: SmallInt;
{ ---- 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, 0xFFFF at end of list
// ---- console rastport attributes
cu_Mask: ShortInt;
cu_FgPen: ShortInt;
cu_BgPen: ShortInt;
cu_AOLPen: ShortInt;
cu_DrawMode: ShortInt;
cu_Obsolete1: ShortInt; // was cu_AreaPtSz -- not used in V36
cu_Obsolete2: APTR; // was cu_AreaPtrn -- not used in V36
cu_Minterms: array[0..7] of Byte; // console minterms
cu_Font: PTextFont;
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;
implementation
end.

6
packages/rtl-console/fpmake.pp
View File

@ -15,8 +15,8 @@ Const
WinEventOSes = [win32,win64]; WinEventOSes = [win32,win64];
KVMAll = [emx,go32v2,msdos,netware,netwlibc,os2,win32,win64,win16]+UnixLikes+AllAmigaLikeOSes; KVMAll = [emx,go32v2,msdos,netware,netwlibc,os2,win32,win64,win16]+UnixLikes+AllAmigaLikeOSes;
// all full KVMers have crt too, except Amigalikes // all full KVMers have crt too
CrtOSes = KVMALL+[WatCom]-[aros,morphos,amiga]; CrtOSes = KVMALL+[WatCom];
KbdOSes = KVMALL; KbdOSes = KVMALL;
VideoOSes = KVMALL; VideoOSes = KVMALL;
MouseOSes = KVMALL; MouseOSes = KVMALL;
@ -24,8 +24,6 @@ Const
rtl_consoleOSes =KVMALL+CrtOSes+TermInfoOSes; rtl_consoleOSes =KVMALL+CrtOSes+TermInfoOSes;
// Amiga has a crt in its RTL dir, but it is commented in the makefile
Var Var
P : TPackage; P : TPackage;
T : TTarget; T : TTarget;

937
packages/rtl-console/src/amicommon/crt.pp Normal file
View File

@ -0,0 +1,937 @@
{
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.
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 crt;
interface
{$i crth.inc}
implementation
uses
exec, amigados, Utility, conunit, intuition, agraphics;
var
MaxCols, MaxRows: LongInt;
type
TANSIColor = record
r,g,b: Byte;
m: Byte; // pen on MorphOS
o: Byte; // Pen on AmigaOS4
end;
const
AnsiColors: array[0..15] of TANSIColor = (
(r:000; g:000; b:000; m:016; o:000), // 0 = Black
(r:000; g:000; b:170; m:019; o:004), // 1 = Blue
(r:000; g:170; b:000; m:034; o:002), // 2 = Green
(r:000; g:170; b:170; m:037; o:006), // 3 = Cyan
(r:170; g:000; b:000; m:124; o:001), // 4 = Red
(r:170; g:000; b:170; m:127; o:005), // 5 = Magenta
(r:170; g:085; b:000; m:130; o:103), // 6 = Brown
(r:170; g:170; b:170; m:249; o:107), // 7 = Light Gray
(r:085; g:085; b:085; m:240; o:107), // 8 = Dark Gray
(r:000; g:000; b:255; m:021; o:104), // 9 = LightBlue
(r:000; g:255; b:000; m:046; o:102), // 10 = LightGreen
(r:000; g:255; b:255; m:087; o:106), // 11 = LightCyan
(r:255; g:000; b:000; m:196; o:101), // 12 = LightRed
(r:255; g:000; b:255; m:201; o:105), // 13 = LightMagenta
(r:255; g:255; b:000; m:226; o:003), // 14 = Yellow
(r:255; g:255; b:255; m:231; o:007) // 15 = White
);
const
CD_CURRX = 1;
CD_CURRY = 2;
CD_MAXX = 3;
CD_MAXY = 4;
// Special Character for commands to console
CSI = Chr($9b);
var
// multiple keys
LastKeys: string = '';
Pens: array[0..15] of LongInt;
FGPen: Byte = Black;
BGPen: Byte = LightGray;
function IntToStr(i: LongInt): AnsiString;
var
s: AnsiString;
begin
Str(i, s);
IntToStr := s;
end;
function SendActionPacket(Port: PMsgPort; Arg: BPTR): LongInt;
var
ReplyPort: PMsgPort;
Packet: PStandardPacket;
Ret: NativeInt;
begin
SendActionPacket := 0;
ReplyPort := CreateMsgPort;
if not Assigned(ReplyPort) then
Exit;
Packet := AllocMem(SizeOf(TStandardPacket));
if not Assigned(Packet) then
begin
DeleteMsgPort(ReplyPort);
Exit;
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);
Ret := Packet^.sp_Pkt.dp_Res1;
FreeMem(Packet);
DeleteMsgPort(ReplyPort);
SendActionPacket := Ret;
end;
function GetConUnit: PConUnit;
var
Port: PMsgPort;
Info: PInfoData;
Bptr1: BPTR;
begin
Info := PInfoData(AllocMem(SizeOf(TInfoData)));
GetConUnit := nil;
//
if Assigned(Info) then
begin
{$ifdef AmigaOS4}
Port := PFileHandle(BADDR(DosInput()))^.fh_MsgPort;
{$else}
Port := PFileHandle(BADDR(DosInput()))^.fh_Type;
{$endif}
//GetConsoleTask;
Bptr1 := MKBADDR(Info);
if Assigned(Port) then
begin
if SendActionPacket(Port, Bptr1) = 0 then
Port := nil;
end;
if Port = nil then
begin
FreeMem(Info);
Info := nil;
Exit;
end;
GetConUnit := PConUnit((PIoStdReq(Info^.id_InUse))^.io_Unit);
end;
FreeMem(Info);
end;
{$if defined(MorphOS)}
//Extract two Integer Values from string ";" separated and space at end
function GetIntValues(Text: AnsiString; var Val1: LongInt; var Val2: LongInt): Boolean;
var
Start, Ende: LongInt;
n: Integer;
begin
GetIntValues := False;
// First Value
Start := 1;
Ende := Pos(';', Text);
Val(Copy(Text, Start, Ende - Start), Val1, n);
if n <> 0 then
Exit;
// Second Value
Start := Ende + 1;
Ende := Pos(' ', Text);
if Ende <= 0 then
Ende := Length(Text) + 1;
Val(Copy(Text, Start, Ende - Start), Val2, n);
if n <> 0 then
Exit;
GetIntValues := True;
end;
{$endif}
// Get the size of Display, this time, MorphOS is broken :(
// does not support ConUnit, is always nil, so we use the slow, error prune way directly via console commands
function GetDisplaySize: TPoint;
{$ifdef MorphOS}
var
Pt: TPoint;
fh: BPTR;
Actual: Integer;
Width, Height: LongInt;
report: array[0..25] of Char;
ToSend: AnsiString;
Start, Ende: LongInt;
begin
Pt.X := 2;
Pt.Y := 2;
fh := DosOutput();
if fh <> 0 then
begin
//SetMode(fh, 1); // RAW mode
ToSend := Chr($9b)+'0 q';
if DosWrite(fh, @ToSend[1], Length(ToSend)) > 0 then
begin
actual := DosRead(fh, @report[0], 25);
if actual >= 0 then
begin
report[actual] := #0;
// Search for position of display message
Start := 0;
Ende := 0;
while Ende < actual do
begin
if Report[Ende] = Chr($9b) then
Start := Ende;
if Report[Ende] = 'r' then
begin
Report[Ende] := #0;
Break;
end;
Inc(Ende);
end;
// skip over #$9b'1;1;'
if GetIntValues(PChar(@report[Start + 5]), Height, Width) then
begin
Pt.X := Width + 1;
Pt.Y := Height + 1;
end
else
sysdebugln('scan failed. ' + PChar(@report[Start + 5]));
end;
//SetMode(fh, 0); // Normal mode
end;
end;
GetDisplaySize := Pt;
MaxCols := Pt.X;
MaxRows := Pt.Y;
end;
{$else}
var
Pt: TPoint;
TheUnit: PConUnit;
begin
Pt.X := 2;
Pt.Y := 2;
TheUnit := GetConUnit;
if Assigned(TheUnit) then
begin
Pt.X := TheUnit^.cu_XMax + 1;
Pt.Y := TheUnit^.cu_YMax + 1;
end;
GetDisplaySize := Pt;
MaxCols := Pt.X;
MaxRows := Pt.Y;
end;
{$endif}
// Get the current position of caret, this time, MorphOS is broken :(
// does not support ConUnit, is always nil, so we use the slow, error prune way directly via console commands
function GetCurrentPosition: TPoint;
{$ifdef MorphOS}
var
Pt: TPoint;
fh: BPTR;
Actual: Integer;
PosX, PosY: LongInt;
report: array[0..25] of Char;
ToSend: AnsiString;
Start, Ende: LongInt;
begin
Pt.X := 2;
Pt.Y := 2;
fh := DosOutput();
if fh <> 0 then
begin
//SetMode(fh, 1); // RAW mode
ToSend := Chr($9b)+'6n';
if DosWrite(fh, @ToSend[1], Length(ToSend)) > 0 then
begin
actual := DosRead(fh, @report[0], 25);
if actual >= 0 then
begin
report[actual] := #0;
// search for the position message
Start := 0;
Ende := 0;
while Ende < actual do
begin
if Report[Ende] = Chr($9b) then
Start := Ende;
if Report[Ende] = 'R' then
begin
Report[Ende] := ' ';
Break;
end;
Inc(Ende);
end;
// skip over #$9b
if GetIntValues(PChar(@report[Start + 1]), PosY, PosX) then
begin
Pt.X := PosX;
Pt.Y := PosY;
end
else
sysdebugln('scan failed. ' + PChar(@report[Start + 1]));
end;
//SetMode(fh, 0); // Normal mode
end;
end;
GetCurrentPosition := Pt;
end;
{$else}
var
Pt: TPoint;
TheUnit: PConUnit;
begin
Pt.X := 1;
Pt.Y := 1;
TheUnit := GetConUnit;
if Assigned(TheUnit) then
begin
Pt.X := TheUnit^.cu_Xcp + 1;
Pt.Y := TheUnit^.cu_Ycp + 1;
end;
GetCurrentPosition := Pt;
end;
{$endif}
procedure InternalWrite(s: AnsiString);
begin
DosWrite(DosOutput(), @s[1], Length(s));
end;
function RealX: Byte;
begin
RealX := Byte(GetCurrentPosition.X);
end;
function WhereX: TCrtCoord;
begin
WhereX := Byte(RealX) - WindMinX;
end;
function RealY: Byte;
begin
RealY := Byte(GetCurrentPosition.Y);
end;
function WhereY: TCrtCoord;
begin
WhereY := Byte(RealY) - WindMinY;
end;
function ScreenCols: Integer;
begin
Screencols := MaxCols;
end;
function ScreenRows: Integer;
begin
ScreenRows := MaxRows;
end;
procedure RealGotoXY(x, y: Integer);
begin
InternalWrite(CSI + IntToStr(y) + ';' + IntToStr(x) + 'H');
end;
procedure GotoXY(x, y: TCrtCoord);
begin
if y + WindMinY - 2 >= WindMaxY then
y := WindMaxY - WindMinY + 1;
if x + WindMinX - 2 >= WindMaxX then
x := WindMaxX - WindMinX + 1;
InternalWrite(CSI + IntToStr(y + WindMinY) + ';' + IntToStr(x + WindMinX) + 'H');
end;
procedure CursorOff;
begin
InternalWrite(CSI + '0 p');
end;
procedure CursorOn;
begin
InternalWrite(CSI + ' p');
end;
procedure ClrScr;
var
i: Integer;
begin
for i := 1 to (WindMaxY - WindMinY) + 1 do
begin
GotoXY(1, i);
InternalWrite(StringOfChar(' ', WindMaxX - WindMinX + 1));
end;
GotoXY(1, 1);
end;
function WaitForKey: string;
var
OutP: BPTR; // Output file handle
Res: Char; // Char to get from 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;
type
TKeyMap = record
con: string;
c1: Char;
c2: Char;
end;
const
KeyMapping: array[0..37] of TKeyMap =
((con: #127; c1: #0; c2:#83;), // Del
(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'10'; c1: #0; c2:#84;), // Shift F1
(con: #155'11'; c1: #0; c2:#85;), // Shift F2
(con: #155'12'; c1: #0; c2:#86;), // Shift F3
(con: #155'13'; c1: #0; c2:#87;), // Shift F4
(con: #155'14'; c1: #0; c2:#88;), // Shift F5
(con: #155'15'; c1: #0; c2:#89;), // Shift F6
(con: #155'16'; c1: #0; c2:#90;), // Shift F7
(con: #155'17'; c1: #0; c2:#91;), // Shift F8
(con: #155'18'; c1: #0; c2:#92;), // Shift F9
(con: #155'19'; c1: #0; c2:#93;), // Shift F10
(con: #155'30'; c1: #0; c2:#135;), // Shift F11
(con: #155'31'; c1: #0; c2:#136;), // Shift F12
(con: #155'40'; c1: #0; c2:#82;), // Ins
(con: #155'44'; c1: #0; c2:#71;), // Home
(con: #155'45'; c1: #0; c2:#70;), // End
(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
(con: #155'T'; c1: #0; c2:#65;), // Shift Cursor Up
(con: #155'S'; c1: #0; c2:#66;), // Shift Cursor Down
(con: #155' A'; c1: #0; c2:#67;), // Shift Cursor Right
(con: #155' @'; c1: #0; c2:#68;) // Shift Cursor Left
);
function ReadKey: Char;
var
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;
// 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(AROS)}
KeyPressed := WaitForChar(OutP, 1) <> 0;
{$else}
KeyPressed := WaitForChar(OutP, 1);
{$endif}
//SetMode(OutP, 0);
end;
procedure TextColor(color : byte);
{$ifndef MorphOS}
var
TheUnit: PConUnit;
{$endif}
begin
Color := Color and $F;
FGPen := Color;
{$ifdef MorphOS}
InternalWrite(CSI + '38;5;'+ IntToStr(AnsiColors[Color].m) + 'm');
{$else}
{$ifdef AmigaOS4}
if AnsiColors[Color].o > 100 then
InternalWrite(CSI + '1;3'+ IntToStr(AnsiColors[Color].o - 100) + 'm')
else
InternalWrite(CSI + '22;3'+ IntToStr(AnsiColors[Color].o) + 'm')
{$else}
if Pens[Color] < 0 then
Pens[Color] := ObtainBestPen(IntuitionBase^.ActiveScreen^.ViewPort.ColorMap, AnsiColors[color].r shl 24, AnsiColors[color].g shl 24, AnsiColors[color].b shl 24, [TAG_END]);
TheUnit := GetConUnit;
if Assigned(TheUnit) then
begin
if Pens[Color] >= 0 then
begin
TheUnit^.cu_Mask := -1; // set the mask to show all colors!
TheUnit^.cu_FgPen := Pens[Color]
end
else
begin
TheUnit^.cu_FgPen := 2;
SysDebugLn('Cannot obtain Text Pen ' + IntToStr(color) + ' use default');
end;
end
else
SysDebugLn('ConUnit not found');
{$endif} // AmigaOS4
{$endif} // MorphOS
end;
procedure TextBackground(color : byte);
{$ifndef MorphOS}
var
TheUnit: PConUnit;
{$endif}
begin
Color := Color and $F;
BGPen := Color;
{$ifdef MorphOS}
InternalWrite(CSI + '48;5;'+ IntToStr(AnsiColors[Color].m) + 'm');
{$else}
{$ifdef AmigaOS4}
if AnsiColors[Color].o > 100 then
InternalWrite(CSI + '1;4'+ IntToStr(AnsiColors[Color].o - 100) + 'm')
else
InternalWrite(CSI + '22;4'+ IntToStr(AnsiColors[Color].o) + 'm')
{$else}
if Pens[Color] < 0 then
Pens[Color] := ObtainBestPen(IntuitionBase^.ActiveScreen^.ViewPort.ColorMap, AnsiColors[color].r shl 24, AnsiColors[color].g shl 24, AnsiColors[color].b shl 24, [TAG_END]);
TheUnit := GetConUnit;
if Assigned(TheUnit) then
begin
if Pens[Color] >= 0 then
begin
TheUnit^.cu_Mask := -1; // set the mask to show all colors!
TheUnit^.cu_BgPen := Pens[Color]
end
else
begin
TheUnit^.cu_FgPen := 0;
SysDebugLn('Cannot obtain Background Pen ' + IntToStr(color) + ' use default');
end;
end
else
SysDebugLn('ConUnit not found');
{$endif} // AmigaOS4
{$endif} // MorphOS
end;
function GetTextBackground: Byte;
begin
GetTextBackground := BGPen;
end;
function GetTextColor: Byte;
begin
GetTextColor := FGPen;
end;
procedure Window(X1,Y1,X2,Y2: Byte);
begin
if x2 > ScreenCols then
x2 := ScreenCols;
if y2 > ScreenRows then
y2 := ScreenRows;
WindMinX := x1 - 1;
WindMinY := y1 - 1;
WindMaxX := x2 - 1;
WindMaxY := y2 - 1;
GotoXY(1, 1);
end;
procedure DelLine;
begin
InternalWrite(CSI + 'X');
end;
procedure ClrEol;
begin
InternalWrite(CSI + 'K');
end;
procedure InsLine;
begin
InternalWrite(CSI + '1 L');
end;
procedure CursorBig;
begin
end;
procedure LowVideo;
begin
end;
procedure HighVideo;
begin
end;
procedure NoSound;
begin
end;
procedure Sound(hz: Word);
begin
end;
procedure NormVideo;
begin
end;
procedure Delay(ms: Word);
var
Dummy: Longint;
begin
dummy := Trunc((ms / 1000.0) * 50.0);
DOSDelay(dummy);
end;
procedure TextMode(Mode: word);
begin
LastMode := Mode;
Mode := Mode and $ff;
MaxCols := ScreenCols;
MaxRows := ScreenRows;
WindMinX := 0;
WindMinY := 0;
WindMaxX := MaxCols - 1;
WindMaxY := MaxRows - 1;
end;
procedure WriteChar(c: Char; var Curr: TPoint; var s: AnsiString);
//var
// i: Integer;
var
isEmpty: boolean;
begin
IsEmpty := Length(s) = 0;
// ignore #13, we only use #10
case c of
#13: Exit;
#7: begin
DisplayBeep(nil);
Exit;
end;
#8: begin
if Length(s) > 0 then
begin
Delete(s, Length(s), 1);
Dec(Curr.X);
Exit;
end;
end;
else
begin
// all other Chars
s := s + c;
//sysdebugln(' Char: ' + c + ' ' + IntToStr(Curr.X) + ' ' + IntToStr(Curr.Y) + ' - ' + IntToStr(WindMinY) + ' ' + IntToStr(WindMaxY));
case c of
#10: begin
if WindMinX > 0 then
s := s + CSI + IntToStr(WindMinX) + 'C';
Curr.X := WindMinX + 1;
if Curr.Y <= WindMaxY then
Inc(Curr.Y)
else
begin
// only start at top again for smaller windows
if WindMaxY < MaxRows - 1 then
Curr.Y := WindMinY + 1;
s := s + CSI + IntToStr(Curr.Y) + ';' + IntToStr(WindMinX + 1) + 'H';
if not isEmpty then
s := s + StringOfChar(' ', WindMaxX - WindMinX + 1);
end;
if isEmpty then
s := s + StringOfChar(' ', WindMaxX - WindMinX);
s := s + CSI + IntToStr(Curr.Y) + ';' + IntToStr(Curr.X) + 'H';
end;
#8: begin
Curr.X := RealX;
end;
else
begin
Inc(Curr.X);
end;
end;
end;
end;
// wrap line
if Curr.X > (WindMaxX + 1) then
begin
if Curr.Y <= WindMaxY - 1 then
Inc(Curr.Y);
s := s + CSI + IntToStr(Curr.Y) + ';' + IntToStr(WindMinX + 1) + 'H' + CSI + 'K';
//sysdebugln('clear 2');
Curr.X := WindMinX + 1;
end;
end;
procedure CrtWrite(Var F: TextRec);
var
i: Smallint;
Curr: TPoint;
s: AnsiString;
begin
Curr := GetCurrentPosition;
s := '';
for i := 0 to f.BufPos - 1 do
WriteChar(F.Buffer[i], Curr, s);
InternalWrite(s);
F.BufPos := 0;
end;
Procedure CrtRead(Var F: TextRec);
var
ch : Char;
procedure BackSpace;
begin
if (f.bufpos>0) and (f.bufpos=f.bufend) then
begin
InternalWrite(#8);
InternalWrite(' ');
InternalWrite(#8);
dec(f.bufpos);
dec(f.bufend);
end;
end;
Begin
//Curr := GetCurrentPosition;
f.bufpos:=0;
f.bufend:=0;
repeat
if f.bufpos > f.bufend then
f.bufend := f.bufpos;
//SetScreenCursor(CurrX,CurrY);
ch := readkey;
case ch of
#0: begin
readkey;
Exit;
end;
^S,
#8: BackSpace;
^Y,
#27: begin
while f.bufpos < f.bufend do
begin
InternalWrite(f.bufptr^[f.bufpos]);
Inc(f.bufpos);
end;
while f.bufend>0 do
BackSpace;
end;
#13: begin
InternalWrite(#13);
InternalWrite(#10);
f.bufptr^[f.bufend] := #13;
f.bufptr^[f.bufend + 1] := #10;
Inc(f.bufend, 2);
break;
end;
#26:
if CheckEOF then
begin
f.bufptr^[f.bufend] := #26;
Inc(f.bufend);
break;
end;
else
begin
if f.bufpos < f.bufsize - 2 then
begin
f.buffer[f.bufpos] := ch;
Inc(f.bufpos);
InternalWrite(ch);
end;
end;
end;
until False;
f.bufpos := 0;
//SetScreenCursor(CurrX,CurrY);
End;
procedure CrtReturn(var F: TextRec);
begin
end;
procedure CrtClose(var F: TextRec);
begin
F.Mode:=fmClosed;
end;
procedure CrtOpen(var F: TextRec);
begin
if F.Mode = fmOutput then
begin
TextRec(F).InOutFunc := @CrtWrite;
TextRec(F).FlushFunc := @CrtWrite;
end
else
begin
F.Mode:=fmInput;
TextRec(F).InOutFunc:=@CrtRead;
TextRec(F).FlushFunc:=@CrtReturn;
end;
TextRec(F).CloseFunc := @CrtClose;
end;
procedure AssignCrt(var F: Text);
begin
Assign(F,'');
TextRec(F).OpenFunc:=@CrtOpen;
end;
procedure InitCRT;
var
i: Integer;
begin
SetMode(DosOutput(), 1);
//
AssignCrt(Output);
Rewrite(Output);
TextRec(Output).Handle := StdOutputHandle;
//
AssignCrt(Input);
Reset(Input);
TextRec(Input).Handle := StdInputHandle;
for i := 0 to High(Pens) do
Pens[i] := -1;
// get screensize (sets MaxCols/MaxRows)
GetDisplaySize;
// set output window
WindMaxX := MaxCols - 1;
WindMaxY := MaxRows - 1;
end;
procedure FreeCRT;
var
i: Integer;
begin
SetMode(DosOutput(), 0);
for i := 0 to High(Pens) do
begin
if Pens[i] >= 0 then
ReleasePen(IntuitionBase^.ActiveScreen^.ViewPort.ColorMap, Pens[i]);
Pens[i] := -1;
end;
// reset colors and delete to end of screen (get rid of old drawings behind the last caret position)
InternalWrite(CSI + '0m' + CSI + 'J');
CursorOn;
end;
initialization
InitCRT;
finalization
FreeCRT;
end.

925
packages/rtl-console/src/amiga/crt.pp
View File

@ -1,925 +0,0 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2000 by Nils Sjoholm and Carl Eric Codere
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 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;
{$i crth.inc}
Implementation
uses
exec, amigados, conunit, intuition;
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;
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;
CSI = chr($9b);
SIGBREAKF_CTRL_C = 4096;
{function AllocVec( size, reqm : Longint ): Pointer;
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;
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;
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;
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;
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;
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;
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;
end;
function SetSignal(newSignals, signalMask : Longint) : Longint;
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;}
function OpenInfo : pInfoData;
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;
end;
procedure CloseInfo(var info : pInfoData);
begin
if info <> nil then begin
FreeVec(info);
info := nil;
end;
end;
function ConData(modus : byte) : integer;
var
info : pInfoData;
theunit : pConUnit;
pos : Longint;
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;
end;
function WhereX : tcrtcoord;
begin
WhereX := Byte(ConData(CD_CURRX))-lo(windmin);
end;
function realx: byte;
begin
RealX := Byte(ConData(CD_CURRX));
end;
function realy: byte;
begin
RealY := Byte(ConData(CD_CURRY));
end;
function WhereY : tcrtcoord;
begin
WhereY := Byte(ConData(CD_CURRY))-hi(windmin);
end;
function screencols : integer;
begin
screencols := ConData(CD_MAXX);
end;
function screenrows : integer;
begin
screenrows := ConData(CD_MAXY);
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');
end;
procedure CursorOn;
begin
Write(CSI,'1 p');
end;
procedure ClrScr;
begin
Write(Chr($0c));
end;
function ReadKey : char;
const
IDCMP_VANILLAKEY = $00200000;
IDCMP_RAWKEY = $00000400;
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;
end;
function KeyPressed : Boolean;
const
IDCMP_VANILLAKEY = $00200000;
IDCMP_RAWKEY = $00000400;
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);
CloseInfo(info);
end;
KeyPressed := ispressed;
end;
procedure TextColor(color : byte);
begin
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');
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;
procedure DelLine;
begin
Write(CSI,'X');
end;
procedure ClrEol;
begin
Write(CSI,'K');
end;
procedure InsLine;
begin
Write(CSI,'1 L');
end;
procedure cursorbig;
begin
end;
procedure lowvideo;
begin
end;
procedure highvideo;
begin
end;
procedure nosound;
begin
end;
procedure sound(hz : word);
begin
end;
procedure delay(ms : Word);
var
dummy : Longint;
begin
dummy := trunc((real(ms) / 1000.0) * 50.0);
DOSDelay(dummy);
end;
{function CheckBreak : boolean;
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;
begin
end;
function GetTextBackground : 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_BgPen;
CloseInfo(info);
end;
GetTextBackground := pen;
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;
var
old_exit : pointer;
procedure crt_exit;
begin
{ Restore default colors }
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;}
end.