// This is file QL2MAI.BCP
//
// To be renamed FLP2_KERMAIN_BCPL for QDOS
SECTION "Main"

/*********************************************************************

      KK    KK  EEEEEEEE  RRRRRRR   MM    MM  IIIIIIII  TTTTTTTT
      KK   KK   EEEEEEEE  RRRRRRRR  MMM  MMM  IIIIIIII  TTTTTTTT
      KK  KK    EE        RR    RR  MMMMMMMM     II        TT
      KKKK      EEEEEE    RRRRRRRR  MM MM MM     II        TT
      KK KK     EE        RRRRRRR   MM    MM     II        TT
      KK  KK    EE        RR  RR    MM    MM     II        TT
      KK   KK   EEEEEEEE  RR   RR   MM    MM  IIIIIIII     TT
      KK    KK  EEEEEEEE  RR    RR  MM    MM  IIIIIIII     TT

*********************************************************************/

GET "LIBHDR"
GET "FLP2_KERHDR"

/*
   This is QL KERMIT
   by David Harper

   Dept of Applied Maths and Theoretical Physics
   University of Liverpool


   It is based upon the BCPL implementation written for the Tripos operating
   system by C.G. Selwyn at Bath University in 1984.  I have replaced the
   finite-state automaton command parser by my own version which allows extra
   commands/options to be added to the program quite easily.


   S T A R T    of   QL   K E R M I T

    Initialise and call the handle routine to execute
    the current command input stream
*/

LET start() BE
$( LET rp = VEC 100/bytesperword
   LET pk = VEC 100/bytesperword
   LET avec = VEC argvl
   LET c = VEC 80/bytesperword
   LET tvec = VEC 1
   LET setname = VEC 40
   LET parser.buffer = VEC 40
   LET main.command.table = VEC 20
   LET set.command.table = VEC 40
   LET set.command.functions = VEC 40
   LET rs232.name = VEC 2
//
   sys.abort := abort            // save ABORT routine address
   abort := kermit.abort         // make BCPL abort through our routine
   ser.name := rs232.name
   starttime := tvec
   finishtime := tvec+1
   cbuf := c
   argv := avec
   parse.buf := parser.buffer
   main.com.table := main.command.table
   set.com.table := set.command.table
   set.function.table := set.command.functions
   pakcnt := 0
   reclevel := 0
   erroring := FALSE
   qcon.init := FALSE
//
   console := open("CON_480x220a26x10_128",0,0)
   currentin := console
   selectinput(console)
   selectoutput(console)
   finishtime!0 := -1
   filecnt := 0
   recpkt := rp
   packet := pk
   fd := 0        // No file open
   remfd := 0     // No serial line open yet
   debug.fd := console   // send debugging output to the screen initially
//
   escchr := brkchr
   remote.delay := 5
   image := FALSE
   quote8ing := FALSE
   quote8 := myquote8
   maxpack := 92
   maxtry  := 5
   reporting := TRUE
//
   s.eol := cr
   s.packet.length := maxpack
   s.quote := myquote
   s.pad := 0
   s.padchar := null
   s.sop := soh
   s.timeout := 5
//
   r.eol := myeol
   r.packet.length := maxpack
   r.quote := myquote
   r.pad := mypad
   r.padchar := mypchar
   r.sop := soh
   r.timeout := 5
//
   local := TRUE
   remote := \local
   serving := FALSE
   debug := FALSE
   take.echo := FALSE
   ser.duplex := 'F'
   ser.escape := kbd.esc
   ser.handshake := 'I'
   ser.parity := 'E'
   ser.pause := 0
   ser.line := '2'
   ser.baud := 4800
   ser.corrupt := FALSE
//
   change.my.priority(64)
//
   screen(screen.clear)
   writef("QL Kermit - Version %N.%N*N",version,update)
   initialise()
//
   handle()
//
   end.kermit()
$)

/*
   H A N D L E

    This routine handles the parsing and actioning of the
    current command input stream.
    Take commands are a recursive call to handle().
*/

