(*$R- No runtime checks *)
program PACK ( input, output, tty );
 
(* This program compresses arbitrary source files 
   to one file with unpacking information in it.
   The names of the source files are given from the terminal.
   The resulting file contains for each file:
   - one line with the file name
   - the source module lines
   - one line containing '****'
 
   An indirect file specification can also be specified as
   input.   eg.  if @XYZ is entered in response to file name,
   then the names of the files to packed will be taken from
   file XYZ.
 
   Unpacking can be performed by the program UNPACK.         *)
 
type nametype = array [1..22] of char ;
 
var   I, J, K: integer;
      C: char;
      FILNAM: nametype ;
      indfilename: nametype ;
      indfile: file of char ;
      none: boolean ;

procedure  getname ( var name: nametype; var none: boolean ) ;
 
var  i: integer;
 
procedure  getind  ( var name: nametype; var none: boolean ) ;
begin
none := eof(indfile) ;
if not none
then
    begin
    name := '                      ' ;   J:=1 ;
	loop
	exit if eoln(indfile) or ( J > 22 ) ;
	read( indfile, FILNAM[J] );   J := J+1
	end ;
    readln ( indfile ) ;
    none := false
    end
else
    indfilename := '                      ' ;
end ;
 
 
begin
none := true ;
if indfilename[1] <> ' ' then  getind ( name, none ) ;
    
if none then
    begin
    write( tty, 'Source file: ');   break;
    readln(tty);
    name := '                      ';   J:=1 ;
	loop
	exit if eoln(tty) or ( J > 22 ) ;
	read( tty, name[J] );   J := J+1 ;
	end ;
 
    if name[1] = '@' then
	begin
	for i:=1 to 21 do indfilename[i] := name[i+1] ;
	reset ( indfile, indfilename ) ;
	getind ( name, none )
	end ;
 
    if name[1] = ' ' then  none := true
		     else  none := false
    end
end ;

begin
 
write( tty, 'Output file name: ');   break;   readln(tty);
FILNAM := '                     ';    J := 1;
while not eoln(ttyin) do
 begin   read(tty, FILNAM[J] );   J := J+1   end;
rewrite( output, FILNAM );
 
indfilename[1] := ' ' ;
loop
  getname ( FILNAM, none ) ;
  exit if none ;
  if indfilename[1] <> ' ' then writeln ( tty, FILNAM ) ;
 
  reset( input, FILNAM );
  if eof(input) then writeln(tty,FILNAM,' not found')
  else
   begin   writeln( FILNAM );
    while not eof(input) do
     begin  (* copy a line *)
      while not eoln(input) do
       begin    read(c);   write(c)   end;
      readln; writeln;
     end;
    writeln('****');
   end;
end;
writeln(tty,'finished')
end.