' SerTrans: Empfangsteil

DECLARE SUB PrintErr (z$, f%)
DECLARE SUB ErzeugeCRCTab ()
DECLARE FUNCTION crc$ (fr$)

DIM crcTab%(255)
SHARED CRCkonst&, crcTab%()

ErzeugeCRCTab

INPUT "Datei, wo empfangen werden soll"; d$
INPUT "COM-Schnittstelle:Geschwindigkeit (bps), z.B. 2:38400"; g$
ON ERROR GOTO Fehler
10 OPEN "COM" + g$ + ",N,8,1,CD0,CS0,DS0,ME" FOR RANDOM AS 1 LEN = 16384
15 OPEN d$ FOR OUTPUT AS 2
Seq% = 0
RcvBuf$ = ""
l% = 255
stat% = 0
tout! = TIMER + 3!
sqMess% = Seq%
tMess! = TIMER
WHILE l% = 255 AND stat% <> 3
  kk$ = INKEY$
  SELECT CASE kk$
  CASE "e"
    stat% = 1
  CASE "n"
    IF stat% = 1 THEN
      stat% = 2
    ELSE
      stat% = 0
    END IF
  CASE "d"
    IF stat% = 2 THEN
      stat% = 3
    ELSE
      stat% = 0
    END IF
  CASE "s"
    tM! = TIMER
    aPak% = Seq% - sqMess%
    IF aPak% <= 0 THEN
      aPak% = aPak% + 256
    END IF
    COLOR 5
    PRINT "šbertragungsrate:"; CSNG(aPak%) * 255! / (tM! - tMess!); "Bytes/Sek.";
    COLOR 7
    sqMess% = Seq%
    tMess! = tM!
  CASE ""
    ' Nichts tun
  CASE ELSE
    stat% = 0
  END SELECT
  a% = LOC(1)
  IF a% = 0 THEN
    IF TIMER > tout! AND RcvBuf$ <> "" THEN
      RcvBuf$ = ""     ' Daten verwerfen
      COLOR 14
      PRINT "T";
      COLOR 7
      GOSUB Quittung
      tout! = tout! + 3!
    END IF
  ELSE
20  RcvBuf$ = RcvBuf$ + INPUT$(a%, 1)
    IF LEN(RcvBuf$) >= 261 THEN
      notOk% = -1
      IF LEN(RcvBuf$) = 261 THEN
        ' Prfe STX und ETX
        IF LEFT$(RcvBuf$, 1) = CHR$(2) AND RIGHT$(RcvBuf$, 1) = CHR$(3) THEN
          ' Prfe CRC
          IF CVI(crc$(MID$(RcvBuf$, 2, 259))) = 0 THEN
            IF ASC(MID$(RcvBuf$, 2, 1)) = Seq% THEN
              l% = ASC(MID$(RcvBuf$, 3, 1))
25            PRINT #2, MID$(RcvBuf$, 4, l%);
              notOk% = 0
              Seq% = Seq% + 1 AND 255
              PRINT "*";
            ELSE
              COLOR 10
              PRINT "?";  ' falsche Sequenznummer
              COLOR 7
            END IF
          ELSE
            COLOR 12
            PRINT "!";   ' CRC-Fehler
            COLOR 7
          END IF
        ELSE
          COLOR 3
          PRINT "F";   ' Frame-Header/Trailer falsch
          COLOR 7
        END IF
      ELSE
        COLOR 13
        PRINT "M";    ' Mll erhalten
        COLOR 7
      END IF
      GOSUB Quittung
      IF notOk% THEN
        tout! = TIMER + .6
        a% = 1
        WHILE TIMER < tout! OR a% > 0
          a% = LOC(1)
          IF a% > 0 THEN
30          dummy$ = INPUT$(a%, 1)
          END IF
        WEND
      END IF
    END IF
    tout! = TIMER + 3!
  END IF
WEND
CLOSE 2
CLOSE 1
ON ERROR GOTO 0
END

Quittung:
Tel$ = CHR$(2) + CHR$(Seq%) + crc$(CHR$(Seq%) + MKI$(0)) + CHR$(3)
40 PRINT #1, Tel$;
RcvBuf$ = ""
RETURN

Fehler:
SELECT CASE ERL
CASE 10
  COLOR 15
  PrintErr "™", ERR
  SLEEP 1!
  RESUME
CASE 20
  PrintErr "E", ERR
  SLEEP 1!
  RESUME NEXT
CASE 30
  PrintErr "D", ERR
  SLEEP 1!
  RESUME NEXT
CASE 40
  PrintErr "T", ERR
  SLEEP 1!
  RESUME
END SELECT
PRINT
PRINT "Ein echter Fehler"; ERR; "trat an;"; ERL; "auf"
STOP

FUNCTION crc$ (fr$)
  f1$ = fr$
  FOR I% = 2 TO LEN(fr$) - 1
    MID$(f1$, I%) = MKI$(CVI(MID$(f1$, I%, 2)) XOR crcTab%(ASC(MID$(f1$, I% - 1, 1))))
  NEXT I%
  crc$ = RIGHT$(f1$, 2)
END FUNCTION

SUB ErzeugeCRCTab
  CRCPoly% = &H1021     ' entspricht X.25-Standard
  CRCkonst& = CLNG(CRCPoly%) + 65536
  w& = 0&
  FOR I% = 0 TO 255
    c% = I%
    FOR j% = 1 TO 8
      w& = 2& * w& + (c% AND 1)
      c% = c% \ 2
    NEXT j%
    w& = 256& * w&
    FOR j% = 1 TO 8
      w& = 2& * w&
      IF (w& AND 65536) <> 0 THEN
        w& = w& XOR CRCkonst&
      END IF
    NEXT j%
    w1& = 0&
    FOR j% = 1 TO 16
      w1& = 2& * w1& + (w& AND 1&)
      w& = w& \ 2&
    NEXT j%
    crcTab%(I%) = CVI(LEFT$(MKL$(w1&), 2))
  NEXT I%
END SUB

SUB PrintErr (z$, f%)
  COLOR 15
  PRINT z$; MID$(STR$(f%), 2);
  COLOR 7
END SUB