home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
pub
/
ucsdwdme
/
kermit.text
< prev
next >
Wrap
Text File
|
2020-01-01
|
19KB
|
565 lines
program kermit;
UCSD Pascal KERMIT for the Terak p-System, from Kate MacGregor, Cornell U
Adapted to Pascal Microengine by Tim Shimeall, UCI
{Changes:
- Added device declarations copied from Microengine hardware documentation
- Replaced external assembly language routines with Pascal versions
- Modified debug messages to be label values printed
- Changed format of packetwrite display to show header fields
- Implemented machine-dependent packet timeout
- Added debug packetwrites in recsw
- Added wrap-around debug info region
- Added legality check in showparms
- Removed lf elimination check in echo procedure
- Unitwrite calls replaced by calls to device driving routines
- Most uses of char_int_rec replaced by ord and chr
- Removed queue (no interrupts)
- Used sets for integer ops to getaround Microengine bug
- Changed parser from a unit to a segment procedure to allow swapping
- Split utility procs into separate files for editing and transfer convinience
}
(*$R-*) (* turn range checking off *)
(*$S+*) (* turn swapping on *)
(* $L+*) (* no listing *)
const blksize = 512;
oport = 8; (* output port # *)
(* clearscreen = 12; charcter which erases screen *)
bell = 7; (* ASCII bell *)
esc = 27; (* ASCII escape *)
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 *)
eoln_sym = 13; (* pascal eoln sym *)
back_space = 8; (* pascal backspace sym *)
(* MICROENGINE dependent constants *)
intsize = 15; (* number of bits in an integer minus 1 *)
Channel0=-992; {FC20 = serial Port B register}
Channel1=-1008; {FC10 = serial Port A register}
(* Elements of the status vector in the "StatCmdRec" declared below*)
RegEmpty=0;
DataReceived=1;
OverError=2;
FrameError=4;
(* bits 3,5,6,and 7 are not used, since they rely on specific wiring,
and seem to be unreliable *)
(* 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;
prompt_line = 7;
debug_line = 9;
debug_max = 12; (* Max lines of debug to show at once *)
(* position on line to put info *)
statuspos = 70;
packet_pos = 19;
retry_pos = 17;
file_pos = 11;
type 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 *)
(* replaced by set version to escape microengine
bug *)
case boolean of
true: (i: integer);
false: (b: set of 0..intsize);
end; (* record *)
(* MICROENGINE Dependent Types *)
Port = (Terminal,Modem);
Statcmdrec = RECORD CASE BOOLEAN OF (* Only the Status field is used
in this code, but the declaration
is from Western Digital doc. *)
TRUE:(Command:INTEGER);
FALSE:(Status:PACKED ARRAY [0:7] OF BOOLEAN);
END;
SerialRec = RECORD
SerData:INTEGER;
StatSynDle:StatCmdRec;
Control2:INTEGER;
Control1:INTEGER;
filler:ARRAY [0..3] OF INTEGER;
Switch:StatCmdRec;
END;
(* Parser Types *)
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 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 *)
debnext:0..7; (* offset for next debug message *)
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;
(* MICROENGINE Dependent Variable declarations *)
PortA,PortB:RECORD CASE BOOLEAN OF
TRUE:(DevAdd:INTEGER);
FALSE:(Serial:^SerialRec);
END;
(* Parser vars *)
noun, verb, adj: vocab;
status: statustype;
vocablist: array[vocab] of string[13];
filename, line: string;
newescchar: char;
expected: set of vocab;
function read_ch(p: port; var ch: char): boolean;
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; p: port): boolean;
forward;
function getsoh(p: port): boolean;
forward;
function rpack(var len, num: integer; var data: packettype): char;
forward;
procedure read_str(p: port; var s: string);
forward;
procedure packetwrite(p: packettype; len: integer);
forward;
procedure show_parms;
forward;
procedure uppercase(var s: string); forward;
(*$I WDFORW.TEXT *) (* Forward Declarations for WDPROCS.TEXT *)
(*$I HELP.TEXT*) (* Segment Procedure Help *)
(*$I SENDSW.TEXT*) (* Segment Procedure Sendsw *)
(*$I RECSW.TEXT*) (* Segment Procedure Recsw *)
(*$I PARSE.TEXT*) (* Segment Function Parse *)
(*$I WDPROCS.TEXT*) (* MICROENGINE dependent routines*)
(*$I UTILS.TEXT *) (* General Utility procedures *)
(*$I RSUTILS.TEXT *) (* Utility procedures for send and receive *)
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(terminal,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);
while not istbtr do;
sndbbt(ch);
end (* if *)
end (* else if *)
else (* anything else: ignore *)
write(chr(bell))
end; (* read_esc *)
begin (* connect *)
writeln('Connecting to host...type CTRL-',ctl(esc_char),' C to exit');
close := false;
repeat
if read_ch(modem,ch) then (* if char from host then *)
echo(ch); (* echo it *)
if read_ch(terminal,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);
while not istbtr do;
sndbbt(ch) (* 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
if noun in [allsym, debugsym, ibmsym, escsym, filewarnsym, localsym,
paritysym] then
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');
(' parity');
end; (* paritysym *)
end (* case *)
else write(chr(bell));
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;
debnext:=0;
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;
init;
end; (* initialize *)
procedure closeup;
begin
finit;
writeln(chr(esc),'E'{clearscreen});
end; (* closeup *)
begin (* kermit *)
initialize;
repeat
write('Kermit-UCSD> ');
readstr(terminal,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 *)
unitclear(1); (* clear any trash in input *)
unitclear(2);
until (verb = exitsym) or (verb = quitsym);
closeup
end. (* kermit *)