⟦1e491fa3e⟧

TextFile

job jaba 1 600 time 5 10 perm disc 20 3
plibinsert = set 1
(plibinsert = pascal
lookupprog plibinsert
if ok.no
finis
plibdelete = assign plibinsert
pliblookup = assign plibinsert
scope project pliblookup plibdelete plibinsert
finis output.no )

program insert(output,ind,out,new);


(* this is a pascal80 library maintenance program,

the call is

                                              * 
1) æ <new lib> =å plibinsert æ <module name> å   æ lib.<old lib> å

2) pliblookup <lib>

                                         *
3) æ <new lib> = å plibdelete æ <entry> å  æ lib.<old lib> å

    <entry> ::=  entry. <number>    or  <module name>



 written by pm 1980, 

changed 80.12.09 by jaba

date of last changes:  81.06.10

*)

label 0;

const
test = false;
pow12 = 4096;
equal = 6; space = 4; point = 8;
name = 10; number = 4;

lib_lookup = 'pliblookup';
lib_delete = 'plibdelete';
lib_insert = 'plibinsert';
lib        = 'lib';
entry      = 'entry';

length_of_head = 11; (* length of fixed part of a descriptor segment *)
length_of_line_descriptor = 16; (* bytes *)



type
headtype=record
dl,   (* descriptor length ( = length of head  + parameters ) *)
pp,   (* number of program pages *)
ps,   (* page size *)
pr,   (* length of last page *)
kind  : integer;
pn: arrayÆ1..6Å of integer (* module name *)
end;

fil= file of integer;
bit=0..1;


var
l, n, sep, i, pno : integer;
prog,id,newlib,oldlib,newentry: alfa;
aux1, aux,ind,out,new: fil;
newhead,oldhead: headtype;
line_state : ( inline, after_space, after_newline, before_text );
make_lib, pnt : boolean;
c,oldc : iso;

number_of_inputs : integer;

coded_date : packed record
case boolean of
false: ( int : integer );
true : ( dummy : 0..255;
year : 0..127; (* year after 1900 *)
month : 0..15;
day   : 0..31;);
end;

coded_time : packed record
case boolean of
false : ( int : integer );
true  : ( dummy : 0..255;
          version : 0..31;
          hour    : 0..31;
          minute  : 0..63; );
end;




procedure error;
begin
writeln('***** param');
sep:=0; idÆsepÅ:=' ';
goto 0;
end;


procedure find_lib_name;
(* search the call for 'lib.<old lib>'
and let oldlib := <old lib>
default is 'oldlib' *)
var
sep, i, paramno : integer;
id : alfa;

begin
paramno := 0;
repeat
repeat 
sep := system( paramno, i, id );
paramno := paramno + 1;
until (sep = 0) or ((sep = space * pow12 + name) and (id = lib));
sep := system( paramno, i, id );
until (sep = 0) or (sep div pow12 = point);

if sep = point * pow12 + name then
oldlib := id
else
(* lib.<old lib>  not found *)
oldlib := 'oldlib';

if test then writeln( 'oldlib = ' , oldlib );
end; (* find lib param *)


procedure inhead(var head: headtype; var f: fil);
var i: integer;
begin
with head do
begin
if eof ( f ) then 
dl := -1
else
read( f, dl );
if dl > 0 then 
begin
read (f,pp,ps,pr,kind);
for i:=1 to 6 do
read (f, pnÆiÅ);
end;
end;
end;


procedure copy(var fo,fi: fil; n: integer; m: bit);
var
i: integer;
begin
for i:=1 to n do
begin if m=1 then write(fo,fi^); get(fi)
end
end;


procedure scan(var out,  f:fil;head: headtype; m: bit);
var
step, i,n: integer;

begin
with head do
if dl > 0 then
begin
if m=1 then
begin
write(out,dl,pp,ps,pr,kind,pnÆ1Å,pnÆ2Å,pnÆ3Å,pnÆ4Å,pnÆ5Å,
pnÆ6Å);
if test then
begin
for step := 1 to 6 do write( chr( pn Æ step Å div 256 ), chr( pn Æ step Å mod 256 ) );
writeln;
end; (* if test *)
end;


(* copy or skip rest of head and the code part *)

copy(out, f, dl div 2 - length_of_head, m);

(* read date and time *)
read(f,coded_date.int, coded_time.int );
if m = 1 then
write(out, coded_date.int, coded_time.int );

(* copy the code part *)

copy( out, f, ((pp - 1) * ps + pr + 1) div 2 - 2 (* date and time *), m);

(* copy or skip 'number of externals' *)
n:=f^; copy(out,f,1,m);
(* copy or skip the externals *)
for i:=1 to n do
begin
copy(out,f,6,m);
copy(out,f,2*f^+1,m);
copy(out,f,2*f^+1,m)
end;

(* skip or copy the internal links *)
copy( out, f, f ^ * 4 + 1, m);

end
end;


