file pfkerm.src

   This is a conversion of the Forth block file KERMIT.SCR
   so as to be readable as a plain text file.  Do not try
   load it (compile it) without editing it to suit your
   version of Forth.  Don't load it under Pygmy Forth;
   instead, get the actual block files from

         http://www.eskimo.com/~pygmy/pfkerm.zip



KERMIT.SCR
  Contains a simple implementation of the Kermit
  file transfer protocol.

  copyright 1997 Frank Sergeant               pygmy@pobox.com
                 809 W. San Antonio St.
                 San Marcos, TX  78666

  This source code is not Public Domain or Shareware.
  You may use it freely for any private or commercial purpose
  provided you do so at your own risk.






( load screen    Kermit file transfer protocol)

 "  *** Simple Kermit file transfer protocol Copyright (c) 1997
Frank Sergeant (pygmy@pobox.com) *** "  DROP


12002 12024 THRU










EXIT ( KERMIT - user interface)

: GET-Y/N ( - f)
  BEGIN KEY DUP 'Y = OVER 'y = OR IF DROP -1 EXIT THEN
            DUP 'N = SWAP 'n = OR IF       0 EXIT THEN  BEEP
  AGAIN  ;

: TRY-AGAIN? ( a - f)
  CR COUNT TYPE CR ." Try again? (Y/N) "
  GET-Y/N  ( f)  ;

: .MSG ( a -) 0 0 AT 160 SPACES  0 0 AT COUNT TYPE  ;





( KERMIT)
1 CONSTANT SOH
VARIABLE SEQ    SEQ OFF
: BUMPSEQ ( -) SEQ @ 1+ 63 AND SEQ !  ;
  94  ( 35) CONSTANT MYMAXL ( fields SEQ TYPE DATA & CKSUM)

CREATE OUT-BUF  MYMAXL ( 1+) 2 + ALLOT     VARIABLE OUTLEN
CREATE  IN-BUF  MYMAXL ( 1+) 2 + ALLOT     VARIABLE INLEN

: ?NUM-OK ( n -) $5E > ABORT" too big"  ;
: CHAR ( n - c) DUP ?NUM-OK ( n) $20 +  ;
: UNCHAR ( c - n) $20 - ( n) DUP ?NUM-OK  ;





( KERMIT  - protocol parameters)
VARIABLE MAXL
VARIABLE QCTL
VARIABLE NPAD
VARIABLE PADC
VARIABLE EOLC
VARIABLE TIMEOUT

: INIT-LIMITS ( -)
  MYMAXL MAXL !  ( maximum "len" value)
      '# QCTL !  ( control code escape character)
       0 NPAD !  ( number of pad characters)
       0 PADC !  ( pad character)
     $0D EOLC !  ( end of line character)
    4 TIMEOUT !  ( timeout in seconds)     ;   INIT-LIMITS


( KERMIT  - address of fields in buffers)
: FIELD: ( offset -) ( buff - a) CREATE C,   DOES> C@ +  ;

0 FIELD: >LEN
1 FIELD: >SEQ
2 FIELD: >TYPE
3 FIELD: >DATA
: >CKSUM ( buff - a) >LEN DUP C@ UNCHAR  +  ;

3 FIELD: >MAXL
4 FIELD: >TIME
5 FIELD: >NPAD
6 FIELD: >PADC
7 FIELD: >EOLC
8 FIELD: >QCTL


( KERMIT - compromise on the parameters)

: COMPROMISE ( -)
  OUT-BUF IN-BUF ( a a)
  OVER >MAXL C@ UNCHAR  OVER >MAXL C@ UNCHAR
      MIN  MAXL ! ( a a)
  OVER >TIME C@ UNCHAR  OVER >TIME C@ UNCHAR
      MAX  TIMEOUT ! ( a a)    2DROP  ;