AND handle() BE
$( LET nch = 0
   filecnt := 0
   erroring := FALSE
   selectinput(currentin)
   selectoutput(console)
   IF currentin = console THEN
      writef("*NQL-Kermit (%S) > ",remote->"Remote","Local")
   command := -1
   nch := readcommand(cbuf)
   IF nch<=0 THEN
   $(  TEST reclevel=0 THEN  LOOP           // Nothing to process
                       ELSE  RETURN         // End of TAKE file
   $)
   IF reclevel>0 & take.echo DO $( writes(cbuf) ; newline() $)
   nwords := parse.line(cbuf,argv) + 1
   TEST do.parse(argv!0,main.com.table) THEN
   $(
      SWITCHON command INTO
      $(
      CASE w.set :
         do.set()
         ENDCASE

      CASE w.show :
         do.show()
         ENDCASE

      CASE w.c :
         IF reclevel \= 0 THEN
         $( writes("Can't connect from take file*N")
            erroring := TRUE
            ENDCASE
         $)
         IF remote THEN
         $( writes("Can't connect if remote*N")
            erroring := TRUE
            ENDCASE
         $)
         connect()
         ENDCASE

      CASE w.disconn :
         TEST remfd \= 0 THEN
         $(  erroring := \disconnect()
             UNLESS erroring DO remfd := 0
         $)
         ELSE
         $(  writes("*N No serial line open yet *N")
             erroring := TRUE
         $)
         ENDCASE

      CASE w.s :
      CASE w.r :
         handle.sr()
         ENDCASE

      CASE w.get :
         TEST local THEN do.get()
         ELSE
            writes("Can't perform get if remote*N")
         ENDCASE

      CASE w.close :
         IF reclevel \= 0 THEN RETURN     // If executing file
      CASE w.e :                          // Otherwise treat as end command
         BREAK

      CASE w.help :
         TEST nwords=1 THEN show.help()
         ELSE IF strcomp(argv!1,"SET") THEN show.set()
         ENDCASE

      CASE w.server :
         TEST remfd\=0 THEN
            TEST serve() THEN BREAK
            ELSE ENDCASE
         ELSE
         $( erroring := TRUE
            writes("No serial line open yet - can't serve*N") $)
//       writes("Server mode not yet implemented*N")
         ENDCASE

      CASE w.finish :
         TEST local THEN
         $(A
            remote.finish()
            selectinput(currentin)
            selectoutput(console)
         $)A
         ELSE
         $( erroring := TRUE
            writes("Can't issue finish if remote*N") $)
         ENDCASE

      CASE w.take :
         $( LET newin = findinput(argv!1)
            LET oldin = currentin
            IF newin < 0 THEN
            $( writef("Can't find file %S*N",argv!1)
               erroring := TRUE
               ENDCASE
            $)
            currentin := newin
            reclevel := reclevel+1
            writef(" TAKEing from file %S*N",argv!1)
            handle()
            reclevel := reclevel-1
            selectinput(currentin)
            endread()
            currentin := oldin
            ENDCASE
         $)
      $)
   $)
   ELSE
   $( erroring := TRUE
      writes("Bad command*N")
   $)
   IF erroring & (reclevel \= 0) THEN RETURN
$) REPEAT

