home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
kermit.columbia.edu
/
kermit.columbia.edu.tar
/
kermit.columbia.edu
/
archives
/
ucsdmagiscan2.zip
/
kermit.text
< prev
next >
Wrap
Text File
|
2011-08-11
|
23KB
|
662 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
}
{Adapted to Joyce Loebl's Magiscan 2 Image processing computer,
by Henry Balen, Lancaster University }
{Changes:
- added ability for the parser to recognize digits,
this enabled a Baudrate command to be implemented
- added a command to set a work disk, set disk #.
- The IO subroutines were put into an unit RS232 and
changed to suit the Magiscan.
- put the parser back into an unit since the Magiscan has 128K
available.
- modified the constants for the screen because the Magiscan only
has 64 columns.
- Added a unit SysUnit to enable the user to interogate the
current work disk and delete files if so wishes.
- Added a unit FileHandle which gives routines for accessing
files for reading and writing, the old version of this didn't
close a file if there was an unsuccessful receive/send this
is now fixed.
- Modified the Buffer empty and fill routines to use these.
- Added the ability to do eight bit prefixing and the necessary
routines for this.
- Have added a new command called TRANSFER ( do a TRANSFER
TYPE <type> ), which enables transfers of image,data,code and
text 'types'.
- There is also image LOAD routine implemented, this allows
the images to be loaded from disk and transfered to the Host
straight from image memory.
}
Futher changes by H Balen, now of Joyce Loebl, March 1986
{
- The receive packet routine has been put in the magiscan's
microcode, data can now be succesfully received and transmitted
at 9600 baud (except images ! max =4800 ), though the screen
cannot scroll fast enough for incoming characters greater
than 1200.
- Two new options have been included - they are the MUX delay
which tells the Magiscan how many cycles the wait when
sending characters, and the option of using the winchester
on #9.
}
(*$R-*) (* turn range checking off *)
(*$S+*) (* turn swapping on *)
(* $L PRINTER: *) (* no listing *)
Uses
M2Types,M2IpRoot,M2Sys,
(*$U DISK.CODE*)DiskUnit,
(*$U RS232.Code*)RS232,
(*$U SysUnit.Code*)SysUnit,
(*$U ParUnit.Code*)ParseUnit,
(*$U FileUnit.Code*)FileHandle,
(*$U HANDLE.CODE*)HANDLER; { the microcode }
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_bquote = '&'; { binary quate 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 *)
(* 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 = 54;
packet_pos = 19;
retry_pos = 17;
file_pos = 11;
Intsize = 15;
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 *)
Port = (Terminal,Modem);
var state: char; (* current state *)
s: string;
eol, bquote, quote, esc_char: char;
fwarn, ibm, half_duplex, debug: boolean;
delay, 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;
vol, Baud: integer;
parity_array: packed array[char] of char;
ctlset: set of char;
rec_ok, send_ok: boolean;
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 ino_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 Bbufemp(buffer: packettype; len: integer);
forward;
function Bbufill(var buffer: packettype): integer;
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;
(*$I HELP.TEXT*) (* Segment Procedure Help *)
(*$I SENDSW.TEXT*) (* Segment Procedure Sendsw *)
(*$I RECSW.TEXT*) (* Segment Procedure Recsw *)
(*$I UTILS.TEXT *) (* General Utility procedures *)
(*$I BINUTILS.TEXT*) { Routines for Binary transfer }
(*$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','D','?'] then
begin
writeln;
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 *)
'D':begin
vol := ord(disk[2]) - ord('0');
if vol in [9,10] then
writeln('Cannot DIR a Winchester')
else
PrintNames(vol,value)
end; (* D *)
'?': begin (* ?: show options *)
(* writeln('B Send a BREAK signal.'); *)
writeln('C Close Connection, return to ');
writeln(' KERMIT-UCSD command level.');
writeln('S Show Status of connection');
writeln('D displays the current directory');
writeln('? Print this list');
write('^',ctl(esc_char),' send the escape ');
writeln('character itself to the');
writeln(' remote host.');
end; (* ? *)
end (* case *)
end
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 writeTrans;
writes the transfer state
begin
write('Transfer Type : ');
case TranState of
CodeFile : writeln('BINARY');
ImgFile : writeln('IMAGE');
TxtFile : writeln('TEXT');
"BinFile : writeln('DATA')
end
end{writeTrans};
procedure show_parms;
(* shows the various settable parameters *)
begin
writeln;
if noun in [allsym, debugsym, ibmsym, escsym, filewarnsym,
muxsym, transym, disksym, localsym, baudsym, 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');
writeln('Baudrate is ',Baud);
writeln('Drive is ',disk);
writeln('MUX is ',MUXDelay);
writetrans
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);
baudsym : writeln('Baudrate is ',Baud);
disksym : writeln('Drive is ',disk);
transym : writetrans;
muxsym : writeln('MUX is ',MUXDelay);
paritysym: begin
case parity of
evenpar: write('Even');
markpar: write('Mark');
nopar: write('No');
oddpar: write('Odd');
end;
writeln(' parity');
end; (* paritysym *)
typesym : writetrans
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 *)
MUXsym : begin
MUXDelay := value
end (* baudsym *);
baudsym : begin
Baud := value;
BaudRate(Baud)
end (* baudsym *);
disksym : begin
if value in [4,5,9] then
begin
disk := ' ';
disk[1] := chr(ord('0')+value);
disk := concat('#',disk);
disk := concat(disk,':')
end
else
writeln('Drive does not exist ')
end (* disksym *)
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;
bquote := my_bquote;
ctlset := [chr(1)..chr(31),chr(del),quote,bquote];
TranState := TxtFile;
TimInt := My_Time;
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;}
initM;
Baud := 1200;
FileInit;
value := 0;
disk := '#5:'
end; (* initialize *)
procedure closeup;
begin
writeln(chr(ff){clearscreen});
end; (* closeup *)
begin (* kermit *)
initialize;
{ Load in the microcode }
OVLYLOAD('HANDLE');
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;
Loadsym: begin
uppercase(filename);
LoadIm(filename)
end;
recsym: begin
recsw(rec_ok);
gotoxy(0,debugline);
write(chr(bell));
if rec_ok then
writeln('successful receive')
else
writeln('unsuccessful receive');
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 *)
closeF(filename,False);
(*$I+*) (* set i/o checking back on *)
gotoxy(0,promptline);
end; (* sendsym *)
delsym: begin
uppercase(filename);
vol := ord(disk[2]) - ord('0');
Delfile(filename,vol)
end; (* delsym *)
setsym: set_parms;
transym: begin
if noun = Typesym then
case adj of
binsym : TranState := CodeFile;
datasym : TranState := BinFile;
textsym : TranState := TxtFile;
imagesym : TranState := ImgFile;
end
else
write(Bell)
end;
show_sym: show_parms;
dirsym : begin
vol := ord(disk[2]) - ord('0');
if vol in [9,10] then
writeln('Cannot DIR a Winchester')
else
PrintNames(vol,value)
end (* dirsym *)
end; (* case verb *)
end; (* case parse *)
{ unitclear(1); }(* clear any trash in input *)
{ unitclear(2); } (* Don't clear the screen ! *)
until (verb = exitsym) or (verb = quitsym);
closeup
end.(* kermit *)