procedure gt(var c: iso);
begin
if n<0 then c:='.' else
if n=0 then c:=nl else
if n mod 2 = 0 then c:=chr(new^ div 256)
else
begin
c:=chr(new^ mod 256); get(new)
end;
n:=n-1
end;


procedure pt(c: iso);
begin
if l mod 2 =0 then oldc:=c else write(aux,ord(oldc)*256+ord(c));
l:=l+1
end; (* pt *)


procedure lookup_lib( lib_name : alfa );
var
no_of_ext, step, entry_number : integer;

procedure skip ( number_of_words : integer );
var
step : integer;

begin
for step := 1 to number_of_words do
get( ind );
end; (* skip *)


begin (* lookup lib *)

writeln(' nr  kind      name            date       time         bytes', nl);

entry_number := 0;
open( ind, lib_name );
reset( ind );
while not eof ( ind ) do
begin
inhead( newhead, ind );
with newhead do
if dl > 0 then
begin
entry_number := entry_number + 1;
write( entry_number : 3, '  ');

case kind of
1: write('PROCESS   ');
2, 4: write('PROCEDURE ');
3, 5: write('FUNCTION  ');
end; (* case kind *)


for step := 1 to 6 do
write( chr( pn Æ step Å div 256 ), chr( pn Æ step Å mod 256 ) );

skip( dl div 2 - length_of_head );
read ( ind, coded_date . int );
with coded_date do
write( 1900 + year, '.', month div 10 :1, month mod 10 :1, '.', 
day div 10 :1, day mod 10 :1 );
read( ind, coded_time . int );

with coded_time do
write( ' ', hour div 10 :1, hour mod 10 :1, '.', 
minute div 10 :1, minute mod 10 :1 );

write( dl + (pp-1) * ps + pr : 13);

skip (( (pp - 1) * ps + pr + 1) div 2 - 2 );


read( ind, no_of_ext );  (* number of external links *)
for step := 1 to no_of_ext do
begin
skip ( 6 );
skip ( ind ^ * 2 + 1 );
skip ( ind ^ * 2 + 1 );
end;

(* skip internal links *)
skip ( ind ^ * 4 + 1 );



writeln;

end; (* with newhead do *)
end; (* while not eof *)

end; (* lookup lib *)



procedure find_entry_and_delete;
(* search the call for 'entry . <number>', and delete the
entry (ies) in increasing order, i.e. one scan *)

label 1; (* used in case of end of file *)

var
sep, i, paramno, del_number, former_del_number, step : integer;
id : alfa;
exit : boolean;

begin
exit := false;
former_del_number := 0;
del_number := maxint;

repeat
paramno := 0;
repeat
repeat
sep := system( paramno, i, id );
paramno := paramno + 1;
until (sep = 0) or ((sep = space * pow12 + name) and (id = entry));

sep := system( paramno, i, id ); (* see if number *)
if sep = point * pow12 + number then
begin
if (i > former_del_number) and (i < del_number) then
del_number := i;

paramno := paramno + 1;
end; (* sep = . <number> *)

until sep = 0;

if del_number <> maxint then (* more to delete *)
begin
for step := former_del_number to del_number - 2 do
begin
if eof( ind ) then (* exit the loop *)  goto 1;
inhead( oldhead, ind );
scan( out, ind, oldhead, 1 );
end; (* copy until 'del_number' *)
if eof( ind ) then (* do not read   *)  goto 1;
inhead( oldhead, ind );
with oldhead do
if dl > 0 then
begin
write( del_number : 3, '  ');
case kind of
1: write('PROCESS   ');
2, 4: write('PROCEDURE ');
3, 5: write('FUNCTION  ');
end; (* case kind *)

for step := 1 to 6 do
write(chr( pn Æ step Å div 256), chr( pn Æ step Å mod 256) );
writeln('  deleted');
end; (* with oldhead ... *)

scan( out, ind, oldhead, 0 ) ; (* skip !! *)

1:  (* after deletion of one entry or end of file  !! *)
former_del_number := del_number;
del_number := maxint;

end
else
(* no more to delete *)
exit := true;

until exit;

if former_del_number <> 0 then
begin (* entry met at least once, copy to end of file and change files *)
while not eof(ind) do
begin
inhead(oldhead, ind); scan( out, ind, oldhead, 1 );
end;
number_of_inputs := number_of_inputs + 1;
close(out); close(ind);
(* prepare next scan *)
open( ind, newlib );

end; (* at least one entry deleted *)

end; (* find entry and delete *)


procedure insert_or_delete ( var ind, out : fil; newentry : alfa );

var
c1 : iso; (* used in connection with open routines *)


begin
if test then writeln(' insert or delete ( ', newentry ,' )' );
pnt := false;
number_of_inputs := number_of_inputs + 1;
if prog = lib_insert then
begin
open(new,newentry); reset(new); inhead(newhead,new);
end
else
for i:=1 to 6 do
newhead.pnÆiÅ:=ord(newentryÆ2*i-1Å)*256+ord(newentryÆ2*iÅ);
repeat
if eof(ind) then oldhead.pn:=newhead.pn else inhead(oldhead,ind);
if oldhead.pn=newhead.pn then
begin
if prog = lib_insert then
with newhead do
begin
if (kind<>4) and (kind<>5) then
begin (* binary code *)
scan( out, new,newhead,1); pnt:=true
end
else
begin (* open routine in textform *)
rewrite(aux);
copy(aux,new,dl div 2 - length_of_head,1);