/*
   s e r v e r

   Loop collecting commands from the other end
   and executing them
*/
AND serve() = VALOF
$( LET num,len = ?,?
   LET r = ?
   AND local.file.name = VEC 8
   AND closed.file = FALSE

   readchar := (ser.interface=interface.qconnect -> qcon.rdch,raw.rdch)
   local.fname := local.file.name
   n := 0
   serving := TRUE

   $( numfiles := 1
      filecnt := 0
      SWITCHON rpack(@len,@num,recpkt) INTO
      $(
      CASE 'I' :
         spack('Y',num,0,0)
         ENDCASE

      CASE 'S' :
         rpar(recpkt,len)
         len := spar(packet)
         report(TRUE)
         spack('Y',num,len,packet)
         oldtry := numtry
         numtry := 0
         n := (n+1) REM 64
         datstamp(starttime)

         TEST recsw() THEN
            datstamp(finishtime)
         ELSE finishtime!0 := -1
         ENDCASE

      CASE 'R' :
         FOR i=0 TO len-1 DO local.fname%(i+1) := recpkt%i
         local.fname%0 := len
         bytes := 0

         TEST sendsw() THEN
            datstamp(finishtime)
         ELSE finishtime!0 := -1
         ENDCASE

      CASE 'G' :                          // Generic commands
         SWITCHON recpkt%0 INTO
         $(
         CASE 'F' :                       // Finish
            FOR i = 1 TO 4 DO packet%(i-1) := "OK.*N"%i
            spack('Y',num,4,packet)
            r := FALSE                    // Don't exit
            BREAK
         CASE 'L' :                       // Logout
            FOR i = 1 TO 4 DO packet%(i-1) := "OK.*N"%i
            spack('Y',num,4,packet)
            r := TRUE                     // Exit
            BREAK
         $)

      DEFAULT :
      CASE FALSE :
         ENDCASE
      $)

      IF fd \= 0 THEN
      $( closed.file := close(fd)
         UNLESS closed.file=0 DO
           $( selectoutput(console)
              writes("*N*NFailed to close file at end of serving.*N")
              writef("Error code is %N*N",closed.file)
           $)
         fd := 0
      $)

   $) REPEAT
   serving := FALSE
   RESULTIS r
$)
AND remote.finish() = VALOF
$( LET num,len = ?,?
   IF remfd=0 THEN
   $(1
     WRITES("No serial line open yet*N")
     RESULTIS FALSE
   $)1

   numtry := 0
   n := 0
   packet%0 := 'F'
   $( spack('G',0,1,packet)
      SWITCHON rpack(@len,@num,recpkt) INTO
      $(
      CASE 'Y' :
         IF len \= 0 THEN message(recpkt,len)
         RESULTIS TRUE
      CASE 'N' :
      CASE FALSE :
         numtry := numtry+1
         IF numtry >= maxtry THEN RESULTIS FALSE
         ENDCASE
      DEFAULT :
         erroring := TRUE
         RESULTIS FALSE
      $)
   $) REPEAT
$)

