⟦331e5f71b⟧

TextFile

job oer 9 200 time 11 0 area 10 size 100000
(
source = copy 25.1
pxforlst=set 1 disc1
pxforerr=set 1 disc1
pxforlst=indent source mark lc
listc=cross pxforlst
o pxforerr
mode list.yes
message compile pxfor
pascal80 codesize.1024 spacing.1024 xtenv xncpenv xpoolenv xrouenv ncthenv testenv source
mode list.no
o c
lookup pass6code
if ok.yes
(pxforbin=set 1 disc1
pxforbin=move pass6code
scope user pxforbin
)
pxforlst=copy listc pxforerr
scope user pxforlst
scope user pxforerr
finis
)






process formatter(
var sys_vector:system_vector;
var reserve_sem: semaphore;
var formatter_sem:semaphore);

const
sp_data_sz=300;
forewer=true;
time_lgt=12;


type

basetype=(bin,oct,dec,hex);
types=(bytet,wrdt);
base_l_t=array(basetype) of integer;
intg_l_r_t=array(basetype) of integer;
intg_l_t_t=array(types) of intg_l_r_t;
sp_5_data = packed array(1..5) of byte;
new_ts_data =
record
f,l,n:integer;
s_h : sp_head_type;
new_sp_data : sp_5_data;
end;


const
outbuf_init = operbuf_t(
6+alfalength,
97,
0,
"ncth        ",
? ) ;
 
bases=base_l_t(2,8,10,16);
intg_len=intg_l_t_t(
intg_l_r_t(9,4,4,3),
intg_l_r_t(17,7,6,5));

var
defbase:basetype:=dec;
mask:mask_type:=def_opt_mask;
outbufp:integer:=0;
outbufpool:pool 3 of operbuf_t;
outbufr:reference;
formatter_o_sem:semaphore;
avbuf:boolean:=true;

reserve_hook : reference;

inbufr:reference;
hook,hook1:reference;
last_mess:reference;
old_sp_data : sp_5_data := sp_5_data(5***0);
new : boolean;


procedure outputbuf;
begin
if not nil(outbufr) then
begin
lock outbufr as outbuf:operbuf_t do
outbuf.last:=outbufp+4+alfalength;
signal(outbufr,sys_vector(operatorsem)^);
end;
outbufp:=0;
end;

procedure outchar(ch:char);
begin
if outbufp=0 then
begin
wait(outbufr,formatter_o_sem);
if outbufr^.u2 <> 0 then
begin
hook^.u2 := outbufr^.u2;
avbuf:=false;
signal(outbufr,sys_vector(operatorsem)^);
end
else
begin
outbufp:=1;
avbuf:=true;
end;
end;
if avbuf then
begin
lock outbufr as outbuf:operbuf_t do
with outbuf do
databuf(outbufp):=ch;
outbufp:= succ(outbufp);
if outbufp > 80 then outputbuf;
end;
end;

procedure outtext(txt:txt_type;len:0..txt_len);
var i:integer;
begin
for i:=1 to len do outchar(txt(i));
end;

procedure outint(val:integer;base:basetype;len:1..txt_len);
var
bas,help,i,extra:integer;
txt:txt_type;
label outprint;
begin
bas:=bases(base);
if val < 0 then
if val <> -1 then
begin
val:=32767 + val + 2;
extra := 32767;
end
else
begin
case base of
bin: txt:=" 1111111111111111   ";
oct: txt:=" 177777             ";
dec: txt:=" 65535              ";
hex: txt:=" ffff               ";
end;
if len >= intg_len(wrdt,base) then val:=0;
goto outprint;
end
else
extra:=0;
i:=len;
repeat
help:=val mod bas + extra mod bas;
val:=val div bas;
extra:=extra div bas + help div bas;
help:=help mod bas;
if help < 10 then txt(i):=chr(help+48)
else txt(i):=chr(help+55);
i:=i-1;
until (i=1) or
      (val=0) and
      (extra=0) and
      (base <> bin);
outprint:
if val > 0 then for help:=1 to len do txt(help):='*'
else
for help:=1 to i do txt(help):=" ";
for i:=1 to len do outchar(txt(i));
end;

procedure outfield(
txt:txt_type;
tlen:integer;
val:integer;
base:basetype;
typ:types);
begin
outtext(txt,tlen);
outint(val,base,intg_len(typ,base));
outchar(nl);
end;

procedure out_lcp_mess(var p:reference );
forward;


procedure int_comint_com( var p:reference );

