fpc/rtl/os2/crt.pas

{****************************************************************************

                            Standard CRT unit.
                    FPK-Pascal runtime library for OS/2.
                    Copyright (c) 1997 Dani‰l Mantione.

      This file may be reproduced and modified under the same conditions
                      as all other FPK-Pascal source code.

****************************************************************************}

unit crt;

{History:

    3 june 1997 - Creation.
    9 june 1997 - Now runs under OS/2.
   12 june 1997 - Now runs under DOS.}

interface

uses dos;

const   _40cols=0;
        _80cols=1;
        _132cols=2;
        _25rows=0;
        _28rows=16;
        _43rows=32;
        _50rows=48;
        font8x8=_50rows;

        black         =0;
        blue          =1;
        green         =2;
        cyan          =3;
        red           =4;
        magenta       =5;
        brown         =6;
        lightgray     =7;
        darkgray      =8;
        lightblue     =9;
        lightgreen    =10;
        lightcyan     =11;
        lightred      =12;
        lightmagenta  =13;
        yellow        =14;
        white         =15;
        blink         =128;

{cemodeset means that the procedure textmode has failed to set up a mode.}

type    cexxxx=(cenoerror,cemodeset);

var textattr:byte;                      {Text attribute.        RW}
    windmin,windmax:word;               {Window coordinates.    R-}
    lastmode:word;                      {Last videomode.        R-}
    crt_error:cexxxx;                   {Crt-status.            RW}

function keypressed:boolean;
function readkey:char;

procedure clrscr;
function whereX:byte;
function whereY:byte;
procedure gotoXY(x,y:byte);
procedure window(left,top,right,bottom : byte);
procedure textmode(mode:integer);
procedure textcolor(colour:byte);
procedure textbackground(colour:byte);
procedure insline;
procedure delline;
procedure lowvideo;
procedure normvideo;
procedure highvideo;
procedure assigncrt(var f:text);
procedure delay(ms:word);
procedure sound(hz:word);
procedure nosound;

{***************************************************************************}

{***************************************************************************}

implementation

const   extkeycode:char=#0;

var maxrows,maxcols:word;
    calibration:longint;

type    Tkbdkeyinfo=record
            charcode,scancode:char;
            fbstatus,bnlsshift:byte;
            fsstate:word;
            time:longint;
        end;

        {if you have information on the folowing datastructure, please
         send them to me at [email protected]}

        {This datastructure is needed when we ask in what video mode we are,
         or we want to set up a new mode.}

        viomodeinfo=record
            cb:word;                         { length of the entire data
                                               structure }
            fbtype,                          { bit mask of mode being set}
            color: byte;                     { number of colors (power of 2) }
            col,                             { number of text columns }
            row,                             { number of text rows }
            hres,                            { horizontal resolution }
            vres: word;                      { vertical resolution }
            fmt_ID,                          { attribute format
                                               ! more info wanted !}
            attrib: byte;                    { number of attributes }
            buf_addr,                        { physical address of
                                               videobuffer, e.g. $0b800}
            buf_length,                      { length of a videopage (bytes)}
            full_length,                     { total video-memory on video-
                                               card (bytes)}
            partial_length:longint;          { ????? info wanted !}
            ext_data_addr:pointer;           { ????? info wanted !}
        end;
        Pviomodeinfo=^viomodeinfo;

{EMXWRAP.DLL has strange calling conventions: All parameters must have
 a 4 byte size.}

function kbdcharin(var Akeyrec:Tkbdkeyinfo;wait,kbdhandle:longint):word;
                   external 'EMXWRAP' index 204;
function kbdpeek(var Akeyrec:TkbdkeyInfo;kbdhandle:word):word;
                 external 'EMXWRAP' index 222;

function dossleep(time:longint):word;
                  external 'DOSCALLS' index 229;
function vioscrollup(top,left,bottom,right,lines:longint;
                     var screl:word;viohandle:longint):word;
                     external 'EMXWRAP' index 107;