l := 0;  (* l denotes the number of code bytes *)
read(new, coded_date . int, coded_time . int );
write(aux, coded_date.int, coded_time.int );
l := l + 4;
if coded_time . version = 4 then
begin
copy(aux, new, length_of_line_descriptor div 2 - 2 (* date and time *), 1);
l := l + length_of_line_descriptor - 4;
n := (pp - 1) * ps + pr - length_of_line_descriptor ;
end
else
n:=(pp-1)*ps+pr - 4 (* date and time ?? *);
gt(c); line_state:=before_text;
repeat
if c=' ' then
begin
if line_state = inline then line_state := after_space;
repeat gt(c) until c<>' ';  (* compress blanks *)
end
else
if (line_state >= after_newline) and ((c='o') or (c='l')) then
begin (* skip options and line numbers *)
gt(c1);
if c1 = '.' then
repeat
gt(c);
until (c = nl) or (c = ff)
else (* not option or line number *)
begin
pt( nl );
pt(c);
line_state := inline;
c := c1;
end;
end (* c = o or l *)
else
if c=';' then
begin
repeat gt(c) until (c=nl) or (c=ff);
end
else
if (c=nl) or (c=ff) then
begin
line_state := after_newline;
repeat gt(c) until (c<>nl) and (c<>ff) and (c<>' ');
pnt:=c='.';
end
else
begin
case line_state of
after_space : pt(' ');
after_newline : pt( nl );
end (* case *)
otherwise ;
line_state := inline;
pt(c); gt(c);
end;
until pnt;
pt(nl);
if l mod 2 = 1 then pt(' ');
while n>0 do gt(c);
pp:=1; pr:=l;

(* external links *)
n:=new^;
copy(aux,new,1,1);
for i:=1 to n do
begin
copy(aux,new,6,1);
copy(aux,new,new^+1,1);
copy(aux,new,new^+1,1);
end;

(* copy internal links *)
copy( aux, new, new ^ * 4 + 1 , 1);

reset(aux);
scan( out, aux,newhead,1);
end
end
else
pnt:=true;
if not eof(ind) then scan( out, ind,oldhead,0);
while not eof(ind) do
begin
inhead(oldhead,ind); scan( out, ind,oldhead,1);
end
end
else
scan( out, ind,oldhead,1);
until pnt;
if prog = lib_insert then close( new );
end; (* insert or delete *)
 

begin (* main program *)
newlib:='lib';
sep:=system(1,i,prog);
if sep=equal*pow12+name then 
begin
pno:=2; sep:=system(0,i,newlib);
end
else
begin
pno:=1; sep:=system(0,i,prog);
end;
sep:=system(pno,i,id);

if prog = lib_lookup then
lookup_lib( id )
else
begin

find_lib_name;

if newlib = oldlib then error;
open( ind, oldlib ); reset( ind );
make_lib := eof(ind);
open( out, newlib ); rewrite( out );
number_of_inputs := 0;

if prog = lib_delete then
find_entry_and_delete;   (* scan the call and delete entries specified by number *)

while sep<>0 do
begin
if sep mod pow12 <> name then error;
if ( (id = lib) and (system( pno + 1, i, id) = point * pow12 + name) ) or
( (id = entry) and (system( pno + 1, i, id) = point * pow12 + number) ) then
pno := pno + 2
else
begin
if make_lib or not odd( number_of_inputs ) then
begin
if make_lib or (number_of_inputs = 0) then
begin
insert_or_delete( ind, out, id );
if not make_lib then
begin
close ( out ); close ( ind );
(* prepare more input, i.e. let ind be the result file *)
open( ind, newlib );
end;
end
else (* not first *)
begin
rewrite( ind );
reset( aux1 );
insert_or_delete( aux1, ind, id );
end;
end
else (* odd number inserted until now *)
begin
reset( ind );
rewrite( aux1 );
insert_or_delete( ind, aux1, id );
end;

pno := pno + 1;
end;
sep:=system(pno,i,id);
end;

if number_of_inputs = 0 then (* insert default name *)
insert_or_delete( ind, out, 'pass6code');

if not make_lib and not odd(number_of_inputs) then
begin (* move the new library to newlib *)
reset( aux1 );
rewrite( ind );
while not eof( aux1 ) do
begin
write(ind, aux1 ^ ); get( aux1 );
end;
end; (* not odd ... *)

end; (* not lib lookup *)
close(ind); close(out);
0: if prog=lib_insert then close(new);
end.

▶EOF◀
DataMuseum.dk

RC4000/8000/9000

⟦1e491fa3e⟧ TextFile

Derivation

TextFile
