Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/TMOD.ZIP/TMOD.PAS

Pascal/Delphi Source File | 1986-02-23 | 6.2 KB | 291 lines

{This is a minimal overlay file for IBM machines and compatibles
 using the addresses corresponding to COM1:. It works on a Compaq
 using a Hayes Internal Modem (for sure!). The modem initialization
 is for a Hayes Smartmodem. - RHM}

const
  iodata    = $3f8;

procedure lineout(message: line); forward;
 {lineout is in IO.INC - don't change this declaration!}

procedure clearstatus;

{Resets latching status flags on SIO chip -
 replace with empty procedure if not needed}

  begin
  end;

function outready: boolean;

{Returns true if serial output port is
 ready to transmit a new character}

  begin
    outready := ((port[$3fd] and 32) > 0);
  end;

procedure xmitchar(ch: char);

{Transmits ch when serial output port is ready,
   unless we're in the local mode.}

  begin
    if not local then begin
      repeat until outready;
      port[iodata] := ord(ch);
    end;
  end;

function cts: boolean;

{This function returns true if a carrier tone is present on the modem
 and is frequently checked to see if the caller is still present.
 It always returns "true" in the local mode.}

  begin
    cts := ((port[$3fe] and 128) = 128) or local;
  end;

function inready: boolean;

{Returns true if we've got a character received
 from the serial port or keyboard.}

  begin
    inready := keypressed or ((port[$3fd] and 1) > 0);
  end;

function recvchar: char;

{Returns character from serial input port,
  REGARDLESS of the status of inready.}

  begin
    recvchar := chr(port[iodata]);
  end;

procedure setbaud(speed: rate);

{For changing the hardware baud rate setting}

  begin
    port[$3fb] := 131;
    case speed of
      slow: begin
              port[$3f8] := $80;
              port[$3f9] := 1;
            end;
      fast: begin
              port[$3f8] := $60;
              port[$3f9] := $0;
            end;
    end;
    port[$3fb] := 3;
    baud := speed;
  end;

procedure clearSIO;

{ Initializes serial I/O chip:
  sets up for 8 bits, no parity and one stop bit on both
  transmit and receive, and allows character transmission
  with CTS low. Also sets RTS line high. }

  begin
    port[$3fb] := 3;
    port[$3f9] := 0;
    port[$3fc] := 11;
  end;

procedure clearmodem;        (* Modem Dependent *)

{Sets modem for auto-answer, CTS line as carrier detect, no command echo}

  var buffer: line;
      loop  : byte;
      ch    : char;

  begin
    buffer := 'ATS0=1 V0 Q1';
    for loop := 1 to length(buffer) do begin
      ch := buffer[loop];
      xmitchar(ch);
      delay(50);
    end;
    xmitchar(#13);
    writeln;
    write('Delaying...');
    delay(1000); {Delays while modem digests initialization codes}
    writeln;
  end;

procedure setup;

{Hardware initializion for system to start BBS program}

  begin
    clearSIO;
    setbaud(fast);
    clearmodem;
  end;

function badframe: boolean;

{Indicates Framing Error on serial I/O chip - return false if not available.}

  begin
    badframe := (port[$3FD] and 8) = 8;
  end;

procedure dropRTS;

{ Lowers RS-232 RTS line - used to inhibit auto-answer
   and to cause modem to hang up }

  begin
    port[$3fc] := 8;
  end;

procedure raiseRTS;

(* Raises RTS line to enable auto-answer *)

  begin
    port[$3fc] := 11;
  end;

procedure setlocal;

{Sets local flag true and inhibits modem auto-answer}

  begin
    dropRTS; {Inhibits Rixon auto-answer}
    local := true;
  end;

procedure clearlocal;

{Clears local flag and allows modem auto-answer}

  begin
    raiseRTS; {Enables Rixon Auto-answer}
    local := false;
  end;

procedure unload;

{Halts Kaypro disk drives - normally they run for about 15 secs.}

  begin
  end;

procedure dispcaller;

{Displays caller's name on protected 25th line of host CRT;
 Replace with empty procedure if not desired.}

  begin
  end;

procedure hangup;

{Signals modem to hang up - in this case by lowering RTS line for 500 msec.}

  begin
    if cts then lineout('--- Disconnected ---' + cr + lf);
    dropRTS;
    if local then clearlocal else repeat until not cts;
    raiseRTS;
  end;

procedure flush;

  var junk: char;

  begin
    junk := recvchar;
  end;

{Real-time clock support begins here - this routine is called
 even if there is NO clock, so leave it and set clockin accordingly}

procedure clock(var month,date,hour,min,sec: byte);

{Returns with month in range 1(Jan)..12(Dec),
 date in 1..length of month, hour in 0..23 (24-hr clock),
 minute and second in 0..59}

  var
    temp: integer;
    tempint: integer;
    temp1: byte;

  const monthmask = $000F;
        daymask = $001F;
        minutemask = $003F;
        secondmask = $001F;
  type  dtstr = string[8];
        Register        = Record
                          AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags : Integer;
                          End;
  var  tstr : dtstr;

  function getdate : dtstr;

  var
    allregs : register;
    month, day,
    year    : string[2];
    i       : integer;
    tstr    : dtstr;

  begin
     allregs.ax := $2A * 256;
     MsDos(allregs);
     str((allregs.dx div 256):2,month);
     str((allregs.dx mod 256):2,day);
     str((allregs.cx - 1900):2,year);
     tstr := month + '/' + day + '/' + year;
     for i := 1 to 8 do
       if tstr[i] = ' ' then
         tstr[i] := '0';
     getdate := tstr;
  end;  {getdate}

  function gettime : dtstr;

  var
   allregs : register;
   hour, minute,
   second  : string[2];
   i       : integer;
   tstr    : dtstr;

  begin
     allregs.ax := $2C * 256;
     MsDos(allregs);
     str((allregs.cx div 256):2,hour);
     str((allregs.cx mod 256):2,minute);
     str((allregs.dx div 256):2,second);
     tstr := hour + ':' + minute + ':' + second;
     for i := 1 to 8 do
       if tstr[i] = ' ' then
         tstr[i] := '0';
     gettime := tstr;
  end;  {gettime}

  begin
    val(copy(getdate,1,2),tempint,temp);
    month := lo(tempint);
    val(copy(getdate,4,2),tempint,temp);
    date := lo(tempint);
    val(copy(gettime,1,2),tempint,temp);
    hour := lo(tempint);
    val(copy(gettime,4,2),tempint,temp);
    min := lo(tempint);
    val(copy(gettime,7,2),tempint,temp);
    sec := lo(tempint);
  end;