function vioscrolldn(top,left,bottom,right,lines:longint;
                     var screl:word;viohandle:longint):word;
                     external 'EMXWRAP' index 147;
function viogetcurpos(var row,column:word;viohandle:longint):word;
                      external 'EMXWRAP' index 109;
function viosetcurpos(row,column,viohandle:longint):word;
                      external 'EMXWRAP' index 115;
function viowrtTTY(s:Pchar;len,viohandle:longint):word;
                      external 'EMXWRAP' index 119;
function viowrtcharstratt(s:Pchar;len,row,col:longint;var attr:byte;
                          viohandle:longint):word;
                          external 'EMXWRAP' index 148;
function viogetmode(var Amodeinfo:viomodeinfo;viohandle:longint):word;
                    external 'EMXWRAP' index 121;
function viosetmode(var Amodeinfo:viomodeinfo;viohandle:longint):word;
                    external 'EMXWRAP' index 122;

procedure setscreenmode(mode:word);

{ This procedure sets a new videomode. Note that the constants passes to
  this procedure are different than in the dos mode.}

const   modecols:array[0..2] of word=(40,80,132);
        moderows:array[0..3] of word=(25,28,43,50);

var newmode:viomodeinfo;

begin
    if os_mode=osOS2 then
        begin
            newmode.cb:=8;
            newmode.fbtype:=1;          {Non graphics colour mode.}
            newmode.color:=4;           {We want 16 colours, 2^4=16.}
            newmode.col:=modecols[mode and 15];
            newmode.row:=moderows[mode shr 4];
            if viosetmode(newmode,0)=0 then
                crt_error:=cenoerror
            else
                crt_error:=cemodeset;
            maxcols:=newmode.col;
            maxrows:=newmode.row;
        end
    else
        begin
            maxcols:=modecols[mode and 15];
            maxrows:=moderows[mode shr 4];
            crt_error:=cenoerror;
            {Set correct vertical resolution.}
            asm
                movw $0x1202,%ax
                movw 8(%ebp),%bx
                shrw $4,%bx
                cmpb $2,%bl
                jne crtsetmode_a1
                decw %ax
            crtsetmode_a1:
                mov $0x30,%bl
                int $0x10
            end;
            {132 column mode in DOS is videocard dependend.}
            if mode and 15=2 then
                begin
                    crt_error:=cemodeset;
                    exit;
                end;
            {Switch to correct mode.}
            asm
                mov 8(%ebp),%bx
                and $15,%bl
                mov $1,%ax
                cmp $1,%bl
                jne crtsetmode_b1
                mov $3,%al
            crtsetmode_b1:
                int $0x10
            {Use alternate print-screen function.}
                mov $0x12,%ah
                mov $0x20,%bl
                int $0x10
            end;
            {Set correct font.}
            case mode shr 4 of
                1:
                    {Set 8x14 font.}
                    asm
                        mov $0x1111,%ax
                        mov $0,%bl
                        int $0x10
                    end;
                2,3:
                    {Set 8x8 font.}
                    asm
                        mov $0x1112,%ax
                        mov $0,%bl
                        int $0x10
                    end;
            end;
        end;
end;

procedure getcursor(var y,x:word);

{Get the cursor position.}

begin
    if os_mode=osOS2 then
        viogetcurpos(y,x,0)
    else
        asm
            movb $3,%ah
            movb $0,%bh
            int $0x10
            movl y,%eax
            movl x,%ebx
            movb %dh,(%eax)
            movb %dl,(%ebx)
        end;
end;

procedure setcursor(y,x:word);

{Set the cursor position.}

begin
    if os_mode=osOS2 then
        viosetcurpos(y,x,0)
    else
        asm
            movb $2,%ah
            movb $0,%bh
            movb y,%dh
            movb x,%dl
            int $0x10
        end;
end;

procedure scroll_up(top,left,bottom,right,lines:word;var screl:word);

begin
    if os_mode=osOS2 then
        vioscrollup(top,left,bottom,right,lines,screl,0)
    else
        asm
            movb $6,%ah
            movb lines,%al
            movl screl,%edi
            movb 1(%edi),%bh
            movb top,%ch
            movb left,%cl
            movb bottom,%dh
            movb right,%dl
            int $0x10
        end;