AND show.help() BE
$( writes("CONNECT                        - Connect*N")
   writes("EXIT                           - Exit*N")
   writes("FINISH                         - Finish server mode on a *
                                           *remote kermit*N")
   writes("GET remote-fname local-fname   - Get file from a server*N")
   writes("HELP                           - This message*N")
   writes("RECEIVE local-fname            - Receive file*N")
   writes("SEND local-fname remote-fname  - Send file*N")
   writes("SET parameter value            - Set various options*N")
   writes("SERVER                         - Set server mode*N")
  writes("SHOW                           - Show the settable option settings*N"
   writes("TAKE local-fname               - Take commands from a file*N")
   writes("END                            - End of command stream*N")
   writes("DISCONN                        - Forcibly close serial line*N")
$)

/*
   Do.show

      Show a selection of currently set parameters etc.
*/

AND do.show() BE $(0
  LET option = 0
//
  screen(screen.clear)
  writes("  Settable options*N*N")
  writef(" DEBUGGING                   : %S*N",(debug -> "ON","OFF"))
  writef(" DELAY                       : %N seconds*N",remote.delay)
  writef(" DUPLEX                      : %S*N",
         (ser.duplex='F' -> "FULL","HALF"))
  writef(" 8BIT-PREFIX                 : %S*N",(quote8ing -> "ON","OFF"))
  writef(" END-OF-LINE                 : %S*N",
         (r.eol=cr -> "CR","LF"))
  newline()
  //
  SWITCHON ser.escape INTO
  $(2 // determine terminal escape character
    CASE kbd.f1 : option := "F1" ; ENDCASE
    CASE kbd.f2 : option := "F2" ; ENDCASE
    CASE kbd.f3 : option := "F3" ; ENDCASE
    CASE kbd.f4 : option := "F4" ; ENDCASE
    CASE kbd.f5 : option := "F5" ; ENDCASE

    CASE kbd.esc : option := "ESC" ; ENDCASE
    CASE kbd.ctrl.esc : option := "CTRL-ESC" ; ENDCASE
  $)2
  writef(" ESCAPE-CHAR                 : %S*N",option)
  SWITCHON ser.handshake INTO
  $(3 // determine handshaking mode
    CASE 'H' : option := "CTS/RTS" ; ENDCASE
    CASE 'X' : option := "XON/XOFF" ; ENDCASE
    CASE 'I' : option := "NONE" ; ENDCASE
  $)3
  writef(" HANDSHAKE                   : %S*N",option)
  writef(" MARKER (start of packet)    : #X%X2*N",r.sop)
  writef(" PACKET-LENGTH               : %N*N",r.packet.length)
  writef(" TAKE-ECHO                   : %S*N*N",
          (take.echo -> "ON","OFF"))
  IF reclevel=0 THEN
  $(B
    writes("*N*N (Hit any key for next page)")
    option := rdch()
    //
    screen(screen.clear)
  $)B
  newline()
  writef(" PADDING (amount)            : %N*N",r.pad)
  writef(" PAD-CHAR                    : #X%X2*N",r.padchar)
  SWITCHON ser.parity INTO
  $(4 // determine parity
    CASE 'E' : option := "EVEN" ; ENDCASE
    CASE 'O' : option := "ODD"  ; ENDCASE
    CASE 'M' : option := "MARK" ; ENDCASE
    CASE 'S' : option := "SPACE" ; ENDCASE
    CASE 'N' : option := "NONE" ; ENDCASE
  $)4
  writef(" PARITY                      : %S*N",option)
  writef(" PAUSE                       : %N seconds*N",ser.pause)
  writef(" PREFIX character            : %C*N",quote8)
  writef(" RETRY limit                 : %N*N",maxtry)
  newline()
  writef(" TIMEOUT                     : %N seconds*N",r.timeout)
  writef(" LINE                        : SER%C*N",ser.line)
  writef(" BAUD                        : %N*N",ser.baud)
  writef(" INTERFACE hardware          : %S*N",
          (ser.interface=interface.qconnect -> "QConnect","None"))
  newline()
  writef(" Serial line is currently    : %S ",
          (remfd=0 -> "CLOSED","OPEN"))
  TEST remfd=0 THEN newline()
               ELSE writef(" as %S*N",ser.name)
$)0
/*
   Handle the get command
*/
AND do.get() = VALOF
$( LET r = ?
   LET len,num = ?,?

   IF remfd=0 THEN
   $( WRITES("No serial line open yet*N")
      RESULTIS FALSE
   $)
   bytes := 0
   numtry := 0

   IF nwords<3 THEN
   $(1  WRITES("Command incomplete *N")
        RESULTIS FALSE
   $)1
   local.fname := argv!2
   filnam := argv!1
      FOR j = 0 TO filnam%0 -1 DO  packet%j := filnam%(j+1)
      spack('R',n,filnam%0,packet)
      r := recsw()
      UNLESS r THEN
      $( finishtime!0 := -1
         selectoutput(console)
         writef("Unable to receive %S*N",filnam)
         RESULTIS FALSE
      $)
   selectoutput(console)
   datstamp(finishtime)
   writes("*NOK.*N")
   RESULTIS TRUE
$)

/*
   Handle a Send/Receive command

*/
AND handle.sr() = VALOF
$( LET r = ?

   IF remfd=0 THEN
   $( WRITES("No serial line open yet*N")
      RESULTIS FALSE
   $)

   bytes := 0

   TEST command = w.s THEN
   $(
      IF nwords<3 THEN $(  WRITES("Command incomplete *N")
                           RESULTIS FALSE
                       $)
      filnam := argv!2
      local.fname := argv!1
      r := sendsw()
   $)
   ELSE
   $(
      IF nwords<2 THEN $(  WRITES("Command incomplete *N")
                           RESULTIS FALSE
                       $)
      local.fname := argv!1
      r := recsw()
   $)

   selectoutput(console)
   TEST r THEN
   $( datstamp(finishtime)
      IF \remote THEN writef("*NOK.*N")
   $)
   ELSE
   $( IF \remote THEN
         writef("%S failed.*N",command=w.s->"Send","Receive")
      finishtime!0 := -1
   $)
   IF fd \= 0 THEN
   $( close(fd)
      fd := 0
   $)
   RESULTIS FALSE
$)

/*       The following functions  are used in the parsing of the command
         line and the identification of words therein.

  PARSE.LINE(line,words) :  separates the string 'line' into words  i.e.
                            items delimited by spaces. The vector 'words'
                            is set to point to the items found : words!0
                            points to a string containing the first word
                            in the line, words!1 to the second, etc.

                            The value returned is the highest element of
                            'words' referred to, and is thus one less than
                            the number of words found.

                            The routine makes use of a vector referred to via
                            the global parse.buf and stores the parsed words
                            in that vector.
*/
AND parse.line(line,words) = VALOF $(0
LET ch,kwords,lch,thisword = 0,-1,0,0
AND linelength = 0
linelength := getbyte(line,0)
thisword := parse.buf
FOR K=1 TO linelength DO
$(1 // One character at a time
  ch := getbyte(line,K)
  IF ch \= SP THEN
  $(2 // Copy the character
    lch := lch + 1
    putbyte(thisword,lch,ch)
  $)2
  //
  // Test for the end of a word
  //
  IF ((ch = SP) & (lch \= 0)) | ((ch \= SP) & (K = linelength)) THEN
  $(3 // Found the end of a word
    putbyte(thisword,0,lch)
    kwords := kwords + 1
    words!kwords := thisword
    thisword := thisword + 1 + lch/4
    lch := 0
  $)3
$)1
RESULTIS kwords
$)0
//
//  strcomp compares two strings for equality
//
AND strcomp(string1,string2) = VALOF $(0
LET length1,length2 = getbyte(string1,0),getbyte(string2,0)
AND equality,nch = TRUE,0
TEST length1=length2 THEN
$(1 // Strings are of the same length so compare them byte by byte
  nch := nch + 1
  equality := (getbyte(string1,nch) = getbyte(string2,nch))
$)1 REPEATUNTIL ((NOT equality) | (nch = length1))
ELSE
$(2 // Strings are of different lengths and so must be different
  equality := FALSE
$)2
RESULTIS equality
$)0

/*
         DO.PARSE(aword,table) : locates the word 'aword' in the parse-table
                                 'table'.  If the word is found, the result
                                 is TRUE and the global 'command' is set to
                                 the position of the word in the table ;
                                 otherwise the result id FALSE and 'command'
                                 set to -1.
*/
AND do.parse(aword,wtable) = VALOF $(0
  LET k,kwords = 1,0
  LET found = FALSE
  kwords := wtable!0          // The number of words in this table
  $(1 // Compare each word in turn
    found := strcomp(aword,wtable!k)
    k := k + 1
  $)1 REPEATUNTIL found | (k > kwords)
  command := (found ->  k-1,-1)
  RESULTIS found
$)0

//       initialise() : sets up the command tables

AND initialise() BE $(0
//
// Set up the main command table first
//
main.com.table!0            :=  w.num.commands      // Number of commands
//
main.com.table!w.s          := "SEND"
main.com.table!w.r          := "RECEIVE"
main.com.table!w.c          := "CONNECT"
main.com.table!w.e          := "EXIT"
main.com.table!w.help       := "HELP"
main.com.table!w.set        := "SET"
main.com.table!w.show       := "SHOW"
main.com.table!w.server     := "SERVER"
main.com.table!w.finish     := "FINISH"
main.com.table!w.get        := "GET"
main.com.table!w.take       := "TAKE"
main.com.table!w.close      := "END"
main.com.table!w.disconn    := "DISCONN"
//
//  Now set up the SET command table
//
set.com.table!0             :=  ws.num.commands    // The number of settable
                                                   //  options
//
   set.com.table!ws.bchk         :=  "BLOCK-CHECK"    //Not implemented yet
   set.com.table!ws.debug        :=  "DEBUG"
   set.com.table!ws.delay        :=  "DELAY"
   set.com.table!ws.duplex       :=  "DUPLEX"
   set.com.table!ws.8bitpfx      :=  "8BIT-PREFIX"
   set.com.table!ws.eol          :=  "END-OF-LINE"
   set.com.table!ws.escchar      :=  "ESCAPE-CHAR"
   set.com.table!ws.flowcon      :=  "FLOW-CONTROL"   //Not implemented yet
   set.com.table!ws.handshake    :=  "HANDSHAKE"
   set.com.table!ws.log          :=  "LOG"            //Not implemented yet
   set.com.table!ws.marker       :=  "MARKER"
   set.com.table!ws.packetlength :=  "PACKET-LENGTH"
   set.com.table!ws.padding      :=  "PADDING"
   set.com.table!ws.parity       :=  "PARITY"
   set.com.table!ws.pause        :=  "PAUSE"
   set.com.table!ws.prefix       :=  "PREFIX"
   set.com.table!ws.repeatcount  :=  "REPEAT-COUNT"   //Not implemented yet
   set.com.table!ws.retry        :=  "RETRY"
   set.com.table!ws.timeout      :=  "TIMEOUT"
   set.com.table!ws.line         :=  "LINE"
   set.com.table!ws.dir          :=  "DIR"            //Not implemented yet
   set.com.table!ws.overwrite    :=  "OVERWRITE"      //Not implemented yet
   set.com.table!ws.baud         :=  "BAUD"
   set.com.table!ws.termtype     :=  "TERMINAL-TYPE"  //Not implemented yet
   set.com.table!ws.interface    :=  "INTERFACE"
   set.com.table!ws.padchar      :=  "PAD-CHAR"
   set.com.table!ws.take.echo    :=  "TAKE-ECHO"

// Set up the set-function table (see "KERSET" for details)

   set.function.table!ws.bchk         :=  not.yet.implemented
   set.function.table!ws.debug        :=  set.debug
   set.function.table!ws.delay        :=  set.delay
   set.function.table!ws.duplex       :=  set.duplex
   set.function.table!ws.8bitpfx      :=  set.8bitprefixing
   set.function.table!ws.eol          :=  set.eol
   set.function.table!ws.escchar      :=  set.terminal.escape
   set.function.table!ws.flowcon      :=  not.yet.implemented
   set.function.table!ws.handshake    :=  set.handshake
   set.function.table!ws.log          :=  not.yet.implemented
   set.function.table!ws.marker       :=  set.marker
   set.function.table!ws.packetlength :=  set.packetlength
   set.function.table!ws.padding      :=  set.padding
   set.function.table!ws.parity       :=  set.parity
   set.function.table!ws.pause        :=  set.pause
   set.function.table!ws.prefix       :=  set.prefix
   set.function.table!ws.repeatcount  :=  not.yet.implemented
   set.function.table!ws.retry        :=  set.retry
   set.function.table!ws.timeout      :=  set.timeout
   set.function.table!ws.line         :=  set.line
   set.function.table!ws.dir          :=  not.yet.implemented
   set.function.table!ws.overwrite    :=  not.yet.implemented
   set.function.table!ws.baud         :=  set.baud
   set.function.table!ws.termtype     :=  not.yet.implemented
   set.function.table!ws.interface    :=  set.interface
   set.function.table!ws.padchar      :=  set.pad.char
   set.function.table!ws.take.echo    :=  set.take.echo
//
//
//
$)0
//
AND readcommand(buffer) = VALOF
$(0
  LET nchs = readline(buffer,72)
  AND ch = 0
  TEST nchs = 0 THEN
    RESULTIS ENDSTREAMCH
  ELSE
  $(1
    nchs := nchs - 1
    FOR k=nchs-1 TO 0 BY -1 DO $(2 buffer%(k+1) := capitalch(buffer%k) $)2
    buffer%0 := nchs
    RESULTIS nchs
  $)1
$)0
//
AND open.serial.line() BE $(0
  LET name = TABLE 3,'S','E','R'
  AND nptr = 0
  nptr := PACKSTRING(name,ser.name)
  nptr := 4
  ser.name%nptr := ser.line                      // Choose SER1 or SER2
  nptr := nptr + 1
  TEST ser.interface\=interface.qconnect THEN
  $(1 // Raw communicatons, no little black boxes
    UNLESS ser.parity='N' DO $(2
                                 ser.name%nptr := ser.parity
                                 nptr := nptr + 1
                             $)2

    UNLESS ser.handshake='X' DO  $(3
                                     ser.name%nptr := ser.handshake
                                     nptr := nptr + 1
                                 $)3

    ser.name%nptr := 'R'                         // Raw data, no EOF
    ser.name%0 := nptr                           // Length of name
    baud(ser.baud)                               // Set baud rate
    remfd := OPEN(ser.name,0,0)                  // Open the channel

    IF remfd<0 THEN
    $(4 // Whoops, we've failed to open the serial line !
      WRITEF("*N Unable to open serial line %S (QDOS error code %N)*N",
             ser.name,remfd)
      remfd := 0
      RETURN
    $)4
  $)1
  ELSE
  $(5 // Communications via a QConnect box
    UNLESS qcon.init DO qcon.reset()
    ser.name%nptr := 'H'                         // CTS/RTS between QL and box
    nptr := nptr + 1
    ser.name%nptr := 'R'                         // Raw data, no EOF
    ser.name%0 := nptr
    baud(9600)
    remfd := OPEN(ser.name,0,0)
    IF remfd<0 THEN
    $(6
      WRITEF("*N Unable to open serial line %S (QDOS error %N)*N",ser.name,
              remfd)
      remfd := 0
      RETURN
    $)6
    qcon.initialise()
  $)5
$)0
//
AND find.new.file(name) = VALOF $(0
  LET exists = FINDINPUT(name)
  debug.report(writef,"*NTrying to open new file %S*N",name)
  IF exists>0 THEN
  $(1 // The file already exists
    close(exists)
    debug.report(writes,"Failed - file already exists*N")
    RESULTIS -8                   // QDOS ERR.EX code
  $)1
  exists := findoutput(name)
  TEST exists>0 THEN debug.report(writes,"File opened successfully*N")
  ELSE debug.report(writef,"Failed - error code is %N*N",exists)
  RESULTIS exists
$)0
//
AND find.old.file(name) = VALOF $(0
  LET exists = findinput(name)
  debug.report(writef,"*NTrying to open old file %S*N",name)
  TEST exists>0 THEN debug.report(writes,"File opened successfully*N")
  ELSE debug.report(writef,"Failed - error code %N*N",exists)
  RESULTIS exists
$)0
AND message(m,n) BE FOR i=0 TO n-1 DO wrch(m%i)
AND end.kermit() BE $(0
  screen(screen.clear)
  writes("QL Kermit : exiting back to SuperBasic*N")
  STOP(0)
$)0
AND datstamp(x) BE !x := time()
//
AND qcon.reset() BE $(0
  IF remfd\=0 DO close(remfd)
  remfd := OPEN("SER2IR",0,0)
  selectoutput(remfd)
  writes("%X1F%X21%X70")
  close(remfd)
  qcon.init := TRUE
  selectoutput(console)
  ink(red)
  writes("*N QConnect reset OK*N")
  ink(green)
$)0
//
AND qcon.initialise() BE $(0
  LET inits = TABLE #X1F164A35, #X00600E00
  AND ch = 0
  //
  // Parity
  //
  IF ser.parity='E' | ser.parity='O' THEN
  $(1
    ch := 16 + (ser.parity='E' -> 32,0)
    inits%2 := inits%2 | ch
    inits%5 := inits%5 | 32
  $)1
  //
  // Handshake
  //
  UNLESS ser.handshake='N' DO
  $(2
    ch := 2 + (ser.handshake='X' -> 64,1)
   inits%5 := inits%5 | ch
  $)2
  //
  // Baud
  //
  ch := 0
  SWITCHON ser.baud INTO
  $(3
    CASE 9600 :            ENDCASE
    CASE 4800 :  ch := 1 ; ENDCASE
    CASE 2400 :  ch := 2 ; ENDCASE
    CASE 1200 :  ch := 3 ; ENDCASE
    CASE  600 :  ch := 4 ; ENDCASE
    CASE  300 :  ch := 5 ; ENDCASE
    CASE  150 :  ch := 6 ; ENDCASE
    DEFAULT   :  catastrophe("Illegal baud rate value in qcon.init")
  $)3
  ch := ch + (ch << 3)
  inits%4 := ch
  selectoutput(remfd)
  writebytes(inits,8)
  selectoutput(console)
  ink(red)
  writef("*N QConnect initialised with string %X8 %X8*N",inits!0,inits!1)
  ink(green)
$)0
//
AND raw.rdch() = VALOF $(0
  LET ch = inkey(0)
  WHILE ch<0 & time()<=endtime DO ch := inkey(0)
  RESULTIS (ch<0 -> rpack.timeout,ch)
$)0
AND qcon.rdch() = VALOF $(0
  LET ch = raw.rdch()
  UNLESS ch=USC THEN RESULTIS ch
  ch := inkey(-1)
  RESULTIS (ch=USC -> USC,rpack.timeout)
$)0
//
AND BAUD(speed) BE $(0
  LET regsin = VEC 7
  AND regsout = VEC 7
  regsin!0 := #X12                     // MT.BAUD
  regsin!1 := speed
  qtrap(1,regsin,regsout)
$)0
//
AND beep() BE $(0
/*  LET regsin = VEC 7
  AND regsout = VEC 7
  AND bparms = TABLE #X0A0B0000, #XAAAA0000, #X00000000, #X00000000
  regsin!0 := #X11                     // MT.IPCOM
  regsin!7 := bparms << 2              // MC address of parameters
  qtrap(1,regsin,regsout)
*/
  ink(red)
  writes("<beep>")
  ink(green)
$)0
//
AND glasstty() BE $(0
  LET ch,lastch = 0,0
  selectoutput(console)
  screen(screen.cursor)
  $(1 // Terminal emulation loop
    selectinput(console)
    ch := inkey(0)
    IF ch=ser.escape THEN BREAK
    IF ch=kbd.left | ch=kbd.ctl.left THEN ch := kbd.del
    IF ch>0 & ch<128 THEN
    $(1
      selectoutput(remfd)
      wrch((ch=LF -> CR,ch))
    $)1
    selectinput(remfd)
    ch := inkey(0)
    IF ch<0 THEN LOOP
    selectoutput(console)
    ch := ch & #X7F
    IF ser.interface=interface.qconnect & ch=USC THEN
    $(5 // Handle USC sequence from QConnect box
      ch := INKEY(-1)                  // Get this byte at all costs
      IF ch\=USC DO
      $(6  qcon.report(ch)
           LOOP
      $)6
    $)5
    TEST ch<SP THEN
    $(2 // It's non-printing
      SWITCHON ch INTO
      $(3
        CASE CR  : wrch(LF) ; ENDCASE

        CASE LF  : UNLESS LASTCH=CR DO wrch(LF) ; ENDCASE

        CASE BEL : beep() ; ENDCASE

        CASE BS  : screen(screen.left) ; ENDCASE

        CASE FF  : screen(screen.clear) ; ENDCASE

        DEFAULT : wrx(ch) ; ENDCASE
      $)3
    $)2
    ELSE
    $(4 // It's a valid ASCII character
      wrch(ch)
    $)4
    lastch := ch
  $)1 REPEAT
  selectinput(console)
  selectoutput(console)
$)0
AND disconnect() = VALOF $(0
  IF remfd=0 THEN RESULTIS TRUE
  TEST close(remfd)=0 THEN
  $(1
    remfd := 0
    RESULTIS TRUE
  $)1
  ELSE
  $(2
    catastrophe("Failed to close serial line")
    RESULTIS FALSE
  $)2
$)0
//
AND connect() BE $(0
  LET disced = FALSE
  IF remfd\=0 & ser.corrupt DO
  $(1 // Try to drop serial line
    UNLESS disconnect() DO catastrophe("Cannot disconnect")
  $)1
  IF remfd=0 DO open.serial.line()
  UNLESS remfd\=0 DO catastrophe("Cannot connect")
  ser.corrupt := FALSE
  glasstty()
$)0
//
AND catastrophe(text) BE $(0
  LET new.con = FINDTERMINAL()
  selectoutput(new.con)
  screen(screen.clear)
  beep()
  writes(text)
  newline()
  STOP(-1)
$)0
//
AND qcon.report(ch) BE $(0
  newline()
  beep()
  ink(red)
  writef(" QConnect USC sequence, byte %X2*N",ch)
  ink(green)
$)0
//
AND ink(colour) BE screen(screen.ink,colour)
//
AND show.set() BE $(0
  LET nopts = ws.num.commands/2
  selectoutput(console)
  writes("Settable options : *N")
  FOR k=0 TO 2*(nopts-1) BY 2 DO
  $(1
    newline()
    writes(set.com.table!(k+1))
    screen(screen.tab,40)
    writes(set.com.table!(k+2))
  $)1
  nopts := ws.num.commands REM 2
  IF nopts=1 DO $(2 newline() ; writes(set.com.table!ws.num.commands) $)2
  newline()
$)0
//
AND wrx(ch) BE $(0
  ink(red)
  writef("<#X%X2>",ch)
  ink(green)
$)0
//
// Our ABORT exit routine
//
AND kermit.abort(code) BE $(0
  selectoutput(console)
  screen(screen.clear)
  sys.abort(code)
$)0
//
// debug.report : cf. cons in kerproto.bcpl
//
AND debug.report(f,a1,a2,a3,a4,a5) BE IF debug THEN
$(0 LET co = COS
    selectoutput(debug.fd)
    f(a1,a2,a3,a4,a5)
    selectoutput(co)
$)0
//
// QDOS call to change the priority of the current job
//
AND change.my.priority(priority) BE $(0
  LET regsin = VEC 7
  AND regsout = VEc 7
//
  regsin!0 := #X0B        // MT.PRIOR
  regsin!1 := -1          // change my priority
  regsin!2 := priority & #X7F  // priority must be in range 0 to 127
//
  qtrap(1,regsin,regsout)
$)0
//
AND sendchars(buffer,nchars) BE writebytes(buffer,nchars)