GEMini Atari/GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso/files/bbs/turbobbs/io.inc

Text File | 1985-08-24 | 10.6 KB | 440 lines

const
  iodata    = 4;
  iocontrol = 6;
  iorate    = 0;

var
  cancelled : boolean;
  inbuffer  : line;

function inready:boolean; forward;

function charin(withecho: boolean):char; forward;

function outready: boolean;                    (* Machine Dependent *)

{Indicates that serial output port is
 ready to transmit a new character}

  begin
    port[iocontrol] := 16;
    outready := (port[iocontrol] and 4) > 0;
  end;

procedure xmitchar(ch: char);                  (* Machine Dependent *)

{Transmits character out serial port, unless we're in the local mode.}

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


procedure sendout(ch: char);

{Character output - bypasses word-wrap; also performs
 "pause" and "abort" input character checks.}

var temp: char;

  begin
    if not cancelled then begin
      if inready then begin
        temp := charin(noecho);
        if (temp = pause) or (upcase(temp) = 'S') then temp := charin(noecho);
        if (temp = abort) or (upcase(temp) = 'C') then cancelled := true;
      end;
      xmitchar(ch);
      write(ch);
      if printon then write(lst, ch);
      if (ch = cr) and (lf = null) then writeln;
    end;
  end;

procedure flushbuff;

  var
    outpointer: byte;

  begin
    if length(buffer) > lastspace then
      for outpointer := lastspace + 1 to length(buffer) do
        sendout(buffer[outpointer]);
    lastspace := length(buffer);
  end;

procedure resetbuff;

  begin
    bufpointer := 0;
    lastspace := 0;
    charcount := 0;
    buffer := '';
  end;

procedure charout(ch:char);

{Character output using word-wrap}

  var
    buffull   : boolean;
    temp      : long;

  begin
    if caps then ch := upcase(ch);
    if not (ch in [null..#31]) then charcount := succ(charcount);
    if (ch = bs) and (charcount > 0) then charcount := charcount - 1;
    buffer := buffer + ch;
    bufpointer := length(buffer);
    buffull := (charcount + 2 > width);
    if buffull then begin
      if (lastspace > 0)
        then begin
          buffer := copy(buffer, lastspace + 1, bufpointer - lastspace);
          charcount := length(buffer);
          lastspace := 0;
          end {then}
        else begin
          flushbuff;
          resetbuff;
        end; {else}
      sendout(cr);
      sendout(lf);
    end; {if}
    if ch in [null..space] then flushbuff;
    if (ch=cr) then resetbuff;
  end;

procedure stringout(message:line);

  var
    charpos: integer;

  begin
    for charpos := 1 to length(message) do charout(message[charpos]);
  end;

procedure lineout(message:line);

  begin
    stringout(message);
    charout(cr);
    charout(lf);
  end;

function cts: boolean;                            (* Machine Dependent *)

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

  begin
    port[iocontrol] := 16;  {Z80 SIO status reset - gets current CTS level}
    cts := ((port[iocontrol] and 32) = 32) or local;
  end;

function inready;                                 (* Machine Dependent *)

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

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

function recvchar: char;                          (* Machine Dependent *)

{Reads character from serial I/O input}

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

function charin;

  var
    ch: char;

  begin
    ch := null;
    repeat
      if inready then ch := recvchar;
      if keypressed then read(kbd, ch);
      if not cts then ch := cr;
      if (ch <> bs) and not controls then ch := chr(ord(ch) and 127);
    until (ch in [abort, pause, bs, tab, cr, space..#127])
      or (controls and (ch <> null));
    if (ch = #127) and not controls then ch := bs;
    if ch = #$8D then ch := cr;
    if withecho then begin
        sendout(ch);
        if ch = bs then begin sendout(' '); sendout(bs); end;
      end
      else write(ch);
    charin := ch;
  end;

procedure flush;                                      (* Machine Dependent *)

  var
    junk: char;

  begin
    while inready do junk := charin(noecho);
    port[iocontrol] := 16;      {Reset Z80 SIO status lines}
  end;

function inputstring(withecho: boolean): line;

  var
    pointer: integer;
    temp:    line;
    ch:      char;

  begin
    temp := '';
    flush;
    repeat
      ch := charin(withecho);
      if ((ch <> pause) and (ch <> abort)) or controls then begin
        if ch = tab then
          repeat
            temp := temp + space;
            pointer := length(temp);
          until (pointer mod 8) = 0
        else begin
          temp := temp + ch;
          pointer := length(temp);
          if (ch = bs) then begin
            if pointer > 1 then temp := copy(temp, 1, pointer - 2)
                           else begin
                             temp := '';
                             sendout(' ');
                           end;
          end; {else}
        end;   {if ch = tab}
      end;     {if (ch <>...}
    until (ch = cr) or (pointer = 80);
    if ch = cr then temp := copy(temp,1,pointer-1)
               else charout(cr);
    if (ch = cr) and not withecho then charout(cr);
    resetbuff;
    charout(lf);
    inputstring := temp;
  end;

function getinput(prompt:line; maxlength:integer; withecho:boolean):line;

  var posn: integer;
      temp: char;

  begin
    if cancelled then begin
      cancelled := false;
      lineout(space);
    end;
    if inbuffer = '' then begin
      repeat
        cancelled := false;
        stringout(prompt);
        if bl = bell then stringout(bl);
      until cancelled = false;
      inbuffer := inputstring(withecho);
    end;
    if maxlength = 1 then begin
      repeat
        if inbuffer = '' then temp := cr else begin
          temp := inbuffer[1];
          inbuffer := copy(inbuffer, 2, length(inbuffer)-1);
        end;
      until temp <> ';';
      getinput := temp;
    end
    else begin
      posn := pos(';', inbuffer);
      if posn = 0 then posn := length(inbuffer) + 1;
      if posn > maxlength then posn := maxlength + 1;
      getinput := copy(inbuffer, 1, posn - 1);
      if posn >= length(inbuffer)
        then inbuffer := ''
        else inbuffer := copy(inbuffer, posn + 1, length(inbuffer) - posn);
    end;
  end;

function allcaps(letters: person): person;

  var
    loop: byte;
    temp: person;

  begin
    temp := '';
    for loop := 1 to length(letters) do
      temp := temp + upcase(letters[loop]);
    allcaps := temp;
  end;

procedure setbaud(speed: rate);                       (* Machine Dependent *)

  begin
    case speed of
      slow: port[iorate] := 5;     { 300 baud}
      fast: port[iorate] := 7;     {1200 baud}
    end;
    baud := speed;
  end;

procedure clearSIO;                                   (* Machine Dependent *)

{Initializes serial I/O chip - a Z80 SIO in this case}

  begin
    port[iocontrol] := $18;
    port[iocontrol] := 4;
    port[iocontrol] := $44;
    port[iocontrol] := 3;
    port[iocontrol] := $C1;
    port[iocontrol] := 5;
    port[iocontrol] := $EA;
  end;

procedure clearmodem;                                 (* Modem Dependent *)

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

  begin
    buffer := cr + cr + '<O3N4N5N0Q>';
    flushbuff;
    resetbuff;
    writeln;
    write('Delaying...');
    delay(5000);
    writeln;
  end;

procedure setup;                                      (* Machine Dependent *)

  begin
    port[8] := 12;  {sets Kaypro 2-84 serial printer port to 4800 baud}
    write(esc + 'B7'); {sets 25th line protection on Kaypro 2-84.}
    setbaud(fast);
    clearSIO;
    clearmodem;
  end;

function badframe: boolean;                           (* Machine Dependent *)

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

  begin
    port[iocontrol] := 1;
    badframe := (port[iocontrol] and 64) = 64;
  end;

procedure dropRTS;                                   (* Machine Dependent *)

  begin
    port[iocontrol] := 5;
    port[iocontrol] := $68;
  end;

procedure setlocal;

  begin
    dropRTS;
    local := true;
    write('Local control.');
  end;

procedure raiseRTS;                                   (* Machine Dependent *)

  begin
    port[iocontrol] := 5;
    port[iocontrol] := $EA;
  end;

procedure clearlocal;

  begin
    raiseRTS;
    local := false;
  end;

procedure awaitcall;                                  (* Machine Dependent *)

  var
    junk: char;

  begin
    setbaud(fast);
    writeln(cr + lf + 'Waiting for call...');
    flush;
    repeat
      if keypressed then begin
        read(kbd, junk);
        local := junk = esc;
        if local then setlocal else exitchar := junk;
      end;
    until cts or (exitchar = abort);
    if exitchar <> abort then begin
      writeln('On line...');
      delay(500);
      flush;
      junk := charin(noecho);
      if badframe or (junk <> cr) then setbaud(slow);
      port[iocontrol] := $30;   {Resets Z80 SIO error flags - this is the}
    end;                        {only machine dependent line in procedure}
  end;

procedure unload;                                     (* Machine Dependent *)

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

  begin
    port[20] := (port[20] and $EF);
  end;

procedure hangup;                                     (* Machine Dependent *)

{Signals modem to hang up by lowering RTS line for 400 msec.}

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

procedure dispcaller;                                 (* Machine Dependent *)

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

  begin
    write(esc + 'B6' + esc + '=' + chr(56) + ' ');
    write(caller);
    if clockin then write(' called at ' + timeon);
    write(#24 + esc + 'C6');    {#24 = clear to end of line}
  end;

procedure clearsc;

  begin
    stringout(cs);
    delay(500);   {allows time for slow terminal screen clears}
  end;

function getcap(prompt: line): char;

  var
    temp : char;

  begin
    temp := upcase(getinput(prompt, 1, echo));
    getcap := temp;
  end;
əəəəəəəəəəəəəəəəəəəəəəəəəə