end;

procedure scroll_dn(top,left,bottom,right,lines:word;var screl:word);

begin
    if os_mode=osOS2 then
        vioscrolldn(top,left,bottom,right,lines,screl,0)
    else
        asm
            movb $7,%ah
            movb lines,%al
            movl screl,%edi
            movb 1(%edi),%bh
            movb top,%ch
            movb left,%cl
            movb bottom,%dh
            movb right,%dl
            int $0x10
        end;
end;

function keypressed:boolean;

{Checks if a key is pressed.}

var Akeyrec:Tkbdkeyinfo;

begin
    if os_mode=osOS2 then
        begin
            kbdpeek(Akeyrec,0);
            keypressed:=(extkeycode<>#0) or ((Akeyrec.fbstatus and $40)<>0);
        end
    else
        begin
            if extkeycode<>#0 then
                begin
                    keypressed:=true;
                    exit
                end
            else
                asm
                    movb $1,%ah
                    int $0x16
                    setnz %al
                    movb %al,__RESULT
                end;
        end;
end;

function readkey:char;

{Reads the next character from the keyboard.}

var Akeyrec:Tkbdkeyinfo;
    c,s:char;

begin
    if extkeycode<>#0 then
        begin
            readkey:=extkeycode;
            extkeycode:=#0
        end
    else
        begin
            if os_mode=osOS2 then
                begin
                    kbdcharin(Akeyrec,0,0);
                    c:=Akeyrec.charcode;
                    s:=Akeyrec.scancode;
                    if (c=#224) and (s<>#0) then
                        c:=#0;
                end
            else
                begin
                    asm
                        movb $0,%ah
                        int $0x16
                        movb %al,c
                        movb %ah,s
                    end;
                end;
            if c=#0 then
                extkeycode:=s;
            readkey:=c;
        end;
end;

procedure clrscr;

{Clears the current window.}

var screl:word;

begin
    screl:=$20+textattr shl 8;
    scroll_up(hi(windmin),lo(windmin),
              hi(windmax),lo(windmax),
              hi(windmax)-hi(windmin)+1,
              screl);
    gotoXY(1,1);
end;

procedure gotoXY(x,y:byte);

{Positions the cursor on (x,y) relative to the window origin.}

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;
    setcursor(y+hi(windmin)-1,x+lo(windmin)-1);
end;

function whereX:byte;

{Returns the x position of the cursor.}

var x,y:word;

begin
    getcursor(y,x);
    whereX:=x-lo(windmin)+1;
end;

function whereY:byte;

{Returns the y position of the cursor.}

var x,y:word;

begin
    getcursor(y,x);
    whereY:=y-hi(windmin)+1;
end;

procedure delline;

{Deletes the line at the cursor.}

var row,left,right,bot:longint;
    fil:word;

begin
    row:=whereY;
    left:=lo(windmin)+1;
    right:=lo(windmax)+1;
    bot:=hi(windmax)+1;
    fil:=$20 or (textattr shl 8);
    scroll_up(row+1,left,bot,right,1,fil);
end;

procedure insline;

{Inserts a line at the cursor position.}

var row,left,right,bot:longint;
    fil:word;

begin
    row:=whereY;
    left:=lo(windmin)+1;
    right:=lo(windmax)+1;
    bot:=hi(windmax);
    fil:=$20 or (textattr shl 8);
    scroll_dn(row,left,bot-1,right,1,fil);
end;

procedure textmode(mode:integer);

{ Use this procedure to set-up a specific text-mode.}

begin
    textattr:=$07;
    lastmode:=mode;
    mode:=mode and $ff;
    setscreenmode(mode);
    windmin:=0;
    windmax:=(maxcols-1) or ((maxrows-1) shl 8);
    clrscr;
end;

procedure textcolor(colour:byte);

{All text written after calling this will have color as foreground colour.}

begin
    textattr:=(textattr and $70) or (colour and $f)+colour and 128;
end;

procedure textbackground(colour:byte);

{All text written after calling this will have colour as background colour.}

begin
    textattr:=(textattr and $8f) or ((colour and $7) shl 4);
end;

procedure normvideo;

{Changes the text-background to black and the foreground to white.}

begin
    textattr:=$7;
end;

procedure lowvideo;

{All text written after this will have low intensity.}

begin
    textattr:=textattr and $f7;
end;

procedure highvideo;

{All text written after this will have high intensity.}

begin
    textattr:=textattr or $8;
end;

procedure delay(ms:word);

var i,j:longint;

{Waits ms microseconds. The DOS code is copied from the DOS rtl.}

begin
    {Under OS/2 we could also calibrate like under DOS. But this is
     unreliable, because OS/2 can hold our programs while calibrating,
     if it needs the processor for other things.}
    if os_mode=osOS2 then
        dossleep(ms)
    else
        begin
            for i:=1 to ms do
                for j:=1 to calibration do
                    begin
                    end;
        end;
end;

procedure window(left,top,right,bottom:byte);

{Change the write window to the given coordinates.}

begin
    if (left<1) or
     (top<1) or
     (right>maxcols) or
     (bottom>maxrows) or
     (left>right) or
     (top>bottom) then
        exit;
    windmin:=(left-1) or ((top-1) shl 8);
    windmax:=(right-1) or ((bottom-1) shl 8);
    gotoXY(1,1);
end;

procedure writePchar(s:Pchar;len:word);

{Write a series of characters to the screen.

 Not very fast, but is just text-mode isn't it?}

var x,y:word;
    c:char;
    i,n:integer;
    screl:word;
    ca:Pchar;

begin
    i:=0;
    getcursor(y,x);
    while i<=len-1 do
        begin
            case s[i] of
                #8:
                    x:=x-1;
                #9:
                    x:=(x-lo(windmin)) and $fff8+8+lo(windmin);
                #10:
                    ;
                #13:
                    begin
                        x:=lo(windmin);
                        inc(y);
                    end;
                else
                    begin
                        ca:=@s[i];
                        n:=1;
                        while not(s[i+1] in [#8,#9,#10,#13]) and
                         (x+n<=lo(windmax)+1) and (i<len-1) do
                            begin
                                inc(n);
                                inc(i);
                            end;
                        if os_mode=osOS2 then
                            viowrtcharstratt(ca,n,y,x,textattr,0)
                        else
                            asm
                                movw $0x1300,%ax
                                movb $0,%bh
                                movb U_CRT_TEXTATTR,%bl
                                movb y,%dh
                                movb x,%dl
                                movw n,%cx
                                pushl %ebp
                                movl ca,%ebp
                                int $0x10
                                popl %ebp
                            end;
                        x:=x+n;
                    end;
            end;
            if x>lo(windmax) then
                begin
                    x:=lo(windmin);
                    inc(y);
                end;
            if y>hi(windmax) then
                begin
                    screl:=$20+textattr shl 8;
                    scroll_up(hi(windmin),lo(windmin),
                              hi(windmax),lo(windmax),
                              1,screl);
                    y:=hi(windmax);
                end;
{           writeln(stderr,x,'  ',y);}
            inc(i);
        end;
    setcursor(y,x);
end;

function crtread(var f:textrec):word;

{Read a series of characters from the console.}

var max,curpos,i:integer;
    c:char;
    clist:array[0..2] of char;

begin
    max:=f.bufsize-2;
    curpos:=0;
    repeat
        c:=readkey;
        case c of
            #0:
                readkey;
            #8:
                if curpos>0 then
                    begin
                        clist:=#8' '#8;
                        writePchar(@clist,3);
                        dec(curpos);
                    end;
            #13:
                begin
                    f.bufptr^[curpos]:=#13;
                    inc(curpos);
                    f.bufptr^[curpos]:=#10;
                    inc(curpos);
                    f.bufpos:=0;
                    f.bufend:=curpos;
                    clist[0]:=#13;
                    writePchar(@clist,1);
                    break;
                end;
            #32..#255:
                if curpos<max then
                    begin
                        f.bufptr^[curpos]:=c;
                        inc(curpos);
                        writePchar(@c,1);
                    end;
        end;
    until false;
    crtread:=0;
end;

function crtwrite(var f:textrec):word;

{Write a series of characters to the console.}

begin
    writePchar(Pchar(f.bufptr),f.bufpos);
    f.bufpos:=0;
    crtwrite:=0;
end;


function crtopen(var f:textrec):integer;

begin
    if f.mode=fmoutput then
        crtopen:=0
    else
        crtopen:=5;
end;

function crtinout(var f:textrec):integer;

begin
    case f.mode of
        fminput:
            crtinout:=crtread(f);
        fmoutput:
            crtinout:=crtwrite(f);
    end;
end;

function crtclose(var f:textrec):integer;

begin
    f.mode:=fmclosed;
    crtclose:=0;
end;

procedure assigncrt(var f:text);

{Assigns a file to the crt console.}

begin
    textrec(f).mode:=fmclosed;
    textrec(f).bufsize:=128;
    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[0]:=#0;
end;

procedure sound(hz:word);

{sound and nosound are not implemented because the OS/2 API supports a freq/
 duration procedure instead of start/stop procedures.}

begin
end;

procedure nosound;

begin
end;

function get_ticks:word;

type    Pword=^word;

begin
    get_ticks:=Pword(longint(first_meg)+$46c)^;
end;

procedure initdelay;

{Calibrate the delay procedure. Copied from DOS rtl.}

var first:word;

begin
    calibration:=0;

    { wait for new tick }
    first:=get_ticks;
    while get_ticks=first do
        begin
        end;
    first:=get_ticks;

    { this estimates calibration }
    while get_ticks=first do
        inc(calibration);

    { calculate this to ms }
    calibration:=calibration div 70;
    while true do
        begin
            first:=get_ticks;
            while get_ticks=first do
                begin
                end;
            first:=get_ticks;
            delay(55);
            if first=get_ticks then
                exit
            else
                begin
                    { decrement calibration two percent }
                    calibration:=calibration-calibration div 50;
                    dec(calibration);
                end;
        end;
end;

{Initialization.}

type    Pbyte=^byte;

var curmode:viomodeinfo;
    mode:byte;

begin
    textattr:=lightgray;
    if os_mode=osOS2 then
        begin
            curmode.cb:=sizeof(curmode);
            viogetmode(curmode,0);
            maxcols:=curmode.col;
            maxrows:=curmode.row;
            lastmode:=0;
            case maxcols of
                40:
                    lastmode:=0;
                80:
                    lastmode:=1;
                132:
                    lastmode:=2;
            end;
            case maxrows of
                25:;
                28:
                    lastmode:=lastmode+16;
                43:
                    lastmode:=lastmode+32;
                50:
                    lastmode:=lastmode+48;
            end
        end
    else
        begin
            {Request video mode to determine columns.}
            asm
                mov $0x0f,%ah
                int $0x10
                mov %al,_MODE
            end;
            case mode of
                0,1:
                    begin
                        lastmode:=0;
                        maxcols:=40;
                    end;
                else
                    begin
                        lastmode:=1;
                        maxcols:=80;
                    end;
            end;
            {Get number of rows from realmode $0040:$0084.}
            maxrows:=Pbyte(longint(first_meg)+$484)^;
            case maxrows of
                25:;
                28:
                    lastmode:=lastmode+16;
                43:
                    lastmode:=lastmode+32;
                50:
                    lastmode:=lastmode+48;
            end
        end;
    windmin:=0;
    windmax:=((maxrows-1) shl 8) or (maxcols-1);
    if os_mode=osDOS then
        initdelay;
    crt_error:=cenoerror;
    assigncrt(input);
    textrec(input).mode:=fminput;
    assigncrt(output);
    textrec(output).mode:=fmoutput;
end.