|
DataMuseum.dkPresents historical artifacts from the history of: RC3500 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC3500 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 46080 (0xb400)
Types: TextFileVerbose
Names: »comint1«
└─⟦a41ae585a⟧ Bits:30001842 SW-save af projekt 1000, Alarm-system
└─⟦72244f0ef⟧
└─⟦this⟧ »comint1«
process comint(
var comint_sem:semaphore;
var sys_vector:system_vector;
var formatter_sem:semaphore);
(*************************************************************************)
(* comint *)
(* *)
(* son_process of ncth *)
(* parameters: comint_sem = semaphore receiving inputbuffers from ncp. *)
(* sys_vector = only operator_sem is used by inchar. *)
(* formatter_sem = semaphore belonging to formatter. Recei- *)
(* ves outputbuffers from ncp and comint. *)
(* son_processes: none. *)
(* external functions: none. *)
(* waiting-points: at ?. *)
(* function: Interprets messages from operator, and fill out messages *)
(* to ncp. *)
(*************************************************************************)
const
maxint=32767;
ch_b_sz=256;
numbuf_sz = 256;
messform=13;
dataform=10;
var
chbuf : array(1..ch_b_sz) of char;
def_base : integer := 10;
\f
const
inbuf_error=0;
try_again=2;
ill_base_val = 25;
inbuf_init= operbuf_t(6+alfalength,97,0,"ncth ",?);
idbuf_sz = 50;
var
inbufp:integer:=0;
inbuf_ref:reference;
inbuf_sem:semaphore;
inbuf_pool:pool 1 of operbuf_t;
instr: databuft;
ch:char;
last_ch:integer;
idbuf : array ( 0..idbuf_sz - 1) of char;
idbufp : integer := 0;
procedure print(nr:integer); forward;
(************************************************************************)
(* *)
(* odd *)
(* function: true if nr is odd. *)
(************************************************************************)
function odd(val:integer):boolean;
begin
odd:=val mod 2 > 0 ;
end;
procedure reset_inchar;
begin
inbufp:=0;
end;
(*************************************************************************)
(* *)
(* inchar *)
(* *)
(* external parameters: *)
(* inbufp: if inbufp=0 then ready for new operatormessage *)
(* if =last_ch then reading last character in message *)
(* last_ch: last character to be read in current message *)
(* inbuf_ref,inbuf_sem,inbuf_pool: inbuf_zone. *)
(* ch: last read character. *)
(* internal parameters: *)
(* nobreak: false if an unintelligible message is received. *)
(* waiting-points: at line ?. *)
(* function : reading messages from operator character by character. *)
(* only used by lexan *)
(*************************************************************************)
procedure inchar;
var nobreak:boolean:=true;
begin
while inbufp = 0 do
begin
repeat
if inbufp > 0 then print(try_again);
signal(inbuf_ref,sys_vector(operatorsem)^);
wait(inbuf_ref,inbuf_sem);
inbufp:=succ(inbufp);
until ( inbuf_ref^.u2 = 0 ) or ( inbufp > 4 ) ;
if inbuf_ref^.u2<>0 then
begin
nobreak:=false;
ch:=esc;
print(inbuf_error);
end
else
lock inbuf_ref as inbuf:operbuf_t do
begin
last_ch:=inbuf.next-6-alfalength;
if last_ch <= 0 then inbufp:=0 else inbufp:=1;
instr := inbuf.databuf;
end;
end;
if nobreak then
begin
ch:=instr(inbufp);
inbufp:=succ(inbufp);
if inbufp>last_ch then inbufp:=0
end;
end; (* of inchar *)
(**********************************************************************)
(* *)
(* lexan *)
(* *)
(* external parameters: *)
(* l_st_tab: state-table. *)
(* l_act_tab: action-table. *)
(* chtab: character-grouping-table *)
(* l_att1 - l_att3: containing attr. of detected lex.-sym. *)
(* chbuf: acts as characterstringbuffer. Also used at iden- *)
(* tifierrecognition. *)
(* chbufp: points at first not-used position in charbuf. *)
(* def_base: default_base. Normally 10. *)
(* no_new_char: Set true if current ch-val is to be re-used. *)
(* internal parameters: *)
(* oldst,newst: controlling statemashine. *)
(* errnr: >0 if an error has occured. *)
(* base: = def_base initially, but may be altered if spec. *)
(* chgr: the charactergroup determined by chtab. *)
(* action: the action to be taken upon state_change. *)
(* *)
(* call of other procedures: *)
(* print,inchar,accnum,accstr *)
(* waitingpoints: *)
(* via inchar line ? and print line ?. *)
(* function: *)
(* detecting lexical symbols in operatormessages. possible *)
(* symbols defined by lexsym line ?. *)
(* *)
(**********************************************************************)
type
lexsym=(notused,eq,id,str,num,d_amp,s_amp,star,comma,colon,semicolon,?,errsym,break);
l_r_t=packed array(1..10) of 0..15;
l_t_type=array(0..8) of l_r_t;
ch_tab_type=packed array(0..127) of 1..15;
const
a=10; b=11; c=12; d=13;
l_st_tab=l_t_type(
(*0:*)l_r_t(3,1,4,4,1,2,5,6,8,9),
(*1:*)l_r_t(1,1,1,1,1,2,9,9,9,9),
(*2:*)l_r_t(2,2,2,2,2,2,9,9,9,9),
(*3:*)l_r_t(3,3,3,2,2,2,9,9,9,9),
(*4:*)l_r_t(1,1,1,1,1,2,5,9,9,9),
(*5:*)l_r_t(5,5,5,9,9,9,9,9,9,9),
(*6:*)l_r_t(6,6,6,6,6,6,6,7,6,6),
(*7:*)l_r_t(9,9,9,9,9,9,9,6,9,9),
(*8:*)l_r_t(9,9,9,9,9,9,9,9,9,9));
l_act_tab=l_t_type(
(*0:*)l_r_t(1,2,3,3,2,2,0,0,0,4),
(*1:*)l_r_t(2,2,2,2,2,2,6,6,7,7),
(*2:*)l_r_t(2,2,2,2,2,2,6,6,8,8),
(*3:*)l_r_t(1,1,1,2,2,2,6,6,9,9),
(*4:*)l_r_t(2,2,2,2,2,2,0,6,7,7),
(*5:*)l_r_t(a,a,a,6,6,6,6,6,9,9),
(*6:*)l_r_t(2,2,2,2,2,2,2,0,2,2),
(*7:*)l_r_t(6,6,6,6,6,6,6,2,b,b),
(*8:*)l_r_t(c,c,c,c,c,c,c,c,d,c));
ch_tab= ch_tab_type(
(* 0..9 *)12,12,12,12,12,12,12,12,12,12,
(*10..19*)11,12,11,11,12,12,12,12,12,12,
(*20..29*)12,12,12,12,12,12,12,13,12,12,
(*30..39*)12,12,10,12, 8, 6, 6, 6, 9, 7,
(*40..49*)12,12,10, 6,10,10,12,12, 1, 1,
(*50..59*) 1, 1, 1, 1, 1, 1, 1, 1,10,10,
(*60..69*)13,10,12,12, 6, 2, 3, 2, 3, 2,
(*70..79*) 2, 5, 4, 5, 5, 5, 5, 5, 5, 4,
(*80..89*) 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
(*90..99*) 5, 5, 5, 5, 6, 6,12, 2, 3, 2,
(*00..09*) 3, 2, 2, 5, 4, 5, 5, 5, 5, 5,
(*10..19*) 5, 4, 5, 5, 5, 5, 5, 5, 5, 5,
(*20..27*) 5, 5, 5, 5, 5, 5,12,12 );
var
l_att1,l_att2,l_att3:integer;
chbufp:integer:=1;
no_new_char:boolean:=false;
procedure reset_lexan;
begin
reset_inchar;
no_new_char:=false;
end;
function lexan:lexsym;
const
miss_sep=1;
ill_digit=3;
ill_char=4;
numb_ofl=5;
chbuf_ofl=6;
var
oldst:integer;
newst:integer:=0;
errnr:integer:=0;
base :integer;
chgr :integer;
action:integer;
i : integer;
procedure accstr;
begin
if chbufp + l_att3 <= ch_b_sz then
chbuf(chbufp+l_att3):=ch
else errnr:=chbuf_ofl;
l_att3:=l_att3+1;
end; (* of accstr *)
procedure accnum;
var val:integer;
begin
case ch of
"0".."9":val:=ord(ch)-48;
"A".."F":val:=ord(ch)-55;
"a".."f":val:=ord(ch)-87
otherwise errnr:=9
end;
if val < base then
if maxint div base >= l_att1 then
l_att1:=l_att1 * base + val
else errnr:=numb_ofl
else errnr:=ill_digit;
end; (* of accnum *)
begin (* body of lexan *)
l_att1:=0; l_att2:=chbufp; l_att3:=0; base:= def_base;
while newst < 9 do
begin
oldst:=newst;
if no_new_char then no_new_char:=false
else inchar;
chgr:=ch_tab(ord(ch));
case chgr of
1..10:
begin
newst:=l_st_tab(oldst,chgr);
action:= l_act_tab(oldst,chgr);
end;
11:action:=0;
12:if oldst=6 then action:=2
else action:=5;
13:
begin
newst:=9;
action:=0;
lexan:=break;
end
otherwise errnr:=8
end;
(********** lexan - actions *****************************)
case action of
0: (* no actions *);
1:
begin
accnum;
accstr;
if errnr > 0 then
begin
newst:=2;
errnr:=0;
end;
end;
2:accstr;
3:
begin
accstr;
case ch of
"B","b":base:=2;
"D","d":base:=10;
"H","h":base:=16;
"O","o":base:=8;
otherwise errnr:=7
end;
end;
4:
case ch of
sp,"-": newst:=0; (* skip blanks and hyphens *)
"=":lexan:=eq;
"*":lexan:=star;
",":lexan:=comma;
":":lexan:=colon;
";":lexan:=semicolon;
otherwise errnr:=8
end;
5:errnr:=ill_char;
6:errnr:=miss_sep;
7:
begin
l_att2 := idbufp;
lexan:=id;
no_new_char:=true;
for i := 0 to l_att3 -1 do
begin
if chbuf(chbufp+i) in (.'A'..']'.) then
idbuf(idbufp) := chr(ord(chbuf(chbufp+i))+32)
else
idbuf(idbufp) := chbuf(chbufp+i);
idbufp := (idbufp+1) mod idbuf_sz;
end;
end;
8,b:
begin
if action = 8 then l_att1:=2 (* ord(symbn_t) *)
else l_att1:=3; (* ord(txtt) *)
lexan:=str;
chbufp:=chbufp+l_att3;
no_new_char:=true;
end;
9:
begin
lexan:=num;
no_new_char:=true;
end;
a:accnum;
c:
begin
lexan:=s_amp;
no_new_char:=true;
end;
d:lexan:=d_amp;
otherwise errnr:=9
end; (* of lexan actions *)
if errnr > 0 then
begin
newst:=9;
print(errnr);
lexan:=errsym;
end;
end; (* of while *)
end; (* of lexan *)
\f
(************************************************************************)
(* syntan *)
(* *)
(* external parameters: *)
(* sactt,sactte: action-table + entry *)
(* sstt, sstte: state-table + entry. *)
(* snstt,snsttte: reduction-table + entry. *)
(* ststack: statestack containing LR-parser-prefixes. *)
(* atstack: attribute_stack. *)
(* top: current top of stack *)
(* state: current state of syntax-analyzer. *)
(* symb: current lexical symbol. *)
(* nrbufp: next free position in nrbuf ( see seman ) *)
(* sess_lev: current session/subsession-level calling syntan. *)
(* internal parameters: *)
(* entry: used at tablelookup. *)
(* rednr: used at reductionactions *)
(* action: contains action after tablelookup. *)
(* syntsym: contains rednr after reduction-action. *)
(* *)
(* call of other procedures: *)
(* lexan,reset_lexan,print. *)
(* waitingpoints: *)
(* via lexan: lines *)
(* via print: lines *)
(* function: *)
(* detecting syntactically reducable objects, delivering the- *)
(* se reductions to seman. Administrates syntactical and se- *)
(* mantical stack. *)
(* *)
(************************************************************************)
type (* used by syntan and successors *)
q=packed record
symb: 1..11;
nact:0..6
end;
sacttt=packed array(1..37) of q;
sacttet=packed array(0..25) of 1..37;
r=packed record
symb:1..11;
nst:0..27
end;
ssttt=packed array(1..58) of r;
ssttet=packed array(0..25) of 0..58;
s=packed record
rednr:1..20;
nst:0..27
end;
snsttt= array(1..45) of s;
snsttet=packed array(0..25) of 1..40;
redstt= packed array(1..20) of 1..2;
atst_t=record
att1,att2,att3,att4:integer;
end;
const
sactt=sacttt(
(*0:*) q(11,3),q(2,1),q(5,3),q(7,1),q(8,0),
(*1:*) q(11,4),q(2,4),
(*2:*) q(11,3),q(2,4),
(*3,4:as 2*)
(*5:*) q(11,3),q(2,1),q(5,2),q(6,4),
(*6: as 2*)
(*7:*) q(11,3),q(2,4),q(6,2),q(7,4),
(*8:*) q(11,3),q(2,1),q(5,3),
(*9:*) q(11,3),q(8,4),
(*10,11: as 9*)
(*12:*)q(11,3),q(8,2),q(9,4),
(*13:*)q(11,3),q(9,2),q(10,4),
(*14:*)q(11,5),
(*15:*)q(11,2),
(*16: as 2*)(*17,18: as 8*)(*19: as 7*) (*20,21: as 0*)
(*22:*)q(11,3),q(2,1),q(5,3),q(6,4),
(*23:*)q(11,3),q(6,4),q(11,6)
(*24: as 12*) (*25: as 9*) );
sactte=sacttet(1,6,3***8,10,8,14,1,3***21,23,26,29,30,8,18,18,14,1,1,31,35,23,21);
sstt=ssttt(
(*0:*) r(11,1),r(3,3),r(4,2),r(7,9),r(8,10),
(*1:*) r(11,10),r(2,2),
(*2:*) r(11,1),
(*3:*) r(11,1),r(2,3),
(*4:*) r(11,1),r(2,5),
(*5:*) r(11,1),r(3,3),r(4,2),r(5,17),r(6,7),
(*6:*) r(11,1),r(2,9),
(*7:*) r(11,1),r(2,12),r(6,18),r(7,12),
(*8:*) r(11,1),r(3,3),r(4,2),
(*9:*) r(11,3),r(8,13),
(*10:*)r(11,3),r(8,14),
(*11:*)r(11,3),r(8,16),
(*12:*)r(11,0),r(8,20),r(9,18),
(*13:*)r(11,0),r(9,21),r(10,19),
(*14: as 2*)
(*15:*)r(11,8),r(2,10),
(*16:*)r(11,1),r(2,4),
(*17,18: as 8*)
(*19:*)r(11,1),r(2,11),r(6,18),r(7,11),
(*20,21: as 0*)
(*22:*)r(11,1),r(3,3),r(4,2),r(6,6),
(*23:*)r(11,0),r(6,8),
(*24:*)r(11,0),r(8,20),r(9,17),
(*25:*)r(11,0),r(8,15),r(11,27));
sstte=ssttet(1,6,8,9,11,13,18,20,1,27,29,31,33,36,8,39,41,24,24,43,1,1,47,51,53,56);
snstt=snsttt(
(*0:*) s(20,4),s(4,5),s(6,6),s(8,7),s(10,15),s(11,11),s(13,7),
(*0:*) s(15,12),s(17,13),s(19,14),
(*1:*) s(20,27),
(*2..4: as 1*)
(*5:*) s(20,16),s(4,27),
(*6,7: as 1*)
(*8:*) s(20,4),s(4,5),s(6,6),s(8,19),s(10,27),s(13,19),s(15,27),
(*9..16: as 1*)
(*17:*)s(20,4),s(4,22),s(6,27),
(*18:*)s(20,4),s(4,5),s(6,23),s(8,27),
(*19: as 1*)
(*20:*)s(20,4),s(4,5),s(6,6),s(8,7),s(10,15),s(11,25),s(13,7),s(15,27),
(*21:*)s(20,4),s(4,5),s(6,6),s(8,7),s(10,15),s(11,11),s(13,7),s(15,24),s(17,27),s(20,27)
(*22: as 5*)(*23..25: as 1*));
snstte=snsttet(1,4***11,12,11,11,14,8***11,21,24,11,28,36,12,3***11);
redst=redstt(1,1,1,2,1,2,1,2,1,1,2,1,1,1,2,1,2,1,1,1);
var
ststack:array(1..9) of integer;
atstack:array(0..8) of atst_t;
top:integer:=0;
state:integer;
symb:integer:=11;
nrbufp:integer:=1;
sess_lev:integer:=1;
procedure reset_syntan;
begin
symb:=11;
end;
function syntan:integer;
const
noatt=0;
stack=1;
skipstack=2;
synt_error=3;
reduce=4;
accept=5;
det_synt_err = 14;
var
entry:integer;
rednr:integer;
action:integer;
syntsym:integer;
begin
syntsym:=0;
while syntsym = 0 do
case symb of
1..10:
begin
entry:=sactte(state);
repeat entry:=succ(entry) until sactt(entry).symb>symb;
action:=sactt(entry-1).nact;
entry:=sstte(state);
repeat entry:=succ(entry) until sstt(entry).symb>symb;
state:=sstt(entry-1).nst;
case action of
noatt:
begin
top:=succ(top);
ststack(top):=state;
atstack(top):=atst_t(0,0,0,1);
end;
stack:
begin
top:=succ(top);
ststack(top):=state;
with atstack(top) do
begin
att1:=l_att1;
att2:=l_att2;
att3:=l_att3;
att4:=1;
end;
symb:=ord(lexan);
end;
skipstack:
begin
ststack(top):=state;
symb:=ord(lexan)
end;
synt_error:
begin
symb:=12;
print(state+10);
end;
reduce:
begin
rednr:=state;
top:=top-redst(rednr);
if top=0 then state:=0
else state:=ststack(top);
entry:=snstte(state);
repeat entry:=succ(entry) until snstt(entry).rednr>rednr;
state:=snstt(entry-1).nst;
top:=top+1;
ststack(top):=state;
if state > 25 then
begin
print(det_synt_err);
symb:=12;
end
else
syntsym:=rednr;
end;
accept:
symb:=11;
otherwise
begin
print(17);
symb:=11;
syntsym:=21
end
end; (*of action-case*)
end; (*of characters 1..10*)
11:
begin
(* reset syntan *)
reset_lexan;
state:=0;
top:=0;
print(sess_lev+50);
symb:=ord(lexan);
end;
12:
begin
symb:=11;
syntsym:=21;
end;
13: (* escape character detected *)
syntsym:=22
otherwise
begin
symb:=11;
print(18);
syntsym:=21;
end
end;(* of symb case and while_loop *)
syntan:=syntsym;
end; (* of syntan *)
\f
const
m_nr_id=18;
c_str_b_sz=100;
int_functerror=50;;
type
types = (bytet,wrdt,symbn_t,txtt,cmdt);
type_set = set of types;
typearr=packed array(0..4) of types;
(* internal identifier-representation may only contain small letters *)
(* and ciffers *)
id_desc_t=packed record
id_ref,
id_len,
id_nr:byte
end;
id_desc_l_t=packed array(1..m_nr_id) of id_desc_t;
p_desc_t=packed record
p_lform:boolean;
(* p_lform:=(cardinality of p_type_sp > 1) and (m_nr_arg >1) *)
p_type_sp:type_set;
p_nr_arg_sp:byte;
p_nr_obj_sp:byte
end;
p_desc_l_t=packed array(1..m_nr_id) of p_desc_t;
p_l_e_t=packed record
p_type,
p_ref,
p_mult,
p_cnt:integer
end;
parm_l_t=array(1..m_nr_id) of p_l_e_t;
c_l_e_t=packed record
c_type:types;
c_ref,
c_cnt:byte;
end;
const_l_t=packed array(1..m_nr_id) of c_l_e_t;
semenv_t=record
nr_parm,nr_const:byte;
parm_desc:p_desc_l_t;
p_name_l: id_desc_l_t;
c_name_l: id_desc_l_t;
const_l: const_l_t;
c_str_b:array(1..c_str_b_sz) of char;
end;
const
objtype=typearr(bytet,wrdt,symbn_t,txtt,cmdt);
p_l_e_init = p_l_e_t(0,0,0,0);
noop = 0;
terminator = 1;
error = 2;
escape = 3;
var
ncp_mess_ref : reference;
hook_ref : reference;
function getbyte(adr:integer) : byte;
forward;
function getwrd(adr: integer) : integer;
forward;
procedure outmess(txt:txt_type; len,msgnr:byte);
forward;
procedure movebytes(parm:p_l_e_t; var buf:sp_data_type; var messbufp:integer);
forward;
procedure send_term_data(format,oper:byte);
forward;
procedure init_level;
forward;
procedure reset_level;
forward;
function seman( seman_env:semenv_t; var parm_l:parm_l_t) : byte;
forward;
\f
type
bytebt = array(1..numbuf_sz) of byte;
wrdbt = array(0..numbuf_sz div 2 - 1 ) of integer;
const
term_mess_init=sp_head_type(?, <*rec_id not used by comint *>
0, <*sender-id do. *>
?, <*seq-no*>
0, <*sp_type*>
0, <*lcp_oper*>
0, <*status*>
?, <*time*>
0 <*bytecount*>);
nr_term_mess_buf=2;
var
mask:mask_type:=def_opt_mask;
help:reference;
term_mess_ref:reference;
term_mess_sem:semaphore;
term_mess_h_pool:pool nr_term_mess_buf;
term_mess_pool: pool nr_term_mess_buf of ts_data_type;
term_messbufp:integer:=1;
var
nrbufpool:pool 1 of bytebt;
nrbufr:reference;
nrbufsem:semaphore;
function getbyte(adr:integer):byte;
begin
if adr in (.1..nrbufp+1.) then
lock nrbufr as nrbuf:bytebt do
getbyte:=nrbuf(adr)
else getbyte:=0;
end;
function getwrd(adr:integer):integer;
begin
if adr in (.1..nrbufp+1.) then
if odd(adr) then
lock nrbufr as nrbuf:wrdbt do
getwrd:=nrbuf(adr div 2 )
else
print(int_functerror)
else getwrd:=0;
end;
function seman:byte;
const
int_semerror=20;
byte_confl=1;
intg_ill=2;
numb_b_ofl=3;
strt_ill=4;
ch_b_ofl=-14;
cmdt_ill=6;
unk_id=7;
too_many_obj=8;
diff_obj_t_ill=9;
ill_mult_v=10;
ill_mult_arg=11;
too_many_arg=12;
unk_parm=13;
too_many_parm=14;
int_type_error=19;
var
curr_parm:integer:=1;
endm:boolean:=false;
i,j:integer;
all_parm_spec:boolean:=false;
procedure semerror(errnr:integer);
begin
print(errnr+20);
reset_syntan;
endm:=true;
seman:=error;
end;
function savebyte(val:integer):integer;
begin
if nrbufp < numbuf_sz then
lock nrbufr as nrbuf:bytebt do
begin
nrbuf(nrbufp):=val;
savebyte:=nrbufp;
nrbufp:=succ(nrbufp);
end
else semerror(numb_b_ofl);
end;
function savewrd(val:integer):integer;
begin
if nrbufp < numbuf_sz then
lock nrbufr as nrbuf:wrdbt do
begin
if not odd(nrbufp) then nrbufp:=succ(nrbufp);
nrbuf(nrbufp div 2 ) :=val;
savewrd:=nrbufp;
nrbufp:=nrbufp+2
end
else semerror(numb_b_ofl);
end;
function lookup(
ref,len: byte;
id_l:id_desc_l_t;
nr_id:byte):integer;
var
i,j:integer;
ch,id_ch:char;
label end_loop1,out;
begin
lookup:=0;
with seman_env do
for i:=1 to nr_id do
with id_l(i) do
if len = id_len then
begin
for j:=0 to len-1 do
begin
ch := idbuf((ref + j ) mod idbuf_sz);
id_ch:=c_str_b(j+id_ref);
if id_ch <> ch then
if id_ch > ch then goto out
else goto end_loop1;
end;
lookup:=id_nr; goto out;
end_loop1:
end;
out:
end; (* of lookup *)
begin (***************** body of seman *******************)
seman:=noop;
with seman_env do
while not endm do
begin
i:=syntan;
if all_parm_spec and ( i in (. 0..9, 12..14 .) ) then semerror(too_many_parm)
else
with parm_desc(curr_parm),atstack(top) do
case i of
(*-------------------------------------*)
(* obj ::= nr *)
(*-------------------------------------*)
1:
if ( att1 in (.0..255.) ) and ( bytet in p_type_sp ) then
begin
att2:=savebyte(att1);
att1:= ord( bytet );
end
else
if wrdt in p_type_sp then
begin
att2:=savewrd(att1);
att1:= ord(wrdt);
end
else semerror(byte_confl);
(*-------------------------------------*)
(* obj ::= id *)
(*-------------------------------------*)
2:
begin
i:=lookup(att2,att3,c_name_l,nr_const);
if i > 0 then
with const_l(i) do
case c_type of
bytet:
if bytet in p_type_sp then
begin
att2:=savebyte(c_ref);
att1:=ord(bytet)
end
else
if wrdt in p_type_sp then
begin
att2:=savewrd(c_ref);
att1:=ord(wrdt)
end
else semerror(intg_ill);
wrdt:
if wrdt in p_type_sp then
begin
att2:=savewrd(c_ref);
att1:=ord(wrdt);
end
else semerror(intg_ill);
txtt,symbn_t:
if c_type in p_type_sp then
if chbufp+c_cnt<256 then
begin
att2:=chbufp;
for j:=c_ref to c_cnt do
begin
chbuf(chbufp):=c_str_b(j);
chbufp:=succ(chbufp);
end;
att1:=ord(c_type);
att3:=0;
att4:=c_cnt
end
else semerror(ch_b_ofl)
else semerror(strt_ill);
cmdt:
if cmdt in p_type_sp then
begin
att1:=ord(cmdt);
(* att2:=savebyte (c_ref); *)
seman:=c_ref
end
else semerror(cmdt_ill)
otherwise semerror(int_type_error);
end (* of const case *)
else semerror(unk_id)
end;
(*-------------------------------------*)
(* obj ::= symb_n ! txt *)
(*-------------------------------------*)
3:
if objtype(att1) in p_type_sp then
att4:=att3
else semerror(strt_ill);
(*-------------------------------------*)
(* arg ::= arg - obj *)
(*-------------------------------------*)
4:
if att1 = atstack(top+1).att1 then
begin
att4:=att4+atstack(top+1).att4;
if (att4 > p_nr_obj_sp) and (p_nr_obj_sp > 0) then
semerror(too_many_obj);
end
else semerror(diff_obj_t_ill);
(*-------------------------------------*)
(* arg ::= obj *)
(*-------------------------------------*)
5: att3:=1;
6:
(*-------------------------------------*)
(* sub_val ::= arg && arg *)
(*-------------------------------------*)
with atstack(top+1) do
if (att1 in (.ord(bytet)..ord(wrdt).)) and (att4=1) then
begin
j:=getbyte(att2);
if j > 0 then
if (atstack(top).att4 * j <= p_nr_obj_sp) or (p_nr_obj_sp = 0) then
atstack(top).att3:=j
else semerror(too_many_obj)
else semerror(ill_mult_v)
end
else semerror(ill_mult_arg);
(*-------------------------------------*)
(* sub_val ::= arg *)
(*-------------------------------------*)
7: (* no actions *);
(*-------------------------------------*)
(* val ::= val & subval *)
(*-------------------------------------*)
8:
if (att4 < p_nr_arg_sp) or (p_nr_arg_sp=0) then
if p_lform then
begin
with atstack(top+1) do
begin
att1:=savebyte(att1);
att2:=savebyte(att2);
att3:=savebyte(att3);
att4:=savebyte(att4);
att3:=savebyte(0);
end;
lock nrbufr as nrbuf:bytebt do
nrbuf(att3):=atstack(top+1).att1;
att3:=atstack(top+1).att3;
att4:=att4+1;
end
else att4:=att4+1
else semerror(too_many_arg);
(*-------------------------------------*)
(* val ::= subval *)
(*-------------------------------------*)
9:
if p_lform then
begin
att1:=savebyte(att1);
att2:=savebyte(att2);
att3:=savebyte(att3);
att4:=savebyte(att4);
att2:=att1;
att1:=-1;
att3:=savebyte(0);
att4:=1;
end;
(*-------------------------------------*)
(* parm_id ::= id *)
(*-------------------------------------*)
10:
begin
j:=lookup(att2,att3,p_name_l,nr_parm);
if j > 0 then
begin
curr_parm:=j;
all_parm_spec:=false;
end
else semerror(unk_parm);
end;
(*-------------------------------------*)
(* parm ::= parm_id = val *)
(*-------------------------------------*)
11:
with atstack(top+1),parm_l(curr_parm) do
begin
p_type:=att1;
p_ref:=att2;
p_mult:=att3;
p_cnt:=att4;
end;
(*-------------------------------------*)
(* parm ::= val *)
(*-------------------------------------*)
12:
if ( att2 > 0 ) then
with parm_l(curr_parm) do
begin
p_type:=att1;
p_ref:=att2;
p_mult:=att3;
p_cnt:=att4;
end;
(*-------------------------------------*)
(* val ::= * *)
(*-------------------------------------*)
13:
begin
if nil(term_mess_ref) then
wait(term_mess_ref,term_mess_sem);
lock term_mess_ref as term_mess:ts_data_type do
movebytes(parm_l(curr_parm),term_mess.sp_data,term_messbufp);
send_term_data(dataform,0);
att2:=0;
end;
(*-------------------------------------*)
(* val ::= empty *)
(*-------------------------------------*)
14: (* no actions *);
(*-------------------------------------*)
(* block ::= block , parm *)
(* block ::= parm *)
(*-------------------------------------*)
15,16:
begin
curr_parm:=succ(curr_parm);
if curr_parm > nr_parm
then
begin
curr_parm:=nr_parm;
all_parm_spec:=true;
end;
end;
17,18:
(*-------------------------------------*)
(* sub_com ::= subcom : block *)
(* sub_com ::= block *)
(*-------------------------------------*)
endm:=true;
(*-------------------------------------*)
(* com ::= subcom ; *)
(*-------------------------------------*)
19:
begin
endm:=true;
seman:=terminator; (* a ';' detected in input *)
end;
21: (* error *)
begin
endm:=true;
seman:=error;
end;
22: (* escape *)
begin
endm:=true;
seman:=escape;
end
otherwise semerror(int_semerror);
end; (* of semantic reductions *)
end; (* of while loop *)
end; (* of seman *)
procedure reset_system;
begin
reset_syntan;
nrbufp:=1; chbufp:=1;
end;
type
err_mess_tab_type=array(0..24) of txt_type;
const
err_mess_tab=err_mess_tab_type(
"internal error ",
"missing separator ",
"timeout ",
"illegal digit ",
"illegal character ",
"number overflow ",
"char-buffer overflow",
"= only after parm-id",
"missing object ",
"missing param-sep ",
"syntaxerror detected",
"byte-word conflict ",
"integer-type illegal",
"number-buf overflow ",
"string-type illegal ",
"illegal base value ",
"command_type illegal",
"unknown constant ",
"too many objects ",
"diff obj-types illeg",
"illegal subval_arg 2",
"illegal subval_arg 1",
"too many arguments ",
"unknown parameter-id",
"too many param-spec ");
procedure outmess;
var i:integer;
begin
if nil(term_mess_ref) then
wait(term_mess_ref,term_mess_sem);
term_mess_ref^.u1 := messform;
lock term_mess_ref as term_mess:comint_mess_t do
with term_mess,sp_head,comint_data do
begin
message:=txt;
mess_l:=len;
messnr := msgnr;
lcp_oper :=0;
c_mask := mask ;
c_defbase := def_base;
position :=0;
bytecount := 0;
end;
signal(term_mess_ref,formatter_sem);
end; (* of outtext*)
procedure print(nr:integer);
begin
case nr of
0..6:outmess(err_mess_tab(nr),txt_len,nr);
11..14:outmess(err_mess_tab(nr-4),txt_len,nr);
21..34:outmess(err_mess_tab(nr-10),txt_len,nr);
51:outmess("< ",1,nr);
52:outmess("? ",1,nr)
otherwise outmess(err_mess_tab(0),txt_len,nr);
end; (*of mess_selection*)
end; (*of print*)
procedure movebytes( parm:p_l_e_t;var buf:sp_data_type;var messbufp:integer);
var
i,j,
typ,ref,mult,count,link:integer;
begin
with parm do
begin
link:=p_ref;
while link > 0 do
begin
if p_type < 0 then
begin
typ:=getbyte(link);
ref:=getbyte(link+1);
mult:=getbyte(link+2);
count:=getbyte(link+3);
link:=getbyte(link+4);
end
else
begin
typ:=p_type;
ref:=p_ref;
mult:=p_mult;
count:=p_cnt;
link:=0;
end;
for i:=0 to mult - 1 do
for j:=0 to count - 1 do
begin
case objtype(typ) of
bytet,cmdt:buf(messbufp):=getbyte(ref+j);
wrdt:
begin
buf(messbufp):=getbyte(ref+j*2);
messbufp:=messbufp+1;
buf(messbufp):=getbyte(ref+j*2+1);
end;
symbn_t,txtt:buf(messbufp):=ord(chbuf(ref+j))
otherwise (* no actions yet *);
end;
if (typ<>1) and (messbufp<sp_data_sz) or (messbufp<sp_data_sz-1) then
messbufp:=succ(messbufp);
end;
end;
end;
end; (* of movebytes *)
procedure send_term_data(format,oper:byte);
begin
if nil(term_mess_ref) then
wait(term_mess_ref,term_mess_sem);
term_mess_ref^.u1:=format ; (* ordinary printoutformat *)
if format = messform then
lock term_mess_ref as term_mess:comint_mess_t do
with term_mess,sp_head,comint_data do
begin
sp_type:=64;
lcp_oper:=oper;
messnr:=255;
mess_l:=0;
c_mask:=mask;
c_defbase:=def_base;
position:=inbufp-1;
bytecount:=term_messbufp - 1;
end
else
lock term_mess_ref as term_mess: ts_data_type do
term_mess.sp_head.bytecount:=term_messbufp-1;
signal(term_mess_ref,formatter_sem);
term_messbufp:=1
end; (* of send_term_mess*)
var
sub_sess_nrbufp,
sub_sess_chbufp:integer;
procedure init_level;
begin
sub_sess_nrbufp:=nrbufp;
sub_sess_chbufp:=chbufp;
sess_lev:=sess_lev+1;
end; (* of init_level*)
procedure reset_level;
begin
nrbufp:=sub_sess_nrbufp;
chbufp:=sub_sess_chbufp;
sess_lev:=sess_lev-1;
end; (* of reset_level*)
\f
procedure session;
const
sendm = 4;
form = 5;
rout = 6;
lic = 7;
startrep=32;
stoprep =48;
ncp = 8;
dce = 9;
sess_env=semenv_t(
10,8,
p_desc_l_t(
p_desc_t(false,(.cmdt.),1,1), <* oper *>
4***p_desc_t(false,(.wrdt.),3,1),
4***p_desc_t(true,(.bytet,wrdt,txtt,symbn_t.),0,0),
p_desc_t(false,(.bytet.),1,1), <* defbase *>
(m_nr_id-10)***p_desc_t(?,?,?,?)), <* unused *>
id_desc_l_t(
id_desc_t(13,2,6), <* d1 *>
id_desc_t(15,2,7), <* d2 *>
id_desc_t(17,2,8), <* d3 *>
id_desc_t(19,2,9), <* d4 *>
id_desc_t(21,7,10), <*defbase*>
id_desc_t( 5,2,2), <* h1 *>
id_desc_t( 7,2,3), <* h2 *>
id_desc_t( 9,2,4), <* h3 *>
id_desc_t(11,2,5), <* h4 *>
id_desc_t( 1,4,1), <* oper *>
(m_nr_id-10)***id_desc_t(?,?,?)), <* unused *>
id_desc_l_t(
id_desc_t(62,3,8), <* dce *>
id_desc_t(33,4,2), <* form *>
id_desc_t(41,3,4), <* lic *>
id_desc_t(59,3,5), <* ncp *>
id_desc_t(37,4,3), <* rout *>
id_desc_t(28,5,1), <* sendm *>
id_desc_t(44,8,6), <* startrep *>
id_desc_t(52,7,7), <* stoprep *>
(m_nr_id-8)***id_desc_t(?,?,?) <* unused *> ),
const_l_t(
c_l_e_t(cmdt,sendm,?), <* sendm *>
c_l_e_t(cmdt,form,?), <* form *>
c_l_e_t(cmdt,rout,?), <* rout *>
c_l_e_t(cmdt,lic,?), <* lic *>
c_l_e_t(cmdt,ncp,? ), <* ncp *>
c_l_e_t(bytet,startrep,?), <* startrep *>
c_l_e_t(bytet,stoprep,?), <* stoprep *>
c_l_e_t(cmdt,dce,?), <* dce *>
(m_nr_id-8)***c_l_e_t(?,?,?) <* unused *> ),
"operh1h2h3h4d1d2d3d4defbasesendmformroutlicstartrepstoprepncpdce");
var
sess_parm_l:parm_l_t;
endm:boolean:=false;
mess_seq_no:integer:=0;
i,j:integer;
\f
procedure sendmess;
const
sendm_env=semenv_t(
6,2,
p_desc_l_t(
2***p_desc_t(false,(.bytet.),1,1),
p_desc_t(false,(.wrdt.),1,1),
2***p_desc_t(false,(.bytet.),1,1), <*sptype,lcpoper*>
p_desc_t(true,(.bytet,wrdt,txtt,symbn_t.),0,0), <* chmess *>
(m_nr_id-6)***p_desc_t(?,?,?,?) <* unused *> ),
id_desc_l_t(
id_desc_t(23,6,6), <* chdata *>
id_desc_t(16,6,2), <* datano *>
id_desc_t(37,6,1), <* headno *>
id_desc_t( 8,7,5), <* lcpoper *>
id_desc_t(30,6,3), <* reclcp *>
id_desc_t( 1,6,4), <* sptype *>
(m_nr_id-6)*** id_desc_t(?,?,?) <* unused *> ),
id_desc_l_t(
id_desc_t(44,8,1), <* startrep *>
id_desc_t(53,7,2), <* stoprep *>
(m_nr_id-2)*** id_desc_t(?,?,?) <* unused *> ),
const_l_t(
c_l_e_t(bytet,startrep,?),
c_l_e_t(bytet,stoprep,?),
(m_nr_id-2)***c_l_e_t (?,?,?) ),
"sptype lcpoper datano chdata reclcp headno startrep stoprep "); <* end of sendm_env*>
var
sendm_parm_l:parm_l_t;
endm:boolean:=false;
i,j:integer;
messbufp:integer;
begin (* body of sendm *)
init_level;
for i:=1 to sendm_env.nr_parm do
sendm_parm_l(i):=p_l_e_init;
while not endm do
case seman(sendm_env,sendm_parm_l) of
noop: (* no actions *) ;
terminator:
begin
sensesem(ncp_mess_ref,comint_sem);
if not nil(ncp_mess_ref) then
begin
pop(hook_ref,ncp_mess_ref);
lock ncp_mess_ref as ncp_mess:ts_data_type do
with ncp_mess,sp_head do
begin
i:=getbyte(sendm_parm_l(1).p_ref);
if not ( i in (.1..4.)) then i:=1;
with sess_parm_l(i+1) do
begin
if p_cnt > 0 then receiver_id:=getwrd(p_ref) else receiver_id:=1;
if p_cnt > 1 then j:=getwrd(p_ref+2) else j:=0;
sp_type := j mod 256;
if p_cnt > 2 then j:=getwrd(p_ref+4) else j:=0;
lcp_oper := j mod 256;
status:=0;
seq_no:=mess_seq_no;
mess_seq_no:=succ(mess_seq_no) mod 256;
end;
with sendm_parm_l(3) do
if p_ref > 0 then receiver_id:=getwrd(p_ref);
with sendm_parm_l(4) do
if p_ref > 0 then sp_type := getbyte(p_ref) mod 256;
with sendm_parm_l(5) do
if p_ref > 0 then lcp_oper:=getbyte(p_ref);
sender_id:=32766;
messbufp:=1;
i:=getbyte(sendm_parm_l(2).p_ref);
if i in (. 1..4 .) then
movebytes(sess_parm_l(i+5),sp_data,messbufp);
movebytes(sendm_parm_l(6),sp_data,messbufp);
bytecount:=messbufp-1;
end; (* of mess construct *)
push(hook_ref,ncp_mess_ref);
ncp_mess_ref^.u2:=0;
return(ncp_mess_ref);
outmess("message submitted. ",18,61);
end (* of if not nil--- *)
else
begin
outmess("no ncp-buf available",txt_len,62);
end; (* of else *)
endm:=true;
end (* of case terminator *)
otherwise
endm:=true;
end; (* of cmd-case *)
reset_level;
end; (* of sendm *)
\f
procedure c_formatter;
const
replm = 4;
c_sem_env = semenv_t(
6,1, (* nr_parm, nrconst *)
p_desc_l_t(
p_desc_t(false,(.cmdt.),1,1),
4***p_desc_t(false,(.bytet.),1,1),
p_desc_t(false,(.bytet.),1,16),
(m_nr_id - 6) *** p_desc_t(?,?,?,?)),
id_desc_l_t(
id_desc_t(27,6,5), (*keeplm *)
id_desc_t(34,4,6), (*mask *)
id_desc_t( 1,4,1), (*oper *)
id_desc_t(13,6,3), (*prdata *)
id_desc_t( 6,6,2), (*prhead *)
id_desc_t(20,6,4), (*prvert *)
(m_nr_id - 6)***id_desc_t(?,?,?)),
id_desc_l_t(
id_desc_t(39,5,1), (* replm *)
(m_nr_id-1)***id_desc_t(?,?,?)),
const_l_t(
c_l_e_t(cmdt,replm,?),
(m_nr_id-1)***c_l_e_t(?,?,?)),
"oper prhead prdata prvert keeplm mask replm ");
var
c_parm_l:parm_l_t;
i,j:integer;
endm:boolean;
begin (* Body of c_formatter *)
init_level;
for i:=1 to c_sem_env.nr_parm do
c_parm_l(i):=p_l_e_init;
while not endm do
begin
i:=seman(c_sem_env,c_parm_l);
case i of
noop,replm:
begin
for j:=2 to 5 do
with c_parm_l(j) do
if p_ref <> 0 then
if getbyte(p_ref) = 0 then mask(j-2):=false
else mask(j-2):=true;
with c_parm_l(6) do
if p_ref <> 0 then
for j:=0 to 15 do
if j < p_cnt * p_mult then
mask(j):=getbyte(p_ref + j mod p_cnt) > 0;
case i of
0: ;
replm:
begin
outmess("message repeat: ",15,91);
send_term_data(messform,repmess);
end;
otherwise ;
end;
end; (* of command-exec *)
otherwise endm:=true
end; (* of i - case *)
end; (* of while loop *)
reset_level;
end; (* of c_formatter *)
\f
const
end_op = 4;
(*************************)
(* router lcp functions *)
(*************************)
crecon = 20; (* 5*4+0 *)
recon = 24; (* 6*4+0 *)
stcon = 12; (* 3*4+0 *)
stpcon = 16; (* 4*4+0 *)
sett = 28; (* 7*4+0 *)
setnwt = 8; (* 2*4+0 *)
sencon = 5; (* 1*4+1 *)
gett = 9; (* 2*4+1 *)
groutt = 13; (* 3*4+1 *)
ghlst = 6; (* 1*4+2 *)
gexst = 14; (* 3*4+2 *)
gdrvst = 10;
(*************************)
(* lic lcp functions *)
(*************************)
gevm = 5; (* 1*4+1 *)
gsurv = 9; (* 2*4+1 *)
gstat = 6; (* 1*4+2 *)
sevm = 4; (* 1*4+0 *)
remlic= 8; (* 2*4+0 *)
reslic= 12; (* 3*4+0 *)
srett = 16; (* 4*4+0 *)
grett = 17; (* 4*4+1 *)
(*************************)
(* ncp lcp functions *)
(*************************)
stime = 61*4+0;
sevadr = 62*4+0;
sexadr = 63*4+0;
gevadr = 62*4+1;
gexadr = 63*4+1;
glcp = 2*4+1;
grepf = 5*4+1;
(*****************************)
(* dce lcp functions *)
(*****************************)
restart = 8;
clvc = 12;
reslc = 16;
dce_sett= 20;
sstcr = 24;
crpvc = 28;
rempvc = 32;
ophlc = 36;
clhlc = 40;
dce_gsurv=6;
glcd = 10;
dce_ghlst=14;
ghlls = 13;
ghlrs = 17;
cparm_desc=p_desc_l_t(
p_desc_t(false,(.bytet,cmdt.),2,1), (* desc of lcpoper *)
p_desc_t(false,(.bytet.),1,1), (* desc of incarnation *)
p_desc_t(true,(.bytet,wrdt,txtt.),0,0), (* desc of datapart *)
(m_nr_id-3)***p_desc_t(?,?,?,?)); (* unused *)
cparm_id_desc=id_desc_l_t(
id_desc_t(9,4,3), (* data *)
id_desc_t(6,3,2), (* inc *)
id_desc_t(1,5,1), (* lcpoper *)
(m_nr_id-3)***id_desc_t(?,?,?)); (* unused *)
crout_env = semenv_t(
3,13, (* no of parms,consts *)
cparm_desc,
cparm_id_desc,
id_desc_l_t(
id_desc_t(13,6,1), (* crecon *)
id_desc_t(71,3,12), (* end *)
id_desc_t(74,6,13), (* gdrvst *)
id_desc_t(55,6,9), (* getroutt *)
id_desc_t(51,4,8), (* gett *)
id_desc_t(66,5,11), (* gexst *)
id_desc_t(61,5,10), (* ghlconst *)
id_desc_t(19,5,2), (* recon *)
id_desc_t(45,6,7), (* sencon *)
id_desc_t(39,6,6), (* setnwt *)
id_desc_t(35,4,5), (* sett *)
id_desc_t(24,5,3), (* stcon *)
id_desc_t(29,6,4), (* stpcon *)
(m_nr_id-13)***id_desc_t(?,?,?)), (* unused *)
const_l_t(
c_l_e_t(bytet,crecon,?),
c_l_e_t(bytet,recon,?),
c_l_e_t(bytet,stcon,?),
c_l_e_t(bytet,stpcon,?),
c_l_e_t(bytet,sett,?),
c_l_e_t(bytet,setnwt,?),
c_l_e_t(bytet,sencon,?),
c_l_e_t(bytet,gett,?),
c_l_e_t(bytet,groutt,?),
c_l_e_t(bytet,ghlst,?),
c_l_e_t(bytet,gexst,?),
c_l_e_t(cmdt,end_op,?),
c_l_e_t(bytet,gdrvst,?),
(m_nr_id-13)***c_l_e_t(?,?,?)),
"lcpopincdatacreconreconstconstpconsettsetnwtsencongettgrouttghlstgexstendgdrvst"
);
\f
clic_env = semenv_t
(3, (* no of parameters *)
9, (* no of constants *)
cparm_desc,
cparm_id_desc,
id_desc_l_t(
id_desc_t(48,3,8), (* end *)
id_desc_t(28,4,1), (* gevm *)
id_desc_t(51,5,9), (* grett *)
id_desc_t(18,5,3), (* gstat *)
id_desc_t(13,5,2), (* gsurv *)
id_desc_t(36,6,5), (* remlic*)
id_desc_t(42,6,6), (*reslic*)
id_desc_t(32,4,4), (*sevm *)
id_desc_t(23,5,7), (* srett *)
(m_nr_id-9)***id_desc_t(?,?,?)), (* unused *)
const_l_t(
c_l_e_t(bytet,gevm,?),
c_l_e_t(bytet,gsurv,?),
c_l_e_t(bytet,gstat,?),
c_l_e_t(bytet,sevm,?),
c_l_e_t(bytet,remlic,?),
c_l_e_t(bytet,reslic,?),
c_l_e_t(bytet,srett,?),
c_l_e_t(cmdt,end_op,?),
c_l_e_t(bytet,grett,?),
(m_nr_id-9)***c_l_e_t(?,?,?)),
"lcpopincdatagsurvgstatsrettgevmsevmremlicreslicendgrett"
);
\f
cncp_env = semenv_t(
3,11, (* no of parms and const *)
cparm_desc,
cparm_id_desc,
id_desc_l_t(
id_desc_t(64,3,11), (* end *)
id_desc_t(38,6,6), (* gevadr *)
id_desc_t(34,4,5), (* gevm *)
id_desc_t(44,6,7), (* gexadr *)
id_desc_t(50,4,8), (* glcp *)
id_desc_t(54,5,9), (* grepf *)
id_desc_t(59,5,10), (* gstat *)
id_desc_t(22,6,3), (* sevadr *)
id_desc_t(13,4,1 ), (* sevm *)
id_desc_t(28,6,4), (* sexadr *)
id_desc_t(17,5,2 ), (* stime *)
(m_nr_id-11)***id_desc_t(?,?,?)),
const_l_t(
c_l_e_t(bytet,sevm,?),
c_l_e_t(bytet,stime,?),
c_l_e_t(bytet,sevadr,?),
c_l_e_t(bytet,sexadr,?),
c_l_e_t(bytet,gevm,?),
c_l_e_t(bytet,gevadr,?),
c_l_e_t(bytet,gexadr,?),
c_l_e_t(bytet,glcp,?),
c_l_e_t(bytet,grepf,?),
c_l_e_t(bytet,gstat,?),
c_l_e_t(cmdt,end_op,?),
(m_nr_id-11)***c_l_e_t(?,?,?) ),
"lcpopincdatasevmstimesevadrsexadrgevmgevadrgexadrglcpgrepfgstatend" );
\f
cdce_env = semenv_t(
3,18, (* no of parms,consts *)
cparm_desc,
cparm_id_desc,
id_desc_l_t(
id_desc_t(31,5,10), (* clhlc *)
id_desc_t(28,4,3), (* clvc *)
id_desc_t(43,5,7), (* crpvc *)
id_desc_t(76,3,15), (* end *)
id_desc_t(63,4,12), (* gett *)
id_desc_t(59,4,11), (* gevm *)
id_desc_t(84,5,17), (* ghlls *)
id_desc_t(89,5,18), (* ghlrs *)
id_desc_t(79,5,16), (* ghlst *)
id_desc_t(72,4,14), (* glcd *)
id_desc_t(67,5,13), (* gsurv *)
id_desc_t(54,5,9), (* ophlc *)
id_desc_t(48,6,8), (* rempvc *)
id_desc_t(24,5,4), (* reslc *)
id_desc_t(17,7,2), (* restart*)
id_desc_t(36,4,5), (* sett *)
id_desc_t(13,4,1), (* sevm *)
id_desc_t(40,5,6), (* sstcr *)
(m_nr_id - 18)*** id_desc_t(?,?,?)),
const_l_t(
c_l_e_t(bytet,sevm,?),
c_l_e_t(bytet,restart,?),
c_l_e_t(bytet,clvc,?),
c_l_e_t(bytet,reslc,?),
c_l_e_t(bytet,dce_sett,?),
c_l_e_t(bytet,sstcr,?),
c_l_e_t(bytet,crpvc,?),
c_l_e_t(bytet,rempvc,?),
c_l_e_t(bytet,ophlc,?),
c_l_e_t(bytet,clhlc,?),
c_l_e_t(bytet,gevm,?),
c_l_e_t(bytet,gett,?),
c_l_e_t(bytet,dce_gsurv,?),
c_l_e_t(bytet,glcd,?),
c_l_e_t(cmdt,end_op,?),
c_l_e_t(bytet,dce_ghlst,?),
c_l_e_t(bytet,ghlls,?),
c_l_e_t(bytet,ghlrs,?),
(m_nr_id - 18)***c_l_e_t(?,?,?)),
"lcpopincdatasevmrestartreslclvclhlcsettsstcrpvcrempvcophlcgevmgettgsurvglcdendghlstghllsghlrs");
\f
procedure lcp_func( com_env : semenv_t; lcp_id: integer);
var
crout_parm_l : parm_l_t;
endm,startses: boolean := false;
i,j : integer;
messbufp : integer;
begin (* body of lcpfunc *)
init_level;
for i := 1 to com_env.nr_parm do
crout_parm_l(i) := p_l_e_init;
while not endm do
case seman(com_env,crout_parm_l) of
noop:
begin
sensesem(ncp_mess_ref,comint_sem);
if ( crout_parm_l(1).p_ref>0 ) then
if not nil(ncp_mess_ref) then
begin
pop(hook_ref,ncp_mess_ref);
lock ncp_mess_ref as ncp_mess : ts_data_type do
with ncp_mess,sp_head do
begin
receiver_id := (getbyte(crout_parm_l(2).p_ref))+lcp_id;
sender_id := 32766;
seq_no := mess_seq_no;
mess_seq_no := (mess_seq_no+1) mod 256;
sp_type := 0;
lcp_oper := getbyte(crout_parm_l(1).p_ref);
status := 0;
messbufp := 1;
movebytes(crout_parm_l(3),sp_data,messbufp);
bytecount := messbufp-1;
crout_parm_l(1).p_ref:=0;
end; (* with *)
push(hook_ref,ncp_mess_ref);
ncp_mess_ref^.u2 := 0;
return(ncp_mess_ref);
outmess("message submitted ",18,61);
end (* if not nil *)
else
begin
outmess("no ncp-buf available",txt_len,62);
end
else startses:=true;
endm:=not(startses);
end;
terminator: startses:=true;
error: (* no operations at all *);
otherwise
endm:=true;
end; (* case *)
reset_level;
end; (* end of lcpfunc *)
\f
begin (* body of session *)
reset_system;
for i:=1 to sess_env.nr_parm do
sess_parm_l(i):=p_l_e_init;
mask:=def_opt_mask;
outmess("session initiated ",17,81);
while not endm do
begin
i:=seman(sess_env,sess_parm_l);
if sess_parm_l(10).p_ref > 0 then
def_base:=getbyte(sess_parm_l(10).p_ref);
if not (def_base in (.2,8,10,16.) ) then
begin
print(ill_base_val);
def_base:=10
end;
case i of
noop: (* no actions *);
sendm: sendmess;
form: c_formatter;
rout: lcp_func(crout_env,lid_router0);
lic: lcp_func(clic_env,lid_lic0);
ncp: lcp_func(cncp_env,lid_ncp);
dce: lcp_func(cdce_env,lid_dce0);
terminator,error: (* do nothing *);
escape: endm:=true;
end; (* of cmd-case *)
end; (* of while *)
end; (* of session *)
\f
var i:integer;
begin (* body of comint *)
alloc(inbuf_ref,inbuf_pool,inbuf_sem);
inbuf_ref^.u1:=1;
lock inbuf_ref as inbuf:operbuf_t do
inbuf:=inbuf_init;
for i :=1 to nr_term_mess_buf do
begin
alloc(term_mess_ref, term_mess_pool,term_mess_sem);
alloc(help,term_mess_h_pool,term_mess_sem);
push(help,term_mess_ref);
lock term_mess_ref as term_mess:ts_data_type do
term_mess.sp_head:=term_mess_init;
return(term_mess_ref);
end;
alloc(nrbufr,nrbufpool,nrbufsem);
outmess("vers. 81.06.05/0 ",19,80);
while true do
session;
end. (* comint *)
«eof»