DEFER M  ( the menu to return to)
: KSER-IN ( - c f)
  TIMEOUT @ 1000 * ( ms)
  BEGIN  KEY? IF KEY DROP CR
                    ." Abort file transfer (Y/N)? "  GET-Y/N CR
                    IF ." Transfer aborted -- press "
                       ." any key to return to menu"
                       KEY DROP M
                    ELSE ." Transfer continuing "
              THEN  THEN
    SER-IN? IF ( ms) DROP SER-IN DUP SOH = ( c f) EXIT THEN
    ( ms) 1-  DUP 0= IF POP 2DROP 'V  -1 EXIT THEN     1 MS
  AGAIN  ;

: TEST-IN ( - c f)  KSER-IN  ;


( KERMIT )
: CTRL ( c - c')
  DUP QCTL @ = OVER '~ = OR IF EXIT THEN  $40 XOR  ;

: CTRL? ( c - f)
  DUP $20 < OVER QCTL @ = OR OVER $7E = OR SWAP $7F = OR  ;

: (KEMIT ( c -) OUT-BUF  OUTLEN @ + C! (  ) 1 OUTLEN +!  ;

: KEMIT  ( c -)  PAUSE ( just in case)
  ( c) DUP CTRL? IF  QCTL @ (KEMIT  CTRL  ( c) THEN (KEMIT  ;

: ROOM? ( - u) MAXL @ 1- OUTLEN @  >  ;




( KERMIT )
: CK%% ( u - c)
  DUP $C0 AND 2/ 2/ 2/ 2/ 2/ 2/ + $3F AND CHAR ;

: CKSUM ( buffer - c) >LEN DUP C@ UNCHAR ( a #) 0 ROT ROT
  FOR ( sum a) C@+ +UNDER NEXT DROP  CK%% ( c)  ;

: CKSUM? ( - f)
  IN-BUF CKSUM ( c)  IN-BUF >CKSUM C@ ( c c)  =  ;









DEFER MODEM!
( ' EMIT)  ' SER-OUT IS MODEM!

: DATA! ( a # - a' #')    SWAP  ( # a)
  BEGIN ( # a) OVER 0= ROOM? 0= OR ( ie out of source or room)
   NOT WHILE ( # a) C@+ KEMIT  -1 +UNDER  REPEAT SWAP ( a #) ;

: BUILD-FRAME ( a # type - a' #')   OUTLEN OFF
  0 ( ie dummy len) CHAR (KEMIT    SEQ @ CHAR (KEMIT
  (KEMIT ( a #) DATA! ( a' #')
  OUTLEN @ CHAR  OUT-BUF >LEN C!  ( a #)
  OUT-BUF CKSUM  OUT-BUF >CKSUM C! ( a #)  ;




( KERMIT - debugging aids)

: .FRAME ( buf -) ." len = "  C@+ UNCHAR DUP PUSH 2 U.R
  ."  seq = " C@+ UNCHAR 2 U.R SPACE SPACE
  ." myseq = " SEQ @ 2 U.R SPACE SPACE
  POP 1- TYPE  CR  ;

: .INB ( type -) .S 3 SPACES
   'V = IF ." V-frame "  CR ELSE ."  IN: " IN-BUF .FRAME THEN ;

: .OUTB ( -) .S 3 SPACES ." OUT: " OUT-BUF .FRAME  ;

" WHAT DOES THE SYMBOL # STAND FOR?" CONSTANT TEST1

" as much labor for the study of its" CONSTANT TEST2


( KERMIT)

: SENDFRAME ( -) SOH MODEM!  OUT-BUF >LEN DUP C@ UNCHAR 1+
 FOR ( a) C@+ MODEM!  NEXT DROP (  )  $0D MODEM!  ;













( KERMIT)
: LIMITS ( type -)
  SEQ OFF  PUSH
  '~  ( the repeat char)
  '1  ( 1-byte chksum, either '1 or 1 CHAR seems to work)
  'N  ( no hi-bit prefix)
  QCTL @          EOLC @ CHAR  PADC @ CTRL
  NPAD @ CHAR  TIMEOUT @ CHAR  MAXL @ CHAR    POP
  SEQ @ CHAR   12 ( len) CHAR
  OUT-BUF  12 FOR DUP PUSH C!  POP 1+ NEXT DROP  (  )
  OUT-BUF CKSUM  OUT-BUF >CKSUM C!  ;






( KERMIT)
: BUILD/SEND  ( a # type -) BUILD-FRAME  SENDFRAME 2DROP  ;
: KINIT ( -) 'S LIMITS  SENDFRAME  ;
: KINITACK ( -) 'Y LIMITS COMPROMISE 'Y LIMITS SENDFRAME  ;
: FILEHEADER ( a # -) " sending file " .MSG 2DUP TYPE
  ( a #)   'F BUILD/SEND  ;
: EMPTY-FRAME ( type -) (  ) CREATE C,
  DOES> C@ 0 0 ROT BUILD/SEND  ;

'Y EMPTY-FRAME (ACK     'N EMPTY-FRAME (NAK
'Z EMPTY-FRAME EOF      'B EMPTY-FRAME EOT
'A EMPTY-FRAME ATTRIB   'E EMPTY-FRAME ERROR

: ACK ( seq# -) SEQ @ SWAP SEQ ! (ACK  SEQ !  ;
: NAK ( seq# -) SEQ @ SWAP SEQ ! (NAK  SEQ !  ;


( KERMIT)

VARIABLE EXPECTED

: INBUF! ( c -)  IN-BUF INLEN @ + C!  1 INLEN +!  ;

: SETLENGTH ( clength -)
  INLEN OFF  DUP INBUF!  ( c)   UNCHAR  EXPECTED !  ;

: PUT-IN-BUFFER ( c - f)  INBUF! INLEN @ EXPECTED @ > ;







( KERMIT)

: GETFRAME ( -  type f)
  BEGIN KSER-IN NIP UNTIL (  )  ( ie await SOH)
  BEGIN
     BEGIN KSER-IN WHILE DROP REPEAT ( c) SETLENGTH (  )
     BEGIN KSER-IN NOT WHILE ( c) PUT-IN-BUFFER ( f)
      IF  IN-BUF >TYPE C@ CKSUM?
          OVER 'E = OVER AND ABORT" Fatal Error in Kermit"
          EXIT THEN (  )
     REPEAT ( c) DROP
  AGAIN  ( type f)  ;





( KERMIT)

: GET-GOOD-FRAME ( - type)
  BEGIN  GETFRAME ( type cksumflag) NOT WHILE
       ."  bad cksum " DROP  REPEAT  ;


: IN-SEQ ( - u)  IN-BUF >SEQ C@ UNCHAR  ;

: GOOD-SEQ? ( - f)  IN-SEQ SEQ @ =  ;







( KERMIT)
: (GETACK ( - type)
  BEGIN GETFRAME ( type f) NOT WHILE DROP REPEAT ( type)  ;

: GETACK ( -)
  BEGIN   (GETACK  ( type)
    'Y OF  GOOD-SEQ? ( f) DUP IF BUMPSEQ THEN    ( f)  ELSE
    'N OF  GOOD-SEQ? IF SENDFRAME THEN              0  ELSE
    'V OF  SENDFRAME                                0  ELSE
    ( default) DROP  0 [ 3 ] THENS ( f)
  UNTIL  ;

: READ ( h - a #) PUSH 32767 BUFFER ( ie dummy buffer)
  DUP 1024 POP FILE-READ #BYTES-READ @  ;



( KERMIT)

: GET-FIRST-NAK ( -) BEGIN (GETACK 'N = UNTIL  ;

: SEND ( name -) CLS " Waiting to send " .MSG INIT-LIMITS
  DUP FOPEN IF CR ." cannot open input file" CR  EXIT THEN
  ( name h) 1000 MS  ( name h)   GET-FIRST-NAK
  ( n h)  KINIT RESET-SER-IN  GETACK
  COMPROMISE  SWAP COUNT ( h a #) FILEHEADER ( h) GETACK
  BEGIN ( h) DUP READ DUP WHILE ( h a #)
   BEGIN 'D BUILD-FRAME SENDFRAME GETACK  '. EMIT
   DUP 0= UNTIL 2DROP
  REPEAT 2DROP ( h) FCLOSE (   ) EMPTY-BUFFERS ( just in case)
  EOF GETACK  EOT GETACK  ;



( KERMIT)

CREATE IN-DATA    MYMAXL 3 / 94 * 2 +  ALLOT

: C!+ ( c a - a+) DUP PUSH C! POP 1+  ;

: C@+- ( fr # - fr # c) 1- PUSH C@+ POP SWAP  ;

: UNCTRL'd ( from # c - from # c)
  DUP QCTL @ - IF EXIT THEN    DROP C@+- CTRL   ;







( KERMIT)
: REPEAT'd ( to from # - to from #)  ROT PUSH ( fr #)
  C@+- UNCHAR PUSH C@+- ( fr # c) UNCTRL'd ( fr # c)
  POP POP ( ie rpt# to) 2DUP + PUSH ( fr # c rpt# to)
  SWAP ROT FILL ( fr #) POP ROT ROT ( to fr #)  ;

: UNCTRL ( from to # - a #)
  ROT PUSH PUSH DUP POP POP SWAP ( to to from #)
  BEGIN DUP WHILE ( to to fr #)
      C@+- DUP '~ = IF ( to to fr # c) DROP REPEAT'd
      ELSE UNCTRL'd PUSH ROT POP SWAP C!+ ROT ROT  THEN
  REPEAT ( to to fr 0) 2DROP  OVER -  ( a #)  ;

: >IN-DATA ( - a #) IN-BUF >DATA IN-DATA ( from to)
  IN-BUF C@ UNCHAR 3 - ( from to #) UNCTRL ;


( KERMIT)
VARIABLE KHANDLE
CREATE KFNAME 50 ALLOT

: BUILDFNAME ( -)
  >IN-DATA ( a #) DUP PUSH KFNAME 1+ SWAP CMOVE (  )
  0 KFNAME R@ + 1+ C!  ( make name into an asciiz string)
  POP KFNAME C!   ;

: RCVNAME ( -)
  BUILDFNAME   KFNAME FMAKE ( h f)
  ABORT" cannot open output file" ( h) KHANDLE !
  " receiving file " .MSG KFNAME COUNT TYPE SPACE  ;




( KERMIT)
: GETNEXT ( - type)
  BEGIN GETFRAME ( type f)
     IF ( type) DUP 'V =
        IF ( type) SEQ @ NAK    -1  ( type f)
        ELSE ( type) IN-SEQ DUP ACK ( type seq) SEQ @ -
        THEN
     ELSE
        ( ie bad cksum)
        SEQ @ NAK  -1  ( type f)  ( -1 ABORT"  BAD CKSUM" )
     THEN
   WHILE DROP
  REPEAT   BUMPSEQ  ;

: WRITE ( -) >IN-DATA KHANDLE @ ( a # h) FILE-WRITE   ;


( KERMIT)

: RECEIVE ( -) CLS  " Waiting to receive " .MSG
  RESET-SER-IN    INIT-LIMITS
  BEGIN 0 NAK  1000 MS  GET-GOOD-FRAME  'S = UNTIL
  (  ) KINITACK  BUMPSEQ
  BEGIN  GETNEXT ( type) ( DUP EMIT )
     'D OF  WRITE  '. EMIT       0  ELSE
     'F OF  RCVNAME              0  ELSE
     'Z OF  KHANDLE @ FCLOSE     0  ELSE
     'B OF                      -1  ELSE
     ( otherwise)  DROP          0 [ 4 ] THENS
  UNTIL  (  )  ;


(end file pfkerm.src)
