home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
c
/
ucterak.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
2020-01-01
|
90KB
|
2,767 lines
>>>> UCSD Pascal KERMIT for the Terak p-System, from Kate MacGregor, Cornell U
>>>>
>>>> All files are concatenated together into this single file, separated by
>>>> lines beginning like this one does, followed by the name of the file.
>>>>
>>>> HELP.TEXT
segment procedure help;
procedure keypress;
const clearscreen = 12;
var ch: char;
begin
writeln('---------------Press any key to continue---------------');
repeat
until readch(kq,ch);
writeln(chr(clearscreen))
end; (* keypress *)
procedure help1;
var ch: char;
begin
if (noun = nullsym) then
begin
writeln('KERMIT is a family of programs that do reliable file transfer');
write('between computers over TTY lines. KERMIT can also be ');
writeln('used to make the ');
writeln('microcomputer behave as a terminal for a mainframe. These are the ');
writeln('commands for theUCSD p-system version, KERMIT-UCSD:');
writeln
end; (* if *)
if (noun = nullsym) or (noun = consym) then
begin
writeln(' CONNECT To make a "virutual terminal" connection to a remote');
writeln(' system.');
writeln;
write(' To break the connection and "escape" back to the micro,');
writeln;
writeln(' type the escape sequence (CTRL-] C, that is Control ');
writeln(' rightbracket followed immediately by the letter C.)');
writeln;
end; (* if *)
if (noun = nullsym) or (noun = exitsym) then
begin
writeln(' EXIT To return back to main command level of the p-system.');
writeln;
end; (* if *)
if (noun = nullsym) or (noun = helpsym) then
begin
writeln(' HELP To get a list of KERMIT commands.');
writeln;
end; (* if *)
if (noun = nullsym) or (noun = quitsym) then
begin
writeln(' QUIT Same as EXIT.');
writeln;
end; (* if *)
if (noun = nullsym) or (noun = recsym) then
begin
writeln(' RECEIVE To accept a file from the remote system.');
writeln;
end; (* if *)
end; (* help1 *)
procedure help2;
var ch: char;
begin
if (noun = nullsym) or (noun = sendsym) then
begin
writeln(' SEND To send a file or group of files to the remote system.');
writeln;
end; (* if *)
if (noun = nullsym) then
keypress;
if (noun = nullsym) or (noun = setsym) then
begin
writeln(' SET To establish system-dependent parameters. The ');
writeln(' SET options are as follows: ');
writeln;
if (adj = nullsym) or (adj = debugsym) then
begin
writeln(' DEBUG To set debug mode ON or OFF ');
writeln(' (default is OFF).');
writeln;
end; (* if *)
if (adj = nullsym) or (adj = escsym) then
begin
writeln(' ESCAPE To change the escape sequence that ');
writeln(' lets you return to the PC Kermit from');
write(' the remote host.');
writeln(' The default is CTRL-] c.');
writeln;
end; (* if *)
if (adj = nullsym) or (adj = filewarnsym) then
begin
writeln(' FILE-WARNING ON/OFF, default is OFF. If ON, ');
writeln(' Kermit will warn you and rename an ');
writeln(' incoming file so as not to write over');
writeln(' a file that currently exists with the');
writeln(' same name');
writeln;
end; (* if *)
if (adj = nullsym) then
keypress;
end; (* if *)
end; (* help2 *)
procedure help3;
begin
if (noun = nullsym) or (noun = setsym) then
begin
if (adj = nullsym) or (adj = ibmsym) then
begin
writeln(' IBM ON/OFF, default is OFF. This flag ');
write(' should be ON only when ');
writeln('transfering files');
writeln(' between the micro and an IBM VM/CMS');
writeln(' system. It also causes the parity to');
write(' be set appropriately ');
writeln('(mark) and activates');
writeln(' local echoing');
writeln;
end; (* if *)
if (adj = nullsym) or (adj = localsym) then
begin
write(' LOCAL-ECHO ON/OFF, default is OFF. This sets the');
writeln;
writeln(' duplex. It should be ON when using ');
writeln(' the IBM and OFF for the DEC-20.');
writeln;
end; (* if *)
end; (* if *)
end; (* help3 *)
procedure help4;
begin
if (noun = setsym) or (noun = nullsym) then
begin
if (adj = nullsym) or (adj = paritysym) then
begin
writeln(' PARITY EVEN, ODD, MARK, SPACE, or NONE.');
writeln(' NONE is the default but if the IBM ');
writeln(' flag is set, parity is set to MARK. ');
writeln(' This flag selects the parity for ');
write(' outgoing and incoming characters during');
writeln;
write(' CONNECT and file transfer to match the');
writeln;
writeln(' requirements of the host.');
writeln;
end; (* if *)
end; (* if *)
if (noun = nullsym) or (noun = showsym) then
begin
writeln(' SHOW To see the values of parameters that can be modified');
writeln(' via the SET command. Options are the same as for SET,');
writeln(' except that a SHOW ALL command has been added.');
end; (* if *)
end; (* help4 *)
begin
help1;
help2;
help3;
help4
end; (* help *)
>>>> KBDHANDLR.TEXT
; ----------------------------
; KBDHNDLR TTY Receive Handler
; ----------------------------
;
; Two routines are provided that maintain an interrupt-driven
; TTY-receive queue. Appropriate PASCAL declarations are:
;
; CONST KQSIZE = maximum number of queued characters
;
; TYPE QUEUE = RECORD (* These are order-dependent !!! *)
; QSIZE: INTEGER;
; INP: INTEGER;
; OUTP: INTEGER;
; MAXCHAR: INTEGER;
; DATA: PACKED ARRAY [0..RCVQSIZE] OF CHAR;
; END;
; VAR KQ: QUEUE; (* must be declared in outermost block *)
;
; PROCEDURE KBDINIT (VAR Q: QUEUE; SIZE:INTEGER); EXTERNAL;
; PROCEDURE KBDFINIT; EXTERNAL;
;
; KBDINIT (KQ,KQSIZE); (* initialize the queue handler *)
;
; WHILE TRUE DO
; WITH KQ DO
; IF INP <> OUTP THEN (* characters available *)
; BEGIN
; CH := DATA[OUTP];
; OUTP := OUTP+1; IF OUTP > QSIZE THEN OUTP := 0;
; ...
; END;
;
; KBDFINIT; (* terminate the queue handler *)
;
; The RECORD declaration for the queue must appear exactly as it
; does above except that you can of course use any names you like.
; Do NOT attempt to lump the first four integer variables together
; into a single group of the form list:INTEGER. In that case,
; the compiler allocates them in reverse order, so that your code
; and the interrupt handler will not agree about which words have
; what meaning.
;
; The queue handler runs continuously as an interrupt-driven task
; at high priority. As characters come in, it advances the queue
; INP pointer and keeps track of the maximum number of characters in
; the queue in the MAXCHAR variable. Queue overflow is indicated
; by MAXCHAR > QSIZE. You must terminate by calling KBDFINIT, or
; the TTY receive interrupts will be left enabled and you will end
; up crashing the system by executing garbage code when the next
; character is received. (KBDFINIT also repairs the interrupt
; vectors for breakpoints and the clock, so failing to call it will
; quite likely crash the system even in the absence of incoming
; TTY characters.)
;
; The manipulation of the clock and BPT interrupt vectors is borrowed
; from UCSD's old communications program. The purpose is to allow
; the clock handler to be interrupted by incoming TTY characters.
;
KDB .EQU 177562 ; Receive Data Buffer absolute address
KSR .EQU 177560 ; Receive Status Register absolute address
KINTV .EQU 60 ; Receiver Interrupt Vector address
CLKINTV .EQU 100 ; Clock interrupt vector address
BPTINTV .EQU 14 ; BPT interrupt vector address
QXCINTV .EQU 250 ; QX controller interrupt vector
;
.PROC KBDINIT,2 ; (VAR Q:QUEUE, SIZE:INTEGER)
;
.DEF KBDLOC ; holds vector address
.DEF KBDPR ; holds old priority
Q .EQU 4 ; stack offset for Q address
SIZE .EQU 2 ; stack offset for QSIZE value
;
MOV Q(SP),R0 ; obtain the Q record address
MOV R0,KQADRS ; remember Q address
MOV SIZE(SP),(R0)+ ; store size in QSIZE word
MOV #0,(R0)+ ; clear INP, OUTP, and MAXCHAR
MOV #0,(R0)+
MOV #0,(R0)
;
;
MOV @#KINTV,KBDLOC ; save old interrupt vector
MOV @#KINTV+2,KBDPR ; and old priority
MOV #KHNDLR,@#KINTV ; store interrupt handler address
MOV #200,@#KINTV+2 ; set interrupt priority 4 for TTY input
;MOV #100,@#KSR ; enable interrupts for TTY input
;
MOV (SP)+,R0 ; pop return address from stack
ADD #4,SP ; discard 2 parameters (4 bytes)
JMP @R0 ; and return to PASCAL interpreter
;
KQADRS .WORD 0 ; holds Q address for handler
KBDLOC .WORD 0 ; holds old interrupt vector
KBDPR .WORD 0 ; holds old interrupt priority
;
QSIZE .EQU 0 ; offset from Q
INP .EQU 2 ; likewise
OUTP .EQU 4
MAXCHAR .EQU 6
DATA .EQU 10
;
KHNDLR: MOV R0,-(SP) ; free registers R0, R1, R2 for use
MOV R1,-(SP)
MOV R2,-(SP)
MOV KQADRS,R2 ; fetch Q address saved by KBDINIT
MOV INP(R2),R0 ; fetch INP value
MOV R0,R1 ; make a working copy
ADD R2,R1 ; R1 = address (Q) + value (INP)
MOVB @#KDB,DATA(R1) ; DATA[INP] := input character
BICB #200,DATA(R1) ; clear bit 8 (parity)
BEQ EXIT ; ignore nulls (do not bump INP)
INC R0 ; INP := INP+1
CMP QSIZE(R2),R0
BPL NOWRAP ; if QSIZE >= INP then no wraparound
CLR R0 ; else INP := 0
NOWRAP MOV R0,INP(R2) ; restore INP
;
SUB OUTP(R2),R0
BMI INOUT
BEQ INOUT
BR OUTIN ; if INP > OUTP, # char = INP - OUTP
INOUT ADD QSIZE(R2),R0 ; otherwise, # char = QSIZE+1 + INP - OUTP
ADD #1,R0
OUTIN CMP MAXCHAR(R2),R0
BPL EXIT ; if MAXCHAR >= # char, exit
MOV R0,MAXCHAR(R2) ; otherwise, store new MAXCHAR
;
EXIT MOV (SP)+,R2 ; restore registers for caller
MOV (SP)+,R1
MOV (SP)+,R0
RTT ; return from interrupt
;
CLKHNDLR: COM CLKFLG ; do not reexecute BPT if BPT handler
BEQ CLKEXIT ; takes so long that clock ticks again
BPT ; let breakpoint transfer to old clock
CLKEXIT COM CLKFLG ; reset flag
RTI ; and exit
;
CLKFLG .WORD 0 ; flags reentry before BPT exit
;
.PROC KBDFINIT
.REF KBDLOC ; old interrupt vector saved by KBDINIT
.REF KBDPR ; old kbd priority saved by KBDINIT
;
MOV @#KBDPR,@#KINTV+2 ; restore interrupt priority
MOV @#KBDLOC,@#KINTV ; and interrupt vector
RTS PC ; and return
;
.END
>>>> KERMIT.TEXT
program kermit;
(* $R-*) (* turn range checking off *)
(*$S+*) (* turn swapping on *)
(* $L+*)
(*$U PARSELIB.CODE*)
USES PARSER;
const blksize = 512;
oport = 8; (* output port # *)
clearscreen = 12; (* charcter which erases screen *)
bell = 7; (* ASCII bell *)
maxpack = 93; (* maximum packet size minus 1 *)
soh = 1; (* start of header *)
sp = 32; (* ASCII space *)
cr = 13; (* ASCII CR *)
lf = 10; (* ASCII line feed *)
dle = 16; (* ASCII DLE (space compression prefix for psystem) *)
del = 127; (* delete *)
my_esc = 29; (* default esc char for connect (^]) *)
maxtry = 5; (* number of times to retry sending packet *)
my_quote = '#'; (* quote character I'll use *)
my_pad = 0; (* number of padding chars I need *)
my_pchar = 0; (* padding character I need *)
my_eol = 13; (* end of line character i need *)
my_time = 5; (* seconds after which I should be timed out *)
maxtim = 20; (* maximum timeout interval *)
mintim = 2; (* minimum time out interval *)
at_eof = -1; (* value to return if at eof *)
rqsize = 5000; (* input queue size *)
qsize1 = 5001; (* qsize + 1 *)
eoln_sym = 13; (* pascal eoln sym *)
back_space = 8; (* pascal backspace sym *)
(* screen control information *)
(* console line on which to put specified info *)
title_line = 1;
statusline = 2;
packet_line = 3;
retry_line = 4;
file_line = 5;
error_line = 6;
debug_line = 7;
prompt_line = 8;
(* position on line to put info *)
statuspos = 70;
packet_pos = 19;
retry_pos = 17;
file_pos = 11;
type queue = record (* input queue *)
qsize: integer;
inp: integer;
outp: integer;
maxchar: integer;
data: packed array[0..rqsize] of char;
end; (* queue *)
packettype = packed array[0..maxpack] of char;
parity_type = (evenpar, oddpar, markpar, spacepar, nopar);
char_int_rec = record (* allows character to be treated as integer... *)
(* is system dependent *)
case boolean of
true: (i: integer);
false: (ch: char)
end; (* record *)
int_bool_rec = record (* allows integer to be treated as boolean... *)
(* used for numeric AND,OR,XOR...system dependent *)
case boolean of
true: (i: integer);
false: (b: boolean)
end; (* record *)
var kq, rq: queue;
state: char; (* current state *)
f: file of char; (* file to be received *)
oldf: file; (* file to be sent *)
s: string;
eol, quote, esc_char: char;
fwarn, ibm, half_duplex, debug: boolean;
i, size, rpsiz, spsiz, pad, n, num_try, oldtry, timint: integer;
recpkt, packet: packettype;
padchar, ch: char;
debf: text; (* file for debug output *)
parity: parity_type;
xon: char;
filebuf: packed array[1..1024] of char;
bufpos, bufend: integer;
parity_array: packed array[char] of char;
ctlset: set of char;
rec_ok, send_ok: boolean;
function read_ch(var q: queue; var ch: char): boolean;
forward;
procedure clear_buf(var q: queue);
forward;
function aand(x,y: integer): integer;
forward;
function aor(x,y: integer): integer;
forward;
function xor(x,y: integer): integer;
forward;
procedure error(p: packettype; len: integer);
forward;
procedure io_error(i: integer);
forward;
procedure debugwrite(s: string);
forward;
procedure debugint(s: string; i: integer);
forward;
procedure writescreen(s: string);
forward;
procedure refresh_screen(numtry, num: integer);
forward;
function min(x,y: integer): integer;
forward;
function tochar(ch: char): char;
forward;
function unchar(ch: char): char;
forward;
function ctl(ch: char): char;
forward;
function getfil(filename: string): boolean;
forward;
procedure bufemp(buffer: packettype; var f: text; len: integer);
forward;
function bufill(var buffer: packettype): integer;
forward;
procedure spar(var packet: packettype);
forward;
procedure rpar(var packet: packettype);
forward;
procedure spack(ptype: char; num:integer; len: integer; data: packettype);
forward;
function getch(var r: char_int_rec; var q: queue): boolean;
forward;
function getsoh(var q: queue): boolean;
forward;
function rpack(var len, num: integer; var data: packettype): char;
forward;
procedure read_str(var q: queue; var s: string);
forward;
procedure show_parms;
forward;
(*$I HELP.TEXT*)
(*$I SENDSW.TEXT*)
(*$I RECSW.TEXT*)
procedure rcvinit(var q: queue; size: integer);
external;
procedure rcvfinit;
external;
procedure kbdinit(var q: queue; size: integer);
external;
procedure kbdfinit;
external;
procedure sendbrk;
external;
procedure read_str(*var q: queue; var s: string*);
(* acts like readln(s) but takes input from input queue *)
var i: integer;
begin
i := 0;
s := copy('',0,0);
repeat
repeat (* get a character *)
until read_ch(kq,ch);
if (ord(ch) = backspace) then (* if it's a backspace then *)
begin
if (i > 0) then (* if not at beginning of line *)
begin
write(ch); (* go back a space on screen *)
write(' '); (* erase char on screen *)
write(ch); (* go back a space again *)
i := i - 1; (* adjust string counter *)
s := copy(s,1,i) (* adjust string *)
end (* if *)
end (* if *)
else if (ord(ch) <> eoln_sym) then (* otherwise if not at eoln then *)
begin
write(ch); (* echo char on screen *)
i := i + 1; (* inc string counter *)
s := concat(s,' ');
s[i] := ch; (* put char in string *)
end; (* if *)
until (ord(ch) = eoln_sym); (* if not eoln, get another char *)
s := copy(s,1,i); (* correct string length *)
writeln (* write a line on the screen *)
end; (* read_str *)
function aand(*x,y: integer): integer*);
(* arithmetic and--takes 2 integers and ands them, yeilding an integer *)
var xrec, yrec, temp: int_bool_rec;
begin
xrec.i := x; (* put the two numbers in variant record *)
yrec.i := y;
temp.b := xrec.b and yrec.b; (* use as booleans to 'and' them *)
aand := temp.i (* return integer result *)
end; (* aand *)
function aor(*x,y: integer): integer*);
(* arithmetic or *)
var xrec, yrec, temp: int_bool_rec;
begin
xrec.i := x; (* put two numbers in variant record *)
yrec.i := y;
temp.b := xrec.b or yrec.b; (* use as booleans to 'or' them *)
aor := temp.i (* return integer result *)
end; (* aor *)
function xor(*x,y: integer): integer*);
(* exclisive or *)
var xrec, yrec, temp: int_bool_rec;
begin
xrec.i := x; (* put two numbers in variant record *)
yrec.i := y;
(* use as booleans to 'xor' them *)
temp.b := (xrec.b or yrec.b) and (not(xrec.b and yrec.b));
xor := temp.i (* return integer result *)
end; (* xor *)
procedure error(*p: packettype; len: integer*);
(* writes error message sent by remote host *)
var i: integer;
begin
gotoxy(0,errorline);
for i := 0 to len-1 do
write(p[i]);
gotoxy(0,promptline);
end; (* error *)
procedure io_error(*i: integer*);
begin
gotoxy(0,errorline);
write(chr(27),'K'); (* erase to end of line *)
case i of
0: writeln('No error');
1: writeln('Bad Block, Parity error (CRC)');
2: writeln('Bad Unit Number');
3: writeln('Bad Mode, Illegal operation');
4: writeln('Undefined hardware error');
5: writeln('Lost unit, Unit is no longer on-line');
6: writeln('Lost file, File is no longer in directory');
7: writeln('Bad Title, Illegal file name');
8: writeln('No room, insufficient space');
9: writeln('No unit, No such volume on line');
10: writeln('No file, No such file on volume');
11: writeln('Duplicate file');
12: writeln('Not closed, attempt to open an open file');
13: writeln('Not open, attempt to close a closed file');
14: writeln('Bad format, error in reading real or integer');
15: writeln('Ring buffer overflow')
end; (* case *)
gotoxy(0,promptline)
end; (* io_error *)
procedure debugwrite(*s: string*);
(* writes a debugging message *)
var i: integer;
begin
if debug then
begin
gotoxy(0,debugline);
write(chr(27),'K'); (* erase to end of line *)
write(s);
for i := 1 to 2000 do ; (* write debugging message *)
end (* if debug *)
end; (* debugwrite *)
procedure debugint(*s: string; i: integer*);
(* write a debugging message and an integer *)
begin
if debug then
begin
debugwrite(s);
write(i)
end (* if debug *)
end; (* debugint *)
procedure writescreen(*s: string*);
(* sets up the screen for receiving or sending files *)
begin
write(chr(clearscreen));
gotoxy(0,titleline);
write(' Kermit UCSD p-system');
gotoxy(statuspos,statusline);
write(s);
gotoxy(0,packetline);
write('Number of Packets: ');
gotoxy(0,retryline);
write('Number of Tries: ');
gotoxy(0,fileline);
write('File Name: ');
end; (* writescreen *)
procedure refresh_screen(*numtry, num: integer*);
(* keeps track of packet count on screen *)
begin
gotoxy(retrypos,retryline);
write(numtry: 5);
gotoxy(packetpos,packetline);
write(num: 5)
end; (* refresh_screen *)
function min(*x,y: integer): integer*);
(* returns smaller of two integers *)
begin
if x < y then
min := x
else
min := y
end; (* min *)
function tochar(*ch: char): char*);
(* tochar converts a control character to a printable one by adding space *)
begin
tochar := chr(ord(ch) + ord(' '))
end; (* tochar *)
function unchar(*ch: char): char*);
(* unchar undoes tochar *)
begin
unchar := chr(ord(ch) - ord(' '))
end; (* unchar *)
function ctl(*ch: char): char*);
(* ctl toggles control bit: ^A becomes A, A becomes ^A *)
begin
ctl := chr(xor(ord(ch),64))
end; (* ctl *)
procedure echo(ch: char);
(* echos a character on the screen *)
begin
ch := chr(aand(ord(ch),127)); (* mask off parity bit *)
if ch <> chr(lf) then
begin
unitwrite(1,ch,1)
end (* if *)
end; (* echo *)
procedure clear_buf(*var q: queue*);
(* empties the buffer input buffer *)
begin
q.outp := q.inp
end; (* clear_buf *)
function getfil(*filename: string): boolean*);
(* opens a file for writing *)
begin
(*$I-*) (* turn i/o checking off *)
rewrite(f,filename);
(*$I-*) (* turn i/o checking on *)
getfil := (ioresult = 0)
end; (* getfil *)
procedure bufemp(*buffer: packettype; var f: text; len: integer*);
(* empties a packet into a file *)
var i,ls: integer;
r: char_int_rec;
s: string;
begin
s := copy('',0,0);
ls := 0;
i := 0;
while i < len do
begin
r.ch := buffer[i]; (* get a character *)
if (r.ch = myquote) then (* if character is control quote *)
begin
i := i + 1; (* skip over quote and *)
r.ch := buffer[i]; (* get quoted character *)
if (aand(r.i,127) <> ord(myquote)) then
r.ch := ctl(r.ch); (* controllify it *)
end; (* if *)
if (r.i = cr) then (* else if a carriage return then *)
begin
i := i + 3; (* skip over that and line feed *)
(*$I-*) (* turn i/o checking off *)
writeln(f,s); (* and write out line to file *)
s := copy('',0,0); (* empty the string var *)
ls := 0;
if (io_result <> 0) then (* if io_error *)
begin
io_error(ioresult); (* tell them and *)
state := 'a'; (* abort *)
end (* if *)
end
(*$I+*) (* turn i/o checking back on *)
else (* else, is a regular char, so *)
begin
r.i := aand(r.i,127); (* mask off parity bit *)
s := concat(s,' '); (* and add character to out string *)
ls := ls + 1;
s[ls] := r.ch;
i := i + 1 (* increase buffer pointer *)
end; (* else *)
end; (* while *) (* and get another char *)
(*$I-*) (* turn i/o checking off *)
write(f,s); (* and write out line to file *)
if (io_result <> 0) then (* if io_error *)
begin
io_error(ioresult); (* tell them and *)
state := 'a'; (* abort *)
end (* if *)
(*$I+*) (* turn i/o checking back on *)
end; (* bufemp *)
function bufill(*var buffer: packettype): integer*);
(* fill a packet with data from a file...manages a 2 block buffer *)
var i, j, k, t7, count: integer;
r: char_int_rec;
begin
i := 0;
(* while file has some data & packet has some room we'll keep going *)
while ((bufpos <= bufend) or (not eof(oldf))) and (i < spsiz-9) do
begin
(* if we need more data from disk then *)
if (bufpos > bufend) and (not eof(oldf)) then
begin
(* read a couple of blocks *)
bufend := blockread(oldf,filebuf[1],2) * blksize;
(* and adjust buffer pointer *)
bufpos := 1
end; (* if *)
if (bufpos <= bufend) then (* if we're within buffer bounds *)
begin
r.ch := filebuf[bufpos]; (* get a character *)
bufpos := bufpos + 1; (* increase buffer pointer *)
if (r.i = dle) then (* if it's space compression char, *)
begin
count := ord(unchar(filebuf[bufpos])); (* get # of spaces *)
bufpos := bufpos + 1; (* read past # *)
r.ch := ' '; (* and make current char a space *)
end (* else if *)
else (* otherwise, it's just a char *)
count := 1; (* so only 1 copy of it *)
if (r.ch in ctlset) then (* if a control char *)
begin
if (r.i = cr) then (* if a carriage return *)
begin
buffer[i] := quote; (* put (quoted) CR in buffer *)
i := i + 1;
buffer[i] := ctl(chr(cr));
i := i + 1;
r.i := lf; (* and we'll stick a LF after *)
end; (* if *)
if r.i <> 0 then (* if not a NUL then *)
begin
buffer[i] := quote; (* put the quote in buffer *)
i := i + 1;
if r.ch <> quote then
r.ch := ctl(r.ch); (* and un-controllify char *)
end (* if *)
end; (* if *)
end; (* if *)
j := 1;
while (j <= count) and (i <= spsiz - 5) do
begin (* put all the chars in buffer *)
if (r.i <> 0) then (* so long as not a NUL *)
begin
buffer[i] := r.ch;
i := i + 1;
end (* if *)
else (* is a NUL so *)
if (bufpos > blksize) then (* skip to end of block *)
bufpos := bufend + 1 (* since rest will be NULs *)
else
bufpos := blksize + 1;
j := j + 1
end; (* while *)
end; (* while *)
if (i = 0) then (* if we're at end of file, *)
bufill := (at_eof) (* indicate it *)
else (* else *)
begin
if (j <= count) then (* if didn't all fit in packet *)
begin
bufpos := bufpos - 2; (* put buf pointer at DLE *)
(* and update compress count *)
filebuf[bufpos + 1] := tochar(chr(count-j+1));
end; (* if *)
bufill := i (* return # of chars in packet *)
end; (* else *)
end; (* bufill *)
procedure spar(*var packet: packettype*);
(* fills data array with my send-init parameters *)
begin
packet[0] := tochar(chr(maxpack)); (* biggest packet i can receive *)
packet[1] := tochar(chr(mytime)); (* when i want to be timed out *)
packet[2] := tochar(chr(mypad)); (* how much padding i need *)
packet[3] := ctl(chr(mypchar)); (* padding char i want *)
packet[4] := tochar(chr(myeol)); (* end of line character i want *)
packet[5] := myquote; (* control-quote char i want *)
packet[6] := 'N'; (* I won't do 8-bit quoting *)
end; (* spar *)
procedure rpar(*var packet: packettype*);
(* gets their init params *)
begin
spsiz := ord(unchar(packet[0])); (* max send packet size *)
timint := ord(unchar(packet[1])); (* when i should time out *)
pad := ord(unchar(packet[2])); (* number of pads to send *)
padchar := ctl(packet[3]); (* padding char to send *)
eol := unchar(packet[4]); (* eol char i must send *)
quote := packet[5]; (* incoming data quote char *)
end; (* rpar *)
procedure packetwrite(p: packettype; len: integer);
(* writes out all of a packet for debugging purposes *)
var i: integer;
begin
gotoxy(0,debugline);
for i := 0 to len+3 do
begin
if i = 80 then
begin
gotoxy(0,debugline+1);
write(chr(27),'K');
end; (* if *)
write(p[i])
end; (* for *)
for i := 1 to 2000 do ;
end; (* packetwrite *)
procedure spack(*ptype: char; num: integer; len: integer; data: packettype*);
(* send a packet *)
const maxtry = 10000;
var bufp, i, count: integer;
chksum: char;
buffer: packettype;
ch: char;
begin
if ibm and (state <> 's') then (* if ibm and not SINIT then *)
begin
count := 0;
repeat (* wait for an xon *)
repeat
count := count + 1
until (readch(rq,ch)) or (count > maxtry );
until (ch = xon) or (count > maxtry);
if count > maxtry then (* if wait too long then *)
begin
exit(spack) (* get out *)
end; (* if *)
end; (* if *)
bufp := 0;
for i := 1 to pad do
unitwrite(oport,padchar,1); (* write out any padding chars *)
buffer[bufp] := chr(soh); (* packet sync character *)
bufp := bufp + 1;
chksum := tochar(chr(len + 3)); (* init chksum *)
buffer[bufp] := tochar(chr(len + 3)); (* character count *)
bufp := bufp + 1;
chksum := chr(ord(chksum) + ord(tochar(chr(num))));
buffer[bufp] := tochar(chr(num));
bufp := bufp + 1;
chksum := chr(ord(chksum) + ord(ptype));
buffer[bufp] := ptype; (* packet type *)
bufp := bufp + 1;
for i := 0 to len - 1 do (* loop through data chars *)
begin
buffer[bufp] := data[i]; (* store char *)
bufp := bufp + 1;
chksum := chr(ord(chksum) + ord(data[i]))
end; (* for i *)
(* compute final chksum *)
chksum := chr(aand(ord(chksum) + (aand(ord(chksum),192) div 64), 63));
buffer[bufp] := tochar(chksum);
bufp := bufp + 1;
buffer[bufp] := eol;
if (parity <> nopar) then
for i := 0 to bufp do (* set correct parity on buffer *)
buffer[i] := parity_array[buffer[i]];
unitwrite(oport,buffer[0],bufp+1); (* send the packet out *)
if debug then
packetwrite(buffer,len);
end; (* spack *)
function read_ch(*var q: queue; var ch: char): boolean*);
(* read a character from an input queue *)
begin
with q do
begin
if (inp <> outp) then (* if a char there *)
begin
ch := data[outp]; (* get the char *)
outp := (outp + 1) mod qsize1; (* increment buffer pointer *)
read_ch := true; (* and return true *)
end (* if *)
else (* otherwise *)
read_ch := false; (* return false *)
end (* with *)
end; (* read_ch *)
function getch(*var r: char_int_rec; var q: queue): boolean*);
(* gets a character, strips parity, returns true if it got a char which *)
(* isn't Kermit SOH, false if it gets SOH or nothing after maxtry *)
const maxtry = 10000;
var count: integer;
begin
count := 0;
getch := false;
with q do
begin
repeat
count := count + 1;
until (inp <> outp) or (count > maxtry); (* wait for a character *)
if (count > maxtry) then (* if wait too long then *)
exit(getch); (* get out of here *)
r.ch := data[outp]; (* get the character *)
outp := (outp + 1) mod qsize1; (* increment pointer *)
r.i := aand(r.i,127); (* strip parity from char *)
getch := (r.ch <> chr(soh)); (* return true if not SOH *)
end (* with *)
end; (* getch *)
function getsoh(*var q: queue): boolean*);
(* reads characters until it finds an SOH; returns false if has to read more *)
(* than maxtry chars *)
const maxtry = 10000;
var ch: char;
count: integer;
begin
count := 0;
get_soh := true;
with q do
begin
repeat
repeat
count := count + 1
until (inp <> outp) or (count > maxtry); (* wait for a character *)
if (count > maxtry) then
begin
get_soh := false;
exit(get_soh)
end; (* if *)
ch := data[outp]; (* get the character *)
outp := (outp + 1) mod qsize1; (* increment pointer *)
ch := chr(aand(ord(ch),127)); (* strip parity of char *)
until (ch = chr(SOH)) (* if not SOH, get more *)
end (* with q *)
end; (* getsoh *)
(*$G+*) (* turn on goto option...need it for next routine *)
function rpack(*var len, num: integer; var data: packettype): char*);
(* read a packet *)
label 1; (* used to emulate C's CONTINUE statement *)
const maxtry = 10000;
var count, i, ichksum: integer;
chksum, ptype: char;
r: char_int_rec;
begin
count := 0;
if not getsoh(rq) and (state<>'r') then (*if don't get synch char then *)
begin
rpack := 'N'; (* treat as a NAK *)
num := n mod 64;
exit(rpack) (* and get out of here *)
end;
1: count := count + 1;
if (count>maxtry)and(state<>'r') then (* if we've tried too many times *)
begin (* and aren't waiting for init *)
rpack := 'N'; (* treat as NAK *)
exit(rpack) (* and get out of here *)
end; (* if *)
if not getch(r,rq) then (* get a char and *)
goto 1; (* resynch if soh *)
ichksum := r.i; (* start checksum *)
len := ord(unchar(r.ch)) - 3; (* character count *)
if not getch(r,rq) then (* get a char and *)
goto 1; (* resynch if soh *)
ichksum := ichksum + r.i;
num := ord(unchar(r.ch)); (* packet number *)
if not getch(r,rq) then (* get a char and *)
goto 1; (* resynch if soh *)
ichksum := ichksum + r.i;
ptype := r.ch; (* packet type *)
for i := 0 to len-1 do (* get any data *)
begin
if not getch(r,rq) then (* get a char and *)
goto 1; (* resynch if soh *)
ichksum := ichksum + r.i;
data[i] := r.ch;
end; (* for i *)
data[len] := chr(0); (* mark end of data *)
if not getch(r,rq) then (* get a char and *)
goto 1; (* resynch if soh *)
(* compute final checksum *)
chksum := chr(aand(ichksum + (aand(ichksum,192) div 64), 63));
if (chksum <> unchar(r.ch)) then (* if checksum bad *)
rpack := chr(0) (* return 'false' indicator *)
else (* else *)
rpack := ptype; (* return packet type *)
if debug then
begin
gotoxy(0,debugline);
write(len,num,ptype);
for i := 1 to 1000 do
;
end; (* if *)
end; (* rpack *)
(*$G-*) (* turn off goto option...don't need it anymore *)
procedure connect;
(* connect to remote host (terminal emulation *)
var ch: char;
close: boolean;
procedure read_esc;
(* read charcter after esc char and interpret it *)
begin
repeat
until read_ch(kq,ch); (* wait until they've typed something in *)
if (ch in ['a'..'z']) then (* uppercase it *)
ch := chr(ord(ch) - ord('a') + ord('A'));
if ch in ['B','C','S','?'] then
case ch of
'B': sendbrk; (* B: send a break to the IBM *)
'C': close := true; (* C: end connection *)
'S': begin (* S: show status *)
noun := allsym;
showparms
end; (* S *)
'?': begin (* ?: show options *)
writeln('B Send a BREAK signal.');
write('C Close Connection, return to ');
writeln('KERMIT-UCSD command level.');
writeln('S Show Status of connection');
writeln('? Print this list');
write('^',esc_char,' send the escape ');
writeln('character itself to the');
writeln(' remote host.')
end; (* ? *)
end (* case *)
else if ch = esc_char then (* ESC-char: send it out *)
begin
if half_duplex then
begin
echo(ch);
unitwrite(oport,ch,1)
end (* if *)
end (* else if *)
else (* anything else: ignore *)
write(chr(bell))
end; (* read_esc *)
begin (* connect *)
clear_buf(kq); (* empty keyboard buffer *)
clear_buf(rq); (* empty remote input buffer *)
writeln('Connecting to host...type CTRL-',ctl(esc_char),' C to exit');
close := false;
repeat
if read_ch(rq,ch) then (* if char from host then *)
echo(ch); (* echo it *)
if read_ch(kq,ch) then (* if char from keyboard then *)
if ch <> esc_char then (* if not ESC-char then *)
begin
if half_duplex then (* echo it if half-duplex *)
echo(ch);
unitwrite(oport,ch,1) (* send it out the port *)
end (* if *)
else (* ch = esc_char *) (* else is ESC-char so *)
read_esc; (* interpret next char *)
until close; (* if still connected, get more *)
writeln('Disconnected')
end; (* connect *)
procedure fill_parity_array;
(* parity value table for even parity...not(entry) = odd parity *)
const min = 0;
max = 126;
var i, shifter, counter: integer;
minch, maxch, ch: char;
r: char_int_rec;
begin
minch := chr(min);
maxch := chr(max);
case parity of
evenpar:
begin
for ch := minch to maxch do
begin
r.ch := ch; (* put char into variant record *)
shifter := aand(r.i,255); (* mask off parity bit *)
counter := 0;
for i := 1 to 7 do (* count the 1's *)
begin
if odd(shifter) then
counter := counter + 1;
shifter := shifter div 2
end; (* for i *)
if odd(counter) then (* stick a 1 on if necessary *)
parity_array[ch] := chr(aor(ord(ch),128))
else
parity_array[ch] := chr(aand(ord(ch),127))
end; (* for ch *)
end; (* case even *)
oddpar:
begin
for ch := minch to maxch do
begin
r.ch := ch; (* put char into variant record *)
shifter := aand(r.i,255); (* mask off parity bit *)
counter := 0;
for i := 1 to 7 do (* count the 1's *)
begin
if odd(shifter) then
counter := counter + 1;
shifter := shifter div 2
end; (* for i *)
if odd(counter) then (* stick a 1 on if necessary *)
parity_array[ch] := chr(aand(ord(ch),127))
else
parity_array[ch] := chr(aor(ord(ch),128))
end; (* for ch *)
end; (* case odd *)
markpar:
for ch := minch to maxch do (* stick a 1 on all chars *)
parity_array[ch] := chr(aor(ord(ch),128));
spacepar:
for ch := minch to maxch do (* mask off parity on all chars *)
parity_array[ch] := chr(aand(ord(ch),127));
nopar:
for ch := minch to maxch do (* don't mess w/parity bit at all *)
parity_array[ch] := ch;
end; (* case *)
end; (* fill_parity_array *)
procedure write_bool(s: string; b: boolean);
(* writes message & 'on' if b, 'off' if not b *)
begin
write(s);
case b of
true: writeln('on');
false: writeln('off');
end; (* case *)
end; (* write_bool *)
procedure show_parms;
(* shows the various settable parameters *)
begin
case noun of
allsym:
begin
write_bool('Debugging is ',debug);
writeln('Escape character is ^',ctl(esc_char));
write_bool('File warning is ',fwarn);
write_bool('IBM is ',ibm);
write_bool('Local echo is ',halfduplex);
case parity of
evenpar: write('Even');
markpar: write('Mark');
nopar: write('No');
oddpar: write('Odd');
spacepar: write('Space');
end; (* case *)
writeln(' parity');
end; (* allsym *)
debugsym: write_bool('Debugging is ',debug);
escsym: writeln('Escape character is ^',ctl(esc_char));
filewarnsym: write_bool('File warning is ',fwarn);
ibmsym: write_bool('IBM is ',ibm);
localsym: write_bool('Local echo is ',halfduplex);
paritysym: begin
case parity of
evenpar: write('Even');
markpar: write('Mark');
nopar: write('No');
oddpar: write('Odd');
spacepar: write('Space');
end; (* case *)
writeln(' parity');
end; (* paritysym *)
end; (* case *)
end; (* show_sym *)
procedure set_parms;
(* sets the parameters *)
begin
case noun of
debugsym: case adj of
onsym: begin
debug := true;
(*$I-*)
rewrite(debf,'CONSOLE:')
(*I+*)
end; (* onsym *)
offsym: debug := false
end; (* case adj *)
escsym: escchar := newescchar;
filewarnsym: fwarn := (adj = onsym);
ibmsym: case adj of
onsym: begin
ibm := true;
parity := markpar;
half_duplex := true;
fillparityarray
end; (* onsym *)
offsym: begin
ibm := false;
parity := nopar;
half_duplex := false;
fillparityarray
end; (* onsym *)
end; (* case adj *)
localsym: halfduplex := (adj = onsym);
paritysym: begin
case adj of
evensym: parity := evenpar;
marksym: parity := markpar;
nonesym: parity := nopar;
oddsym: parity := oddpar;
spacesym: parity := spacepar;
end; (* case *)
fill_parity_array;
end; (* paritysym *)
end; (* case *)
end; (* set_parms *)
procedure initialize;
var ch: char;
begin
pad := mypad;
padchar := chr(mypchar);
eol := chr(my_eol);
esc_char := chr(my_esc);
quote := my_quote;
ctlset := [chr(1)..chr(31),chr(del),quote];
half_duplex := false;
debug := false;
fwarn := false;
spsiz := max_pack;
rpsiz := max_pack;
n := 0;
parity := nopar;
initvocab;
fill_parity_array;
ibm := false;
xon := chr(17);
bufpos := 1;
bufend := 0;
rcvinit(rq,rqsize);
kbdinit(kq,rqsize);
end; (* initialize *)
procedure closeup;
begin
kbdfinit;
rcvfinit;
writeln(chr(clear_screen))
end; (* closeup *)
begin (* kermit *)
initialize;
repeat
write('Kermit-UCSD> ');
readstr(kq,line);
case parse of
unconfirmed: writeln('Unconfirmed');
parm_expected: writeln('Parameter expected');
ambiguous: writeln('Ambiguous');
unrec: writeln('Unrecognized command');
fn_expected: writeln('File name expected');
ch_expected: writeln('Single character expected');
null: case verb of
consym: connect;
helpsym: help;
recsym: begin
recsw(rec_ok);
gotoxy(0,debugline);
write(chr(bell));
if rec_ok then
writeln('successful receive')
else
writeln('unsuccessful receive');
(*$I-*) (* set i/o checking off *)
close(oldf);
(*$I+*) (* set i/o checking back on *)
gotoxy(0,promptline);
end; (* recsym *)
sendsym: begin
uppercase(filename);
sendsw(send_ok);
gotoxy(0,debugline);
write(chr(bell));
if send_ok then
writeln('successful send')
else
writeln('unsuccessful send');
(*$I-*) (* set i/o checking off *)
close(oldf);
(*$I+*) (* set i/o checking back on *)
gotoxy(0,promptline);
end; (* sendsym *)
setsym: set_parms;
show_sym: show_parms;
end; (* case verb *)
end; (* case parse *)
until (verb = exitsym) or (verb = quitsym);
closeup
end. (* kermit *)
>>>> PARSER.TEXT
(*$S+*)
unit parser;
INTERFACE
type statustype = (null, at_eol, unconfirmed, parm_expected, ambiguous,
unrec, fn_expected, ch_expected);
vocab = (nullsym, allsym, consym, debugsym, escsym, evensym, exitsym,
filewarnsym,helpsym, ibmsym, localsym, marksym, nonesym,
oddsym, offsym, onsym, paritysym, quitsym, recsym, sendsym,
setsym, showsym, spacesym);
var noun, verb, adj: vocab;
status: statustype;
vocablist: array[vocab] of string;
filename, line: string;
newescchar: char;
expected: set of vocab;
procedure uppercase(var s: string);
function parse: statustype;
procedure initvocab;
IMPLEMENTATION
procedure uppercase(*var s: string*);
var i: integer;
begin
for i := 1 to length(s) do
if s[i] in ['a'..'z'] then
s[i] := chr(ord(s[i]) - ord('a') + ord('A'))
end; (* uppercase *)
procedure eatspaces(var s: string);
var done: boolean;
i: integer;
begin
done := (length(s) = 0);
while not done do
begin
if s[1] = ' ' then
begin
i := length(s) - 1;
s := copy(s,2,i);
done := length(s) = 0
end (* if *)
else
done := true
end (* while *)
end; (* eatspaces *)
procedure isolate_word(var line, s: string);
var i: integer;
done: boolean;
begin
done := false;
i := 1;
s := copy(' ',0,0);
while (i <= length(line)) and not done do
begin
if line[i] = ' ' then
done := true
else
s := concat(s,copy(line,i,1));
i := i + 1;
end; (* while *)
line := copy(line,i,length(line)-i+1);
end; (* isolate_word *)
function get_fn(var line, fn: string): boolean;
var i, l: integer;
begin
get_fn := true;
isolate_word(line, fn);
l := length(fn);
if (l < 1) then
get_fn := false
end; (* get_fn *)
function getch(var ch: char): boolean;
var s: string;
begin
isolate_word(line,s);
if length(s) <> 1 then
getch := false
else
begin
ch := s[1];
get_ch := true
end (* else *)
end; (* getch *)
function parse(*: statustype*);
type states = (start, fin, get_filename, get_set_parm, get_parity, get_on_off,
get_char, get_show_parm, get_help_show, get_help_parm,
exitstate);
var status: statustype;
word: vocab;
state: states;
function get_sym(var word: vocab): statustype;
var i: vocab;
s: string;
stat: statustype;
done: boolean;
matches: integer;
begin
eat_spaces(line);
if length(line) = 0 then
getsym := ateol
else
begin
stat := null;
done := false;
isolate_word(line,s);
i := allsym;
matches := 0;
repeat
if (pos(s,vocablist[i]) = 1) and (i in expected) then
begin
matches := matches + 1;
word := i
end
else if (s[1] < vocablist[i,1]) then
done := true;
if (i = spacesym) then
done := true
else
i := succ(i)
until (matches > 1) or done;
if matches > 1 then
stat := ambiguous
else if (matches = 0) then
stat := unrec;
getsym := stat
end (* else *)
end; (* getsym *)
begin
state := start;
parse := null;
noun := nullsym;
verb := nullsym;
adj := nullsym;
uppercase(line);
repeat
case state of
start:
begin
expected := [consym, exitsym, helpsym, quitsym, recsym, sendsym,
setsym, showsym];
status := getsym(verb);
if status = ateol then
begin
parse := null;
exit(parse)
end (* if *)
else if (status <> unrec) and (status <> ambiguous) then
case verb of
consym: state := fin;
exitsym, quitsym: state := fin;
helpsym: state := get_help_parm;
recsym: state := fin;
sendsym: state := getfilename;
setsym: state := get_set_parm;
showsym: state := get_show_parm;
end (* case *)
end; (* case start *)
fin:
begin
expected := [];
status := getsym(verb);
if status = ateol then
begin
parse := null;
exit(parse)
end (* if status *)
else
status := unconfirmed
end; (* case fin *)
getfilename:
begin
expected := [];
if getfn(line,filename) then
begin
status := null;
state := fin
end (* if *)
else
status := fnexpected
end; (* case get file name *)
get_set_parm:
begin
expected := [paritysym, localsym, ibmsym, escsym,
debugsym, filewarnsym];
status := getsym(noun);
if status = ateol then
status := parm_expected
else if (status <> unrec) and (status <> ambiguous) then
case noun of
paritysym: state := get_parity;
localsym: state := get_on_off;
ibmsym: state := get_on_off;
escsym: state := getchar;
debugsym: state := getonoff;
filewarnsym: state := getonoff;
end (* case *)
end; (* case get_set_parm *)
get_parity:
begin
expected := [marksym, spacesym, nonesym, evensym, oddsym];
status := getsym(adj);
if status = ateol then
status := parm_expected
else if (status <> unrec) and (status <> ambiguous) then
state := fin
end; (* case get_parity *)
get_on_off:
begin
expected := [onsym, offsym];
status := getsym(adj);
if status = ateol then
status := parm_expected
else if (status <> unrec) and (status <> ambiguous) then
state := fin
end; (* get_on_off *)
get_char:
if getch(newescchar) then
state := fin
else
status := ch_expected;
get_show_parm:
begin
expected := [allsym, paritysym, localsym, ibmsym, escsym,
debugsym, filewarnsym];
status := getsym(noun);
if status = ateol then
status := parm_expected
else if (status <> unrec) and (status <> ambiguous) then
state := fin
end; (* case get_show_parm *)
get_help_show:
begin
expected := [paritysym, localsym, ibmsym, escsym,
debugsym, filewarnsym];
status := getsym(adj);
if (status = at_eol) then
begin
status := null;
state := fin
end
else if (status <> unrec) and (status <> ambiguous) then
state := fin
end; (* case get_help_show *)
get_help_parm:
begin
expected := [consym, exitsym, helpsym, quitsym, recsym,
sendsym, setsym, showsym];
status := getsym(noun);
if status = ateol then
begin
parse := null;
exit(parse)
end;
if (status <> unrec) and (status <> ambiguous) then
case noun of
consym: state := fin;
sendsym: state := fin;
recsym: state := fin;
setsym: state := get_help_show;
showsym: state := fin;
helpsym: state := fin;
exitsym, quitsym: state := fin;
end (* case *)
end; (* case get_help_show *)
end (* case *)
until (status <> null);
parse := status
end; (* parse *)
procedure initvocab;
var i: integer;
begin
vocablist[allsym] := 'ALL';
vocablist[consym] := 'CONNECT';
vocablist[debugsym] := 'DEBUG';
vocablist[escsym] := 'ESCAPE';
vocablist[evensym] := 'EVEN';
vocablist[exitsym] := 'EXIT';
vocablist[filewarnsym] := 'FILE-WARNING';
vocablist[helpsym] := 'HELP';
vocablist[ibmsym] := 'IBM';
vocablist[localsym] := 'LOCAL-ECHO';
vocablist[marksym] := 'MARK';
vocablist[nonesym] := 'NONE';
vocablist[oddsym] := 'ODD';
vocablist[offsym] := 'OFF';
vocablist[onsym] := 'ON';
vocablist[paritysym] := 'PARITY';
vocablist[quitsym] := 'QUIT';
vocablist[recsym] := 'RECEIVE';
vocablist[sendsym] := 'SEND';
vocablist[setsym] := 'SET';
vocablist[showsym] := 'SHOW';
vocablist[spacesym] := 'SPACE';
end; (* initvocab *)
end. (* end of unit *)
>>>> RCVHANDLR.TEXT
; ----------------------------
; RCVHNDLR TTY Receive Handler
; ----------------------------
;
; Two routines are provided that maintain an interrupt-driven
; TTY-receive queue. Appropriate PASCAL declarations are:
;
; CONST RCVQSIZE = maximum number of queued characters
;
; TYPE QUEUE = RECORD (* These are order-dependent !!! *)
; QSIZE: INTEGER;
; INP: INTEGER;
; OUTP: INTEGER;
; MAXCHAR: INTEGER;
; DATA: PACKED ARRAY [0..RCVQSIZE] OF CHAR;
; END;
; VAR RCVQ: QUEUE; (* must be declared in outermost block *)
;
; PROCEDURE RCVINIT (VAR Q: QUEUE; SIZE:INTEGER); EXTERNAL;
; PROCEDURE RCVFINIT; EXTERNAL;
;
; RCVINIT (RCVQ,RCVQSIZE); (* initialize the queue handler *)
;
; WHILE TRUE DO
; WITH RCVQ DO
; IF INP <> OUTP THEN (* characters available *)
; BEGIN
; CH := DATA[OUTP];
; OUTP := OUTP+1; IF OUTP > QSIZE THEN OUTP := 0;
; ...
; END;
;
; RCVFINIT; (* terminate the queue handler *)
;
; The RECORD declaration for the queue must appear exactly as it
; does above except that you can of course use any names you like.
; Do NOT attempt to lump the first four integer variables together
; into a single group of the form list:INTEGER. In that case,
; the compiler allocates them in reverse order, so that your code
; and the interrupt handler will not agree about which words have
; what meaning.
;
; The queue handler runs continuously as an interrupt-driven task
; at high priority. As characters come in, it advances the queue
; INP pointer and keeps track of the maximum number of characters in
; the queue in the MAXCHAR variable. Queue overflow is indicated
; by MAXCHAR > QSIZE. You must terminate by calling RCVFINIT, or
; the TTY receive interrupts will be left enabled and you will end
; up crashing the system by executing garbage code when the next
; character is received. (RCVFINIT also repairs the interrupt
; vectors for breakpoints and the clock, so failing to call it will
; quite likely crash the system even in the absence of incoming
; TTY characters.)
;
; The manipulation of the clock and BPT interrupt vectors is borrowed
; from UCSD's old communications program. The purpose is to allow
; the clock handler to be interrupted by incoming TTY characters.
;
RDB .EQU 177522 ; Receive Data Buffer absolute address
RSR .EQU 177520 ; Receive Status Register absolute address
RCVINTV .EQU 120 ; Receiver Interrupt Vector address
CLKINTV .EQU 100 ; Clock interrupt vector address
BPTINTV .EQU 14 ; BPT interrupt vector address
QXCINTV .EQU 250 ; QX controller interrupt vector
;
.PROC RCVINIT,2 ; (VAR Q:QUEUE, SIZE:INTEGER)
;
.DEF BPTLOC ; used to save BPT interrupt handler adrs
.DEF BPTPR ; used to save BPT handler priority
Q .EQU 4 ; stack offset for Q address
SIZE .EQU 2 ; stack offset for QSIZE value
;
MOV Q(SP),R0 ; obtain the Q record address
MOV R0,RCVQADRS ; remember Q address
MOV SIZE(SP),(R0)+ ; store size in QSIZE word
MOV #0,(R0)+ ; clear INP, OUTP, and MAXCHAR
MOV #0,(R0)+
MOV #0,(R0)
;
MOV @#BPTINTV,BPTLOC ; save old BPT handler address
MOV @#BPTINTV+2,BPTPR ; and old BPT handler priority
MOV @#CLKINTV,@#BPTINTV ; make BPT vector point to old clock
MOV #0,@#BPTINTV+2 ; and let it run at low priority
MOV #CLKHNDLR,@#CLKINTV ; and replace clock handler with ours
MOV #0,@#QXCINTV+2 ; make floppy interruptable
;
MOV #RCVHNDLR,@#RCVINTV ; store interrupt handler address
MOV #200,@#RCVINTV+2 ; set interrupt priority 4 for TTY input
MOV #100,@#RSR ; enable interrupts for TTY input
;
MOV (SP)+,R0 ; pop return address from stack
ADD #4,SP ; discard 2 parameters (4 bytes)
JMP @R0 ; and return to PASCAL interpreter
;
RCVQADRS .WORD 0 ; holds Q address for handler
BPTLOC .WORD 0 ; saves old BPT handler location
BPTPR .WORD 0 ; saves old BPT handler priority
;
QSIZE .EQU 0 ; offset from Q
INP .EQU 2 ; likewise
OUTP .EQU 4
MAXCHAR .EQU 6
DATA .EQU 10
;
RCVHNDLR: MOV R0,-(SP) ; free registers R0, R1, R2 for use
MOV R1,-(SP)
MOV R2,-(SP)
MOV RCVQADRS,R2 ; fetch Q address saved by RCVINIT
MOV INP(R2),R0 ; fetch INP value
MOV R0,R1 ; make a working copy
ADD R2,R1 ; R1 = address (Q) + value (INP)
MOVB @#RDB,DATA(R1) ; DATA[INP] := input character
BICB #200,DATA(R1) ; clear bit 8 (parity)
BEQ EXIT ; ignore nulls (do not bump INP)
INC R0 ; INP := INP+1
CMP QSIZE(R2),R0
BPL NOWRAP ; if QSIZE >= INP then no wraparound
CLR R0 ; else INP := 0
NOWRAP MOV R0,INP(R2) ; restore INP
;
SUB OUTP(R2),R0
BMI INOUT
BEQ INOUT
BR OUTIN ; if INP > OUTP, # char = INP - OUTP
INOUT ADD QSIZE(R2),R0 ; otherwise, # char = QSIZE+1 + INP - OUTP
ADD #1,R0
OUTIN CMP MAXCHAR(R2),R0
BPL EXIT ; if MAXCHAR >= # char, exit
MOV R0,MAXCHAR(R2) ; otherwise, store new MAXCHAR
;
EXIT MOV (SP)+,R2 ; restore registers for caller
MOV (SP)+,R1
MOV (SP)+,R0
RTT ; return from interrupt
;
CLKHNDLR: COM CLKFLG ; do not reexecute BPT if BPT handler
BEQ CLKEXIT ; takes so long that clock ticks again
BPT ; let breakpoint transfer to old clock
CLKEXIT COM CLKFLG ; reset flag
RTI ; and exit
;
CLKFLG .WORD 0 ; flags reentry before BPT exit
;
.PROC RCVFINIT
.REF BPTLOC ; old BPT handler loc, saved by RCVINIT
.REF BPTPR ; old BPT handler priority, likewise
;
MOV #0,@#RSR ; disable receive interrupt
MOV @#BPTINTV,@#CLKINTV ; repair clock interrupt vector
MOV @#BPTPR,@#BPTINTV+2 ; reestablish BPT handler priority
MOV @#BPTLOC,@#BPTINTV ; repair BPT handler address
MOV #340,@#QXCINTV+2 ; repair QX controller vector
RTS PC ; and return
;
.END
>>>> RECSW.TEXT
(* RECEIVE SECTION *)
segment procedure recsw(var rec_ok: boolean);
function rdata: char;
(* send file data *)
var num, len: integer;
ch: char;
begin
repeat
if numtry > maxtry then
begin
state := 'a';
exit(rdata)
end;
num_try := num_try + 1;
ch := rpack(len,num,recpkt); (* receive a packet *)
refresh_screen(numtry,n);
if (ch = 'D') then (* got data packet *)
begin
if (num <> (n mod 64)) then (* wrong packet *)
begin
if (oldtry > maxtry) then
begin
rdata := 'a'; (* too many tries, abort *)
exit(rdata)
end; (* if *)
n := n - 1;
if (num = (n mod 64)) then (* previous packet again *)
begin (* so re-ACK it *)
spack('Y',num,6,packet);
numtry := 0; (* reset try counter *)
(* stay in same state *)
end (* if *)
else (* wrong number *)
state := 'a' (* so abort *)
end (* if *)
else (* right packet *)
begin
bufemp(recpkt,f,len); (* write data to file *)
spack('Y',(n mod 64),0,packet); (* ACK packet *)
oldtry := numtry; (* reset try counters *)
if numtry > 1 then
clearbuf(rq); (* clear buffer *)
numtry := 0;
n := n + 1 (* bump packet number *)
(* stay in data send state *)
end (* else *)
end (* if 'D' *)
else if (ch = 'F') then (* file header *)
begin
if (oldtry > maxtry) then
begin
rdata := 'a'; (* too many tries, abort *)
exit(rdata)
end; (* if *)
n := n - 1;
if (num = (n mod 64)) then (* previous packet again *)
begin (* so re-ACK it *)
spack('Y',num,0,packet);
clear_buf(rq); (* and empty out buffer *)
numtry := 0; (* reset try counter *)
state := state; (* stay in same state *)
end (* if *)
else
state := 'a' (* not previous packet, abort *)
end (* if 'F' *)
else if (ch = 'Z') then (* end of file *)
begin
if (num <> (n mod 64)) then(* wrong packet, abort *)
begin
rdata := 'a';
exit(rdata)
end; (* if *)
spack('Y',n mod 64,0,packet); (* ok, ACK it *)
close(f,lock); (* close up the file *)
n := n + 1; (* bump packet counter *)
state := 'f'; (* go to complete state *)
end (* else if 'Z' *)
else if (ch = 'E') then (* error packet *)
begin
error(recpkt,len); (* display error *)
state := 'a' (* and abort *)
end (* if 'E' *)
else if (ch <> chr(0)) then (* some other packet type, *)
state := 'a' (* abort *)
until (state <> 'd');
rdata := state
end; (* rdata *)
function rfile: char;
(* receive file header *)
var num, len: integer;
ch: char;
oldfn: string;
i: integer;
procedure makename(recpkt: packettype; var fn: string; l: integer);
function exist(fn: string): boolean;
(* returns true if file named fn exists *)
var f: file;
begin
(*$I-*) (* turn off i/o checking *)
reset(f,fn);
exist := (ioresult = 0)
(*$I+*)
end; (* exist *)
procedure checkname(var fn: string);
(* if file fn exists, makes a new name which doesn't *)
(* does this by changing letters in file name until it *)
(* finds some combination which doesn't exitst *)
var ch: char;
i: integer;
begin
i := 1;
while (i <= length(fn)) and exist(fn) do
begin
ch := 'A';
while (ch in ['A'..'Z']) and exist(fn) do
begin
fn[i] := ch;
ch := succ(ch);
end; (* while *)
i := i + 1
end; (* while *)
end; (* checkname *)
begin (* makename *)
fn := copy(' ',1,15); (* stretch length *)
moveleft(recpkt[0],fn[1],l); (* get filename from packet *)
oldfn := copy(fn, 1,l); (* save fn sent to show user *)
fn := copy(fn,1,min(15,l)); (* set length of filename *)
(* and make sure <= 15 *)
uppercase(fn);
if pos('.TEXT',fn) <> length(fn)-4 then
begin
if length(fn) > 10 then
fn := copy(fn,1,10); (* can only be 15 long in all *)
fn := concat(fn,'.TEXT'); (* and we'll add .TEXT *)
end; (* if *)
if fwarn then (* if file warning is on *)
checkname(fn); (* must check that name unique *)
end; (* makename *)
begin (* rfile *)
if debug then
debugwrite('rfile');
if (numtry > maxtry) then (* if too many tries, give up *)
begin
rfile := 'a';
exit(rfile)
end;
numtry := numtry + 1;
ch := rpack(len,num,recpkt); (* receive a packet *)
refresh_screen(numtry,n);
if ch = 'S' then (* send init, maybe our ACK lost *)
begin
if (oldtry > maxtry) then (* too many tries, abort *)
begin
rfile := 'a';
exit(rfile)
end; (* if *)
n := n - 1;
if num = (n mod 64) then (* previous packet mod 64? *)
begin (* yes, ACK it again *)
spar(packet); (* with our send init params *)
spack('Y',num,6,packet);
numtry := 0; (* reset try counter *)
rfile := state; (* stay in same state *)
end (* if *)
else (* not previous packet, abort *)
state := 'a'
end (* if 'S' *)
else if (ch = 'Z') then (* end of file *)
begin
if (oldtry > maxtry) then (* too many tries, abort *)
begin
rfile := 'a';
exit(rfile)
end; (* if *)
n := n - 1;
if num = (n mod 64) then (* previous packet mod 64? *)
begin (* yes, ACK it again *)
spack('Y',num,0,packet);
numtry := 0;
rfile := state (* stay in same state *)
end (* if *)
else
rfile := 'a' (* no, abort *)
end (* else if *)
else if (ch = 'F') then (* file header *)
begin (* which is what we really want *)
if (num <> (n mod 64)) then (* if wrong packet, abort *)
begin
rfile := 'a';
exit(rfile)
end;
makename(recpkt,filename,len); (* get filename, make unique if filew *)
gotoxy(filepos,fileline);
write(oldfn,' ==> ',filename);
if not getfil(filename) then (* try to open new file *)
begin
ioerror(ioresult); (* if unsuccessful, tell them *)
rfile := 'a'; (* and abort *)
exit(rfile)
end; (* if *)
spack('Y',n mod 64,0,packet); (* ACK file header *)
oldtry := numtry; (* reset try counters *)
numtry := 0;
n := n + 1; (* bump packet number *)
rfile := 'd'; (* switch to data state *)
end (* else if *)
else if ch = 'B' then (* break transmission *)
begin
if (num <> (n mod 64)) then (* wrong packet, abort *)
begin
rfile := 'a';
exit(rfile)
end;
spack('Y',n mod 64,0,packet); (* say ok *)
rfile := 'c' (* go to complete state *)
end (* else if *)
else if (ch = 'E') then
begin
error(recpkt,len);
rfile := 'a'
end
else if (ch = chr(0)) then (* returned false *)
rfile := state (* so stay in same state *)
else (* some weird state, so abort *)
rfile := 'a'
end; (* rfile *)
function rinit: char;
(* receive initialization *)
var num, len: integer; (* packet number and length *)
ch: char;
begin
if debug then
debugwrite('rinit');
numtry := numtry + 1;
ch := rpack(len,num,recpkt); (* receive a packet *)
refresh_screen(num_try,n);
if (ch = 'S') then (* send init packet *)
begin
rpar(recpkt); (* get other side's init data *)
spar(packet); (* fill packet with my init data *)
ctl_set := [chr(1)..chr(31),chr(del),quote];
spack('Y',n mod 64,6,packet); (* ACK with my params *)
oldtry := numtry; (* save old try count *)
numtry := 0; (* start a new counter *)
n := n + 1; (* bump packet number *)
rinit := 'f'; (* enter file send state *)
end (* if 'S' *)
else if (ch = 'E') then
begin
rinit := 'a';
error(recpkt,len)
end (* if 'E' *)
else if (ch = chr(0)) then
rinit := 'r' (* stay in same state *)
else
rinit := 'a' (* abort *)
end; (* rinit *)
(* state table switcher for receiving packets *)
begin (* recswok *)
writescreen('Receiving');
state := 'r'; (* initial state is send *)
n := 0; (* set packet # *)
numtry := 0; (* no tries yet *)
while true do
if state in ['d', 'f', 'r', 'c', 'a'] then
case state of
'd': state := rdata;
'f': state := rfile;
'r': state := rinit;
'c': begin
rec_ok := true;
exit(recsw)
end; (* case c *)
'a': begin
rec_ok := false;
exit(recsw)
end (* case a *)
end (* case *)
else (* state not in legal states *)
begin
rec_ok := false;
exit(recsw)
end (* else *)
end; (* recsw *)
>>>> SENDB.TEXT
; ------------------------------
; . SENDS TTY Output Routine .
; ------------------------------
;
; SENDBRK is a routine to send a continuous break to an IBM mainframe.
; The appropriate PASCAL declaration is:
;
; PROCEDURE SENDBRK; EXTERNAL; (*to send a break*)
;
;
XDB .EQU 177526 ; absolute address, transmit data buffer
XSR .EQU 177524 ; absolute address, transmit status register
;
;
.PROC SENDBRK
;
SNDB1: BIT #200,@#XSR ; wait for previous char to complete
BEQ SNDB1
;
MOV #1,@#XSR ; transmit continuous break
MOV #310,R1 ; wait 200 (=310 octal) milliseconds
SNDB2: MOV #124,R0
SNDB3: SUB #1,R0
BNE SNDB3
SUB #1,R1
BNE SNDB2
MOV #0,@#XSR ; clear continuous break
;
RTS PC ; and return
;
.END
>>>> SENDSW.TEXT
(* Send Section *)
segment procedure sendsw(var send_ok: boolean);
var io_status: integer;
procedure openfile;
(* resets file & gets past first 2 blocks *)
begin
(*$I-*) (* turn off compiler i/o checking temporarily *)
reset(oldf,filename);
(*$I+*) (* turn compiler i/o checking back on *)
io_status := io_result;
if (iostatus = 0) then
if (pos('.TEXT',filename) = length(filename) - 4) then
(* is a text file, so *)
i := blockread(oldf,filebuf,2); (* skip past 2 block header *)
end; (* openfile *)
function sinit: char;
(* send init packet & receive other side's *)
var num, len, i: integer; (* packet number and length *)
ch: char;
begin
if debug then
debugwrite('sinit');
if numtry > maxtry then
begin
sinit := 'a';
exit(sinit)
end;
num_try := num_try + 1;
spar(packet);
clear_buf(rq);
refresh_screen(numtry,n);
spack('S',n mod 64,6,packet);
ch := rpack(len,num,recpkt);
if (ch = 'N') then
begin
sinit := 's';
exit(sinit)
end (* if 'N' *)
else if (ch = 'Y') then
begin
if ((n mod 64) <> num) then (* not the right ack *)
begin
sinit := state;
exit(sinit)
end;
rpar(recpkt);
if (eol = chr(0)) then (* if they didn't spec eol *)
eol := chr(my_eol); (* use mine *)
if (quote = chr(0)) then (* if they didn't spec quote *)
quote := my_quote; (* use mine *)
ctl_set := [chr(1)..chr(31),chr(del),quote];
numtry := 0;
n := n + 1; (* increase packet number *)
sinit := 'f';
exit(sinit)
end (* else if 'Y' *)
else if (ch = 'E') then
begin
error(recpkt,len);
sinit := 'a'
end (* if 'E' *)
else if (ch = chr(0)) then
sinit := state
else if (ch <> 'N') then
sinit := 'a'
end; (* sinit *)
function sdata: char;
(* send file data *)
var num, len: integer;
ch: char;
packarray: array[false..true] of packettype;
sizearray: array[false..true] of integer;
current: boolean;
b: boolean;
function other(b: boolean): boolean;
(* complements a boolean which is used as array index *)
begin
if b then
other := false
else
other := true
end; (* other *)
begin
current := true;
packarray[current] := packet;
sizearray[current] := size;
while (state = 'd') do
begin
if (numtry > maxtry) then (* if too many tries, give up *)
state := 'a';
b := other(current);
numtry := numtry + 1;
(* send a data packet *)
spack('D',n mod 64,sizearray[current],packarray[current]);
refresh_screen(numtry,n);
(* set up next packet *)
sizearray[b] := bufill(packarray[b]);
ch := rpack(len,num,recpkt); (* receive a packet *)
if ch = 'N' then (* NAK, so just stay in this state *)
if ((n+1) mod 64 <> num) then (* unless NAK for next, which *)
sdata := state
else (* is just like ACK for this packet *)
begin
if num > 0 then
num := (num - 1) (* in which case, decrement num *)
else
num := 63;
ch := 'Y'; (* and indicate an ACK *)
end; (* else *)
if (ch = 'Y') then
begin
if ((n mod 64) <> num) then (* if wrong ACK *)
begin
sdata := state; (* stay in same state *)
exit(sdata); (* get out of here *)
end; (* if *)
if numtry > 1 then
clear_buf(rq); (* if anything in buffer, flush it *)
numtry := 0;
n := n + 1;
current := b;
if sizearray[current] = ateof then
state := 'z' (* set state to eof *)
else
state := 'd' (* else stay in data state *)
end (* if *)
else if (ch = 'E') then
begin
error(recpkt,len);
state := 'a'
end (* if 'E' *)
else if (ch = chr(0)) then (* receive failure, so stay in d *)
begin
end
else if (ch <> 'N') then
state := 'a' (* on any other goto abort state *)
end; (* while *)
size := sizearray[current];
packet := packarray[current];
sdata := state
end; (* sdata *)
function sfile: char;
(* send file header *)
var num, len, i: integer;
ch: char;
fn: packettype;
oldfn: string;
procedure legalize(var fn: string);
(* make sure file name will be legal to other computer *)
var count, i, j, l: integer;
procedure uppercase(var s: string);
var i: integer;
begin
for i := 1 to length(s) do
if s[i] in ['a'..'z'] then
s[i] := chr(ord('A') + ord(s[i]) - ord('a'))
end; (* uppercase *)
begin
count := 0;
l := length(fn);
for i := 1 to l do (* count '.'s in fn *)
if fn[i] = '.' then
count := count + 1;
for i := 1 to count-1 do (* remove all but 1 *)
begin
j := 1;
while (j < l) and (fn[j] <> '.') do
j := j + 1;
delete(fn,j,1);l := l - 1
end; (* for i *)
l := length(fn);
i := pos(':',fn);
if (i <> 0) then
begin
fn := copy(fn,i,l-i);
l := length(fn)
end;
i := 1;
while (i <= length(fn)) do
if not(fn[i] in ['a'..'z','A'..'Z','.','0'..'9']) then
delete(fn,i,1)
else
i := i + 1;
uppercase(fn)
end; (* legalize *)
begin
if debug then
debugwrite('sfile');
if (numtry > maxtry) then (* if too many tries, give up *)
begin
sfile := 'a';
exit(sfile)
end;
numtry := numtry + 1;
oldfn := filename;
legalize(filename); (* make filename acceptable to remote *)
len := length(filename);
moveleft(filename[1],fn[0],len); (* move filename into a packettype *)
gotoxy(filepos,fileline);
write(oldfn,' ==> ',filename);
refresh_screen(numtry,n);
spack('F',n mod 64,len,fn); (* send file header packet *)
size := bufill(packet); (* get first data from file *)
(* while waiting for response *)
ch := rpack(len,num,recpkt);
if ch = 'N' then (* NAK, so just stay in this state *)
if ((n+1) mod 64 <> num) then (* unless NAK for next packet, which *)
exit(sfile) (* is just like ACK for this packet *)
else
begin
if (num > 0) then
num := (num - 1) (* in which case, decrement num *)
else
num := 63;
ch := 'Y'; (* and indicate an ACK *)
end; (* else *)
if (ch = 'Y') then
begin
if ((n mod 64) <> num) then (* if wrong ACK, stay in F state *)
exit(sfile);
numtry := 0;
n := n + 1;
sfile := 'd';
end (* if *)
else if (ch = 'E') then
begin
error(recpkt,len);
sfile := 'a'
end (* if 'E' *)
else if (ch <> chr(0)) and (ch <> 'N') then (* don't recognize it *)
sfile := 'a'
end; (* sfile *)
function seof: char;
(* send end of file *)
var num, len: integer;
ch: char;
begin
if debug then
debugwrite('seof');
if (numtry > maxtry) then (* if too many tries, give up *)
begin
seof := 'a';
exit(seof)
end;
numtry := numtry + 1;
refresh_screen(numtry,n);
spack('Z',(n mod 64),0,packet); (* send end of file packet *)
if debug then
debugwrite('seof1');
ch := rpack(len,num,recpkt);
if ch = 'N' then (* NAK, so just stay in this state *)
if ((n+1) mod 64 <> num) then (* unless NAK for next packet, which *)
exit(seof) (* is just like ACK for this packet *)
else
begin
if num > 0 then
num := (num - 1) (* in which case, decrement num *)
else
num := 63;
ch := 'Y'; (* and indicate an ACK *)
end; (* else *)
if (ch = 'Y') then
begin
if debug then
debugwrite('seof2');
if ((n mod 64) <> num) then (* if wrong ACK, stay in F state *)
exit(seof);
numtry := 0;
n := n + 1;
if debug then
debugwrite(concat('closing ',s));
close(oldf);
seof := 'b'
end (* if *)
else if (ch = 'E') then
begin
error(recpkt,len);
seof := 'a'
end (* if 'E' *)
else if (ch = chr(0)) then (* receive failed, so stay in z state *)
begin
end
else if (ch <> 'N') then (* other error, just abort *)
seof := 'a'
end; (* seof *)
function sbreak: char;
var num, len: integer;
ch: char;
(* send break (end of transmission) *)
begin
if debug then
debugwrite('sbreak');
if (numtry > maxtry) then (* if too many tries, give up *)
begin
sbreak := 'a';
exit(sbreak)
end;
numtry := numtry + 1;
refresh_screen(numtry,n);
spack('B',(n mod 64),0,packet); (* send end of file packet *)
ch := rpack(len,num,recpkt);
if ch = 'N' then (* NAK, so just stay in this state *)
if ((n+1) mod 64 <> num) then (* unless NAK for next packet, which *)
exit(sbreak) (* is just like ACK for this packet *)
else
begin
if num > 0 then
num := (num - 1) (* in which case, decrement num *)
else
num := 63;
ch := 'Y'; (* and indicate an ACK *)
end; (* else *)
if (ch = 'Y') then
begin
if ((n mod 64) <> num) then (* if wrong ACK, stay in B state *)
exit(sbreak);
numtry := 0;
n := n + 1;
sbreak := 'c' (* else, switch state to complete *)
end (* if *)
else if (ch = 'E') then
begin
error(recpkt,len);
sbreak := 'a'
end (* if 'E' *)
else if (ch = chr(0)) then (* receive failed, so stay in z state *)
begin
end
else if (ch <> 'N') then (* other error, just abort *)
sbreak := 'a'
end; (* sbreak *)
(* state table switcher for sending *)
begin (* sendsw *)
if debug then
debugwrite(concat('Opening ',filename));
openfile;
if io_status <> 0 then
begin
writeln(chr(clear_screen));
io_error(io_status);
send_ok := false;
exit(sendsw)
end;
write_screen('Sending');
state := 's';
n := 0; (* set packet # *)
numtry := 0;
while true do
if state in ['d', 'f', 'z', 's', 'b', 'c', 'a'] then
case state of
'd': state := sdata;
'f': state := sfile;
'z': state := seof;
's': state := sinit;
'b': state := sbreak;
'c': begin
send_ok := true;
exit(sendsw)
end; (* case c *)
'a': begin
send_ok := false;
exit(sendsw)
end (* case a *)
end (* case *)
else (* state not in legal states *)
begin
send_ok := false;
exit(sendsw)
end (* else *)
end; (* sendsw *)