begin
lock p as m:comint_mess_t do
with m,sp_head,comint_data do
begin
if messnr < 51 then
outfield("error nr :          ",10,messnr,dec,bytet);
if position > 0 then
outfield("near position :     ",15,position,dec,bytet);
outtext(message,mess_l); outchar(nl);
mask:=c_mask;
if lcp_oper=repmess then
if not nil(last_mess) then
out_lcp_mess(last_mess);
case c_defbase of
2:defbase:=bin;
8:defbase:=oct;
10:defbase:=dec;
16:defbase:=hex;
otherwise (* do nothing *);
end;
if not ( c_mask(keep_last_mess) or nil(last_mess)) then
begin
push(hook1,last_mess);
return(last_mess);
end;
end;
outputbuf;
end; (* of int_comint_com  *)


procedure out_lcp_mess( var p:reference );

type
b_p_l_t = array(basetype) of byte;

const
bytes_pr_l = b_p_l_t(4,8,8,16);

var
b_pr_l,nrlines,remb,lim,i,j,k,l,len,val:integer;

begin
lock p as m:ts_data_type do
with m,sp_head do
begin
if mask(prhead) and (sender_id<>0) then
begin
outfield("SENDER_ID:          ",12,sender_id,dec,wrdt);
outfield("SEQ_NO:             ",12,seq_no,dec,wrdt);
outfield("SP_TYPE:            ",12,sp_type,bin,bytet);
outfield("LCP_OPER:           ",12,lcp_oper,dec,bytet);
outfield("STATUS:             ",12,status,bin,wrdt);
outtext("TIME:               ",12);
for i:= time_lgt div 2 downto 1 do
outint(time(i),hex,3);
outchar(nl);
outfield("BYTECOUNT:          ",12,bytecount,dec,wrdt);
outchar(nl);
end
else
begin
if sender_id <> 0 then
begin
outint(sender_id,dec,4);
outchar(' ');
end;
if (status <> 0 )   then outfield("STATUS    :",12,status,bin,wrdt);
end;
if mask(prdata) then
if mask(prvert) then
begin
outtext("NO. !DEC !HEX!ASC   ",17);outchar(nl);
for i:=1 to sp_head.bytecount do
begin
val:=sp_data(i);
outint(i,dec,4); outchar('!');
outint(val,dec,4); outchar('!');
outint(val,hex,3); outchar('!');
outchar(' ');
if val in (. 32..126.) then outchar(chr(val))
else outchar('*');
outchar(nl);
end;
end
else
begin
k:=0;
b_pr_l:=bytes_pr_l(defbase);
nrlines:=bytecount div b_pr_l;
remb:=bytecount mod b_pr_l;
len:= intg_len(bytet,defbase);
lim:=b_pr_l;
if remb > 0 then
nrlines:=succ(nrlines);
for i:=1 to nrlines do
begin
outint(k+1,dec,4); outchar(':');
if ( i = nrlines ) and ( remb > 0 ) then lim:=remb;
for j:=1 to lim do
begin
k:=succ(k);
outint(sp_data(k),defbase,len);
end;
outchar(nl);
end
end; (* of out lcp-messdata *)
outputbuf;
end;
end; (* of out_lcp_mess *)


var i:integer;
begin    (* body of formatter *)
for i:=1 to 2 do
begin alloc(outbufr,outbufpool,formatter_o_sem);
outbufr^.u1:=2; outbufr^.u2:=0;
lock outbufr as outbuf:operbuf_t do
outbuf:=outbuf_init;
return(outbufr)
end;
while forewer do
begin
wait(inbufr,formatter_sem);
wait(reserve_hook,reserve_sem);
pop(hook,inbufr);
hook^.u2:=0;
if hook^.u1 = 8+5 then
int_comint_com(inbufr)
else
begin
lock inbufr as n: new_ts_data do
if n.new_sp_data <> old_sp_data then
begin
old_sp_data := n.new_sp_data;
new := true;
end
else
new := false;
if new then
out_lcp_mess(inbufr);
if mask(keep_last_mess) then
begin
last_mess:=:inbufr;
hook1:=:hook;
end;
end;
if not nil(inbufr) then
begin
push(hook,inbufr);
return(inbufr);
end;
signal(reserve_hook,reserve_sem);
end;
end. (* of formatter *)
▶EOF◀
DataMuseum.dk

RC4000/8000/9000

⟦331e5f71b⟧ TextFile

Derivation

TextFile
