home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
archives
/
intelrmx86.tar.gz
/
intelrmx86.tar
/
kermit.p86
< prev
next >
Wrap
Text File
|
1985-10-28
|
21KB
|
887 lines
$compact
$optimize(3)
kermit:
do;
declare true literally '0FFH';
declare false literally '00H';
$INCLUDE(:INC:LTKSEL.LIT)
$INCLUDE(:INC:NEXCEP.LIT)
$INCLUDE(:INC:IEXCEP.LIT)
declare null literally '000H';
declare lf literally '0AH';
declare cr literally '0DH';
declare crlf literally 'cr,lf,null';
declare space literally '20H';
declare dollar literally '24H';
declare soh literally '1';
declare term$attr structure
(num$words word,
num$used word,
connect$flag word,
terminal$flag word,
in$baud$rate word,
out$baud$rate word,
scroll$lines word,
x$y$size word,
x$y$offset word,
flow$control word,
high$water$mark word,
low$water$mark word,
fc$on$char word,
fc$off$char word);
declare fdata structure(
len$owner byte,
owner(14) byte,
length dword,
type byte,
owner$access byte,
world$access byte,
create$time dword,
last$mod$time dword,
reserved(20) byte);
declare file$len (2) word PUBLIC AT (@fdata.length);
declare file$truncate byte;
declare buflen literally '122';
declare buffer(buflen) byte PUBLIC;
declare outbuf(buflen) byte;
declare takebuf(buflen) byte;
declare cmdstr(buflen) byte PUBLIC;
declare query_in(10) byte;
declare outlen word;
declare trans_wait word public;
declare status word public;
declare old_baud_in word;
declare old_baud_ci word;
declare dev_attach byte;
declare server$mode byte public;
declare baud_rate word PUBLIC;
declare block_check byte public;
declare duplex byte PUBLIC;
declare break_char byte public;
declare parity byte public;
declare delim byte public;
declare len word;
declare send$delay byte public;
declare send$eol byte public;
declare send$paclen byte public;
declare send$padchar byte public;
declare send$padding byte public;
declare send$pause byte public;
declare send$quote byte public;
declare send$start byte public;
declare send$time byte public;
declare recv$eol byte public;
declare recv$paclen byte public;
declare recv$padchar byte public;
declare recv$padding byte public;
declare recv$pause byte public;
declare recv$quote byte public;
declare recv$start byte public;
declare recv$time byte public;
declare send$setup$string(6) byte public;
declare cmd byte public;
declare in$conn token public;
declare out$conn token public;
declare ci$conn token public;
declare co$conn token public;
declare filestr structure
(len byte,
name(80) byte);
declare filename structure
(len byte,
name(80) byte) public;
declare file$conn token public;
declare takename structure
(len byte,
name(80) byte);
declare take$conn token;
declare takelen byte initial (0);
declare takeindex byte initial (0);
declare debug byte public;
declare qopen byte public;
declare iobuff(1024) byte external;
/* here are the subroutines */
$INCLUDE(:INC:HGTIPN.EXT)
$INCLUDE(:INC:HSTPBF.EXT)
$INCLUDE(:INC:UFLINF.EXT)
$INCLUDE(:INC:UATACH.EXT)
$INCLUDE(:INC:UOPEN.EXT)
$INCLUDE(:INC:UCLOSE.EXT)
$INCLUDE(:INC:UWRITE.EXT)
$INCLUDE(:INC:UDCEX.EXT)
$INCLUDE(:INC:UCREAT.EXT)
$INCLUDE(:INC:UDCTIM.EXT)
$INCLUDE(:INC:UDETAC.EXT)
$INCLUDE(:INC:ISSPEC.EXT)
$INCLUDE(:INC:USPECL.EXT)
$INCLUDE(:INC:USWBF.EXT)
$INCLUDE(:INC:UREAD.EXT)
$INCLUDE(:INC:UEXIT.EXT)
$INCLUDE(:INC:UGTARG.EXT)
$INCLUDE(:INC:UTRUNC.EXT)
connect:
procedure external;
end connect;
spar: procedure (a) external;
declare a address;
end spar;
rpar: procedure (a) external;
declare a address;
end rpar;
do$put: procedure(conn) external;
declare conn token;
end do$put;
send: procedure byte external;
end send;
bye: procedure byte external;
end bye;
finish: procedure byte external;
end finish;
get: procedure byte external;
end get;
recv: procedure byte external;
end recv;
trans: procedure byte external;
end trans;
check$error: PROCEDURE (fatal) byte PUBLIC;
declare fatal byte;
declare dummy word;
declare exc$buf structure(
count byte,
char(80) byte);
if status <> E$OK then do;
call DQ$DECODE$EXCEPTION(status,@exc$buf,@dummy);
call DQ$WRITE(co$conn,@exc$buf.char,exc$buf.count,@dummy);
call DQ$WRITE(co$conn,@(cr,lf),2,@dummy);
if fatal<>0 then call exit$cmd(3);
return true;
end;
return false;
end check$error;
declare digit word;
declare numbuf(20) byte;
declare index byte;
nout: procedure(n) public;
declare n word;
if n = 0 then
do;
call co('0');
return;
end;
index = 1;
do while (n > 0);
digit = n mod 10;
numbuf(index) = digit+030H;
index = index + 1;
n = n / 10;
end;
do while ((index := index - 1) > 0);
call co(numbuf(index));
end;
end nout;
noutd: procedure(n) public;
declare n dword;
if n = 0 then
do;
call co('0');
return;
end;
index = 1;
do while (n > 0);
digit = n mod 10;
numbuf(index) = digit+030H;
index = index + 1;
n = n / 10;
end;
do while ((index := index - 1) > 0);
call co(numbuf(index));
end;
end noutd;
nin: procedure(string) address public;
declare string address;
declare result address;
declare c based string byte;
result = 0;
if (string <> 0) then do;
do while (c >= 030H) and (c <= 039H);
result = result * 10 + (c - 030H);
string = string + 1;
end;
end;
return result;
end nin;
co: procedure(c) public;
declare c byte;
outbuf(outlen)=c;
outlen=outlen+1;
if outlen>50 then do;
call DQ$WRITE(co$conn,@outbuf,outlen,@status);
if check$error(1) then return;
outlen=0;
end;
end co;
do$co: procedure public;
if outlen>0 then do;
call DQ$WRITE(co$conn,@outbuf,outlen,@status);
if check$error(1) then return;
outlen=0;
end;
return;
end do$co;
newline: procedure public;
outbuf(outlen)=cr;
outbuf(outlen+1)=lf;
call DQ$WRITE(co$conn,@outbuf,outlen+2,@status);
if check$error(1) then return;
outlen=0;
end newline;
prints: procedure(msg) public;
declare msg pointer;
declare buff BASED msg structure
(len byte,
msg byte);
call do$co;
call DQ$WRITE(co$conn,@buff.msg,buff.len,@status);
if check$error(1) then return;
return;
end prints;
print: procedure(msg) public;
declare (msg,oldmsg) pointer;
declare c based msg (1) byte;
declare i word;
call do$co;
oldmsg=msg;
i=0;
do while (c(i) > 0) and (c(i) <> '$');
if c(i) = '\' then do;
if i>0 then do;
call DQ$WRITE(co$conn,oldmsg,i,@status);
if check$error(1) then return;
end;
call DQ$WRITE(co$conn,@(cr,lf),2,@status);
if check$error(1) then return;
oldmsg=@c(i+1);
i=0;
msg=oldmsg;
end;
else i=i+1;
end;
if i>0 then do;
call DQ$WRITE(co$conn,oldmsg,i,@status);
if check$error(1) then return;
end;
end print;
set$term$attr: procedure(qdefault);
declare qdefault byte;
declare c byte;
declare save$conn$flag word;
declare save$term$flag word;
if qdefault then do;
/* here restore normal terminal attributes */
term$attr.connect$flag=save$conn$flag;
term$attr.terminal$flag=save$term$flag;
end;
else do;
/* here set kermit terminal attributes */
save$conn$flag=term$attr.connect$flag;
save$term$flag=term$attr.terminal$flag;
term$attr.connect$flag=term$attr.connect$flag OR 7;
if parity=4 then do;
term$attr.connect$flag=term$attr.connect$flag OR 18H;
term$attr.terminal$flag=(term$attr.terminal$flag OR 1F0H) xor 0E0H;
end;
else call print(@('Unsupported parity specified',crlf));
if duplex then
term$attr.terminal$flag=term$attr.terminal$flag OR 2;
else
term$attr.terminal$flag=term$attr.terminal$flag AND 0FFFDH;
end;
call RQ$S$SPECIAL(in$conn,5,@term$attr,0,@status);
if check$error(1) then return;
if NOT qdefault then do;
/* PURGE ANY INPUT QUEUED UP */
c=1;
do while c<>0;
c=DQ$READ(in$conn,@iobuff,127,@status);
if check$error(1) then return;
end;
end;
end set$term$attr;
get$term$attr: procedure;
call RQ$S$SPECIAL(in$conn,4,@term$attr,0,@status);
if check$error(1) then return;
if debug then do;
call print(@('conn_flag ',null));
call nout(term$attr.connect$flag);
call print(@(' term_flag ',null));
call nout(term$attr.terminal$flag);
call newline;
call print(@('baud rate in/out ',null));
call nout(term$attr.in$baud$rate);
call co(' ');
call nout(term$attr.out$baud$rate);
call newline;
call print(@('flow control ',null));
call nout(term$attr.flow$control);
call newline;
end;
return;
end get$term$attr;
/* IOINIT: */
ioinit: procedure;
ci$conn=DQ$ATTACH(@(4,':CI:'),@status);
co$conn=DQ$ATTACH(@(4,':CO:'),@status);
call DQ$OPEN(ci$conn,1,2,@status);
call DQ$OPEN(co$conn,2,0,@status);
if debug then CALL DQ$WRITE(co$conn,
@('openned consol for I/O',cr,lf),24,@status);
in$conn=ci$conn;
out$conn=co$conn;
call get$term$attr;
call print(@('Default communication thru :CI:/:CO:',crlf));
end ioinit;
file$open: procedure (mode) PUBLIC;
declare mode byte;
file$conn=DQ$ATTACH(@filename,@STATUS);
file$truncate=false;
if mode=2 then do;
if status=E$FNEXIST then
file$conn=DQ$CREATE(@filename,@status);
else if status=E$OK then do;
call print(@('About to overwrite file ',null));
call prints(@filename);
call print(@(', please confirm',null));
if NOT query then return;
file$truncate=true;
end;
end;
if check$error(0) then return;
call DQ$OPEN(file$conn,mode,2,@status);
if check$error(0) then return;
if mode=1 then do;
call DQ$FILE$INFO(file$conn,0,@fdata,@status);
if check$error(0) then return;
end;
qopen=true;
return;
end file$open;
file$close: procedure public;
if qopen then do;
if file$truncate then do;
call DQ$TRUNCATE(file$conn,@status);
if check$error(0) then return;
end;
call DQ$CLOSE(file$conn,@status);
if check$error(0) then return;
call DQ$DETACH(file$conn,@status);
if check$error(0) then return;
qopen=false;
end;
end file$close;
return$to$ci: procedure;
if in$conn <> ci$conn then do;
call close$in;
in$conn=ci$conn;
out$conn=co$conn;
call get$term$attr;
old_baud_in=term$attr.in$baud$rate;
call print(@('set connection via :CI:/:CO:',crlf));
if baud_rate<>0 then do;
if term$attr.in$baud$rate<>baud_rate then do;
call print(@('you are about to change the CI/CO baud rate',
', please confirm:',null));
if query then do;
term$attr.in$baud$rate=baud_rate;
call RQ$S$SPECIAL(in$conn,5,@term$attr,0,@status);
if check$error(1) then return;
end;
else baud_rate=0;
end;
end;
end;
end return$to$ci;
close$in: procedure;
if baud_rate <> 0 then do;
if term$attr.in$baud$rate <> old_baud_in then do;
term$attr.in$baud$rate=old_baud_in;
call RQ$S$SPECIAL(in$conn,5,@term$attr,0,@status);
if check$error(1) then return;
end;
end;
call DQ$CLOSE(in$conn,@status);
if check$error(0) then return;
call DQ$DETACH(in$conn,@status);
if check$error(0) then return;
end close$in;
query: procedure byte public;
cmd=DQ$READ(ci$conn,@query_in,10,@status);
if check$error(0) then return false;
if query_in(0)='y' or query_in(0)='Y' then return true;
return false;
end query;
get$line: procedure byte;
declare i byte;
len=0;
takeindex=takeindex+1;
loop:
if takeindex>=takelen then do;
takelen=DQ$READ(take$conn,@takebuf,120,@status);
if check$error(0) then return 0;
takeindex=0;
if takelen=0 then return 0;
end;
do i=takeindex to takelen-1;
buffer(len)=takebuf(i);
if debug then call co(takebuf(i));
if takebuf(i) <> lf then len=len+1;
if takebuf(i)=cr then do;
if debug then call do$co;
takeindex=i;
return len;
end;
end;
takeindex=takelen;
goto loop;
end get$line;
readln: procedure;
declare len word;
len=DQ$READ(ci$conn,@buffer,120,@status);
if check$error(1) then return;
len=DQ$SWITCH$BUFFER(@buffer,@status);
if check$error(1) then return;
end readln;
bye$cmd: procedure PUBLIC;
if in$conn=ci$conn then do;
call print(@('can not send bye to yourself...use SET cmd first',
crlf));
return;
end;
call set$term$attr(false);
if bye then call exit$cmd(3);
else call print(@('Error shutting down remote KERMIT',crlf));
call set$term$attr(true);
end bye$cmd;
conn$cmd: procedure PUBLIC;
if delim<>cr then call port$para;
if in$conn=ci$conn then do;
call print(@('can not connect to yourself...use SET cmd first',
crlf));
return;
end;
call DQ$SPECIAL(3,@ci$conn,@status);
if check$error(1) then return;
call set$term$attr(false);
if term$attr.in$baud$rate>4000 then
call print(@('Warning..at present BAUD rate characters',
' will be lost during BURST transmitions',crlf));
call connect;
call set$term$attr(true);
call DQ$SPECIAL(2,@ci$conn,@status);
if check$error(1) then return;
call newline;
end conn$cmd;
def$cmd: procedure PUBLIC;
call unsupported;
end def$cmd;
exit$cmd: procedure(code) public;
declare code byte;
/* clean up terminal attr. */
call DQ$EXIT(code);
end exit$cmd;
fin$cmd: procedure PUBLIC;
if in$conn=ci$conn then do;
call print(@('can not send finish to yourself...use SET cmd first',
crlf));
return;
end;
call set$term$attr(false);
if NOT finish then
call print(@('Error ending remote KERMIT server',crlf));
call set$term$attr(true);
end fin$cmd;
get$cmd: procedure PUBLIC;
if delim = cr then
call print(@('No files specified',crlf));
else do;
delim=DQ$GET$ARGUMENT(@filename,@status);
if check$error(0) then return;
/* HERE IS WHERE YOU SET UP WILDCARD NAMES USING FILESTR */
call file$open(2);
if qopen then do;
call set$term$attr(false);
if get then call print(@(cr,lf,'OK',crlf));
else call print(@('get failed',crlf));
call set$term$attr(true);
end;
call file$close;
end;
end get$cmd;
loc$cmd: procedure PUBLIC;
call unsupported;
end loc$cmd;
log$cmd: procedure PUBLIC;
call unsupported;
end log$cmd;
recv$cmd: procedure PUBLIC;
if delim <> cr then do;
delim=DQ$GET$ARGUMENT(@filename,@status);
if check$error(0) then return;
call file$open(2);
end;
call set$term$attr(false);
if recv then call print(@(cr,lf,'OK',crlf));
else call print(@(cr,lf,'error recieving file',crlf));
call set$term$attr(true);
call do$put(file$conn);
call file$close;
end recv$cmd;
rem$cmd: procedure PUBLIC;
call unsupported;
end rem$cmd;
send$cmd: procedure PUBLIC;
if delim = cr then
call print(@('No files specified',crlf));
else do;
delim=DQ$GET$ARGUMENT(@filename,@status);
if check$error(0) then return;
/* HERE IS WHERE YOU SET UP WILDCARD NAMES USING FILESTR */
call file$open(1);
/* add check for output file spec */
if qopen then do;
call set$term$attr(false);
if send then call print(@(cr,lf,'OK',crlf));
else call print(@('Send failed',crlf));
call set$term$attr(true);
end;
call file$close;
end;
end send$cmd;
serv$cmd: procedure PUBLIC;
call unsupported;
end serv$cmd;
set$cmd: procedure PUBLIC;
if delim = cr then
call print(@('No parameter specified',crlf));
else do;
delim=DQ$GET$ARGUMENT(@cmdstr,@status);
if check$error(0) then return;
call get$para;
end;
end set$cmd;
get$para: procedure EXTERNAL;
end get$para;
get$in$cmd: procedure EXTERNAL;
end get$in$cmd;
show$cmd: procedure PUBLIC;
call unsupported;
end show$cmd;
stat$cmd: procedure PUBLIC;
call unsupported;
end stat$cmd;
take$cmd: procedure PUBLIC;
declare i byte;
if delim = cr then
call print(@('No file specified',crlf));
else do;
delim=DQ$GET$ARGUMENT(@takename,@status);
if check$error(0) then return;
take$conn=DQ$ATTACH(@takename,@STATUS);
if check$error(0) then return;
call DQ$OPEN(take$conn,1,2,@status);
if check$error(0) then return;
/* here is where you read cmd file, line by line */
do while get$line <> 0;
i=DQ$SWITCH$BUFFER(@buffer,@status);
if check$error(1) then return;
delim=DQ$GET$ARGUMENT(@cmdstr,@status);
if check$error(0) then return;
if cmdstr(0)>0 then call get$in$cmd;
end;
call DQ$CLOSE(take$conn,@status);
if check$error(0) then return;
call DQ$DETACH(take$conn,@status);
if check$error(0) then return;
end;
end take$cmd;
tran$cmd: procedure PUBLIC;
if delim = cr then
call print(@('No files specified',crlf));
else do;
delim=DQ$GET$ARGUMENT(@filename,@status);
if check$error(0) then return;
/* HERE IS WHERE YOU SET UP WILDCARD NAMES USING FILESTR */
call file$open(1);
if qopen then do;
call print(@('Please enter wait interval between 64',
' byte bursts',crlf));
call readln;
delim=DQ$GET$ARGUMENT(@cmdstr,@status);
if check$error(0) then return;
cmdstr(cmdstr(0))=delim;
trans_wait=nin(.cmdstr(1));
call set$term$attr(false);
if trans then call print(@(cr,lf,'OK',crlf));
else call print(@('Transmit failed',crlf));
call set$term$attr(true);
end;
call file$close;
end;
end tran$cmd;
ambiguous: procedure EXTERNAL;
end ambiguous;
unsupported: procedure EXTERNAL;
end unsupported;
unknown: procedure(cmd$ptr) EXTERNAL;
declare cmd$ptr pointer;
end unknown;
do$cmd: procedure EXTERNAL;
end do$cmd;
do$para: procedure EXTERNAL;
end do$para;
get$baud: procedure EXTERNAL;
end get$baud;
get$duplex: procedure EXTERNAL;
end get$duplex;
output$baud: procedure EXTERNAL;
end output$baud;
baud$para: procedure PUBLIC;
if delim=cr then do;
baud_rate=0;
end;
else do;
delim=DQ$GET$ARGUMENT(@cmdstr,@status);
if check$error(0) then return;
call get$baud;
if cmd<=0 then return;
if in$conn=ci$conn then do;
call print(@('about to change consol baud rate to ',null));
call output$baud;
call print(@(', please confirm:',null));
if NOT query then return;
end;
end;
if baud_rate=0 then term$attr.in$baud$rate=old_baud_in;
else term$attr.in$baud$rate=baud_rate;
call RQ$S$SPECIAL(in$conn,5,@term$attr,@buffer,@status);
if check$error(1) then return;
end baud$para;
block$para: procedure PUBLIC;
call unsupported;
end block$para;
debug$para: procedure PUBLIC;
debug= NOT debug;
if debug then call print(@('DEBUG ON',crlf));
else call print(@('DEBUG OFF',crlf));
end debug$para;
delay$para: procedure PUBLIC;
if delim=cr then send$delay=5;
else do;
delim=DQ$GET$ARGUMENT(@cmdstr,@status);
if check$error(0) then return;
cmdstr(cmdstr(0))=delim;
send$delay=nin(.cmdstr(1));
end;
end delay$para;
dup$para: procedure PUBLIC;
if delim=cr then duplex=0;
else do;
delim=DQ$GET$ARGUMENT(@cmdstr,@status);
if check$error(0) then return;
call get$duplex;
end;
end dup$para;
esc$para: procedure PUBLIC;
call unsupported;
end esc$para;
file$para: procedure PUBLIC;
call unsupported;
end file$para;
flow$para: procedure PUBLIC;
call unsupported;
end flow$para;
hand$para: procedure PUBLIC;
call unsupported;
end hand$para;
ibm$para: procedure PUBLIC;
call unsupported;
end ibm$para;
inco$para: procedure PUBLIC;
call unsupported;
end inco$para;
par$para: procedure PUBLIC;
call unsupported;
end par$para;
port$para: procedure PUBLIC;
if delim=cr then call return$to$ci;
else do;
delim=DQ$GET$ARGUMENT(@cmdstr,@status);
if check$error(0) then return;
if cmdstr(0)<>4 or (CMPB(@cmdstr(1),@(':CI:'),4)<>-1
and CMPB(@cmdstr(1),@(':CO:'),4)<>-1) then do;
if in$conn <> ci$conn then call close$in;
in$conn=DQ$ATTACH(@cmdstr,@status);
if check$error(0) then return;
call DQ$OPEN(in$conn,3,0,@status);
if check$error(0) then return;
out$conn=in$conn;
call get$term$attr;
old_baud_in=term$attr.in$baud$rate;
if baud_rate <> 0 then do;
/* set new terminal to requested baud rate */
end;
call print(@('set connection via ',null));
call prints(@cmdstr);
call newline;
end;
else call return$to$ci;
end;
call get$term$attr;
end port$para;
recv$para: procedure PUBLIC;
call unsupported;
end recv$para;
retry$para: procedure PUBLIC;
call unsupported;
end retry$para;
send$para: procedure PUBLIC;
call unsupported;
end send$para;
/* *** main program *** */
outlen=0;
debug = false;
server$mode=false;
dev_attach=false;
qopen = false;
send$delay=5;
send$eol=cr; recv$eol=cr;
send$paclen=94; recv$paclen=94;
send$padchar=0; recv$padchar=0;
send$padding=0; recv$padding=0;
send$pause=1; recv$pause=1;
send$quote=23H; recv$quote=23H;
send$start=soh; recv$start=soh;
send$time=5; recv$time=5;
baud_rate=0; /* use system default */
block_check=1; /* simple check-sum */
duplex=0; /* 0=FULL, 1=HALF */
break_char=1DH; /* default ^] */
parity=4; /* parity code 0, set to 0 on output
ignore on input, but clear bit 7
1, set to 1 on output
ignore on input, but clear bit 7
2, even parity in and out
3, odd parity in and out
4, 8-bit...do not check or change bit 7 */
term$attr.num$words=5;
term$attr.num$used=5;
call spar(.send$setup$string);
call rpar(.send$setup$string);
call ioinit;
old_baud_ci=term$attr.in$baud$rate;
old_baud_in=0;
call print(@('RMX-86 Kermit Version 1.0',crlf));
do while (true);
call print(@('Kermit-RMX>',null));
call readln;
delim=DQ$GET$ARGUMENT(@cmdstr,@status);
if check$error(1) then call exit$cmd(3);
if cmdstr(0)>0 then call get$in$cmd;
end;
end kermit;