program write;
include '<pascal>pascmd.pas';
const
  mtopr=77B;
  mosrs=5B;
  mosdm=4B;
  sjdm8=4B;
  jfns=30B;
  maxrec=32768;   {largest record in bytes}
  options='/b:8/s:8192';  {8192 is largest possible record in words}
type str=packed array[1..40]of char;
     byte=0..377B;
     binforms=(notbin,left32,stream);
var
  binformat,formattab:table;
  binary:binforms;
  fn:text;
  format:char;
  high,done,recl,i,pnt:integer;
  lrecl,blksize:integer;
  dev,name,ext,version:str;
  devlen,namlen,extlen,verlen:integer;
  tapefile:packed array[1..200]of char;
  image:packed array[1..maxrec]of char;
  binaryin:file of byte;
  binaryout:file of array[1..maxrec]of byte;

function erstat(var f:file):integer; extern;

procedure analysis(var f:file); extern;

function strlen(s:str):integer;
	var i:integer;
  begin
  i := 0;
  while (i < 39) and (s[i+1] <> chr(0)) do
    i := i+1;
  strlen := i
  end;

procedure copyleft32;
  begin
  while not eof(binaryin) do
    begin
    i := 1;
    while (i <= lrecl) and not eof(binaryin) do
      begin
      binaryout^[i] := binaryin^;
      get(binaryin);
      i := i + 1
      end;
    if (i-1) <> lrecl
      then begin
      writeln(tty,'% Last block contains ',i-1:1,' bytes');
      for i := i to lrecl do
        binaryout^[i] := 0
      end;
    put(binaryout:lrecl)
    end
  end;

procedure copystream;
  begin
  while not eof(binaryin) do
    begin
    i := 1;
    while (i <= lrecl) and not eof(binaryin) do
      begin
      high := binaryin^;
      get(binaryin);
      binaryout^[i] := high * 20B + binaryin^;
      get(binaryin);
      i := i + 1
      end;
    if (i-1) <> lrecl
      then begin
      writeln(tty,'% Last block contains ',i-1:1,' bytes');
      for i := i to lrecl do
        binaryout^[i] := 0
      end;
    put(binaryout:lrecl)
    end
  end;

procedure copytext;
  begin {copytext}
  i := 0;  {char number in line}

  while not eof do
    begin {while eof}
    if input^ = chr(15B)
      then begin  {CR}
      get(input);  {See if CRLF}
      if eof(input)   {CR <EOF>}
	then writeln
      else if input^ = chr(12B)  {CR LF}
	then begin {same as bare LF}
	writeln;
	readln;
        if i > lrecl
	 then writeln(tty,'Input record ',i:1,' chars, truncated to ',lrecl:1);
        i := 0
	end {same as bare LF}
      else
	begin  {treat both CR and next char as normal char's}
        output^ := chr(15B);
        i := i + 1;
        if i <= lrecl
	  then put(output);
	output^ := input^;
	i := i + 1;
	if i <= lrecl
	  then put(output);
        get(input)
	end {create both CR}
      end {of CR}
    else if input^ = chr(12B)
      then begin {LF}
      writeln;
      readln;
      if i > lrecl
	then writeln(tty,'Input record ',i:1,' chars, truncated to ',lrecl:1);
      i := 0
      end {LF}
    else begin {normal}
      output^ := input^;
      i := i + 1;
      if i <= lrecl
	then put(output);
      get(input)
      end; {normal}
    end; {while not EOF}
  end;

procedure copyfile;
  begin
  case binary of
left32:	copyleft32;
stream: copystream;
notbin: copytext
    end;
  end;

function openinfile:Boolean;
  begin
  openinfile := true;
  case binary of

left32:	begin 
        reset(binaryin,'','/b:8/o');
	if erstat(binaryin) <> 0
	  then begin
	  analysis(binaryin);
	  openinfile := false
	  end
	end;

stream: begin
	reset(binaryin,'','/b:4/o');
	if erstat(binaryin) <> 0
	  then begin
	  analysis(binaryin);
	  openinfile := false
	  end
	end;

notbin:	begin
	reset(input,'','/e/o');
	if erstat(input) <> 0
	  then begin
	  analysis(input);
	  openinfile := false
	  end
	end;

    end;
  end;

begin
cmini('Tape name: ');
cmofi(output);
cmcfm;
jsys(jfns;dev,0:output,100000000000B);
devlen := strlen(dev);

formattab := tbmak(5);
tbadd(formattab,ord('U'),'Undefined',0);
tbadd(formattab,ord('S'),'Spanned',0);
tbadd(formattab,ord('F'),'Fixed',0);
tbadd(formattab,ord('D'),'D-variable',0);
tbadd(formattab,ord('B'),'Binary-fixed',0);
binformat := tbmak(2);
tbadd(binformat,1,'32-bit-left-justified',0);
tbadd(binformat,2,'36-bit-stream',0);
cmini('Format: ');
binary := notbin;
format := chr(cmkey(formattab));
cmcfm;

if format = 'B'
  then begin
  format := 'F';
  cmini('Bits per PDP-10 word: ');
  case cmkey(binformat) of
1:  binary := left32;
2:  binary := stream
    end;
  cmcfm;
  end;

loop
  cmini('Record size: ');
  lrecl := cmnum;
  cmcfm;
 exit if (lrecl >= 1) and (lrecl <= maxrec);
  writeln(tty,'Record size must be between 1 and ',maxrec:1);
  end;

if format = 'F'
then begin
  loop
    cmini('Number of records per block: ');
    i := cmnum;
    cmcfm;
    blksize := lrecl * i;
   exit if (blksize >= 1) and (blksize <= maxrec);
    writeln(tty,'(Record size) * (number of records per block) must be between 1 and ',maxrec:1);
    end;
  end;  {of F}

if format in ['S','D']
then begin
  loop
    cmini('Block size: ');
    blksize := cmnum;
    cmcfm;
   exit if (blksize >= 1) and (blksize <= maxrec);
    writeln(tty,'Block size must be between 1 and ',maxrec:1);
    end;
  end;  {S and D}

while true do
 begin
 writeln(tty);
 cmini('copy from: ');
 gjgen(100120000000B);
 if binary <> notbin
   then cmfil(binaryin)
   else cmfil(input);
 cmcfm;
 repeat
  if not openinfile
    then goto 666;
  write(tty,'[');
  if binary <> notbin
    then jsys(jfns;101B,0:binaryin,0)
    else jsys(jfns;101B,0:input,0); 
  write(tty,' as ');
  if binary <> notbin
    then jsys(jfns;name,0:binaryin,001000000000B)
    else jsys(jfns;name,0:input,001000000000B);
  namlen := strlen(name);
  if binary <> notbin
    then jsys(jfns;ext,0:binaryin,000100000000B)
    else jsys(jfns;ext,0:input,000100000000B);
  extlen := strlen(ext);
  if binary <> notbin
    then jsys(jfns;version,0:binaryin,000010000000B)
    else jsys(jfns;version,0:input,000010000000B);
  verlen := strlen(version);
  if (extlen > 0) and (namlen + 1 + extlen > 17)  {name is too long}
    then begin {try to use the whole extension}
    if extlen > 10   {leave at least 6 chars for name}
      then extlen := 10;
    namlen := 17 - extlen - 1;  {give name the leftover space}
    end;
  strwrite(fn,tapefile);
  write(fn,dev:devlen,':',name:namlen,'.',ext:extlen,'.',version:verlen);
  getindex(fn,i);
  writeln(tty,tapefile:i-1,']');
  write(fn,';FORMAT:',format,';REC:',lrecl:1);
  if not (format in ['U','u'])
    then write(fn,';BLOCK:',blksize:1);
  write(fn,chr(0));
  if binary <> notbin
   then begin
     rewrite(binaryout,tapefile,options);
    jsys(mtopr,-1;0:binaryout,mosdm,sjdm8); {use ind compat - in case format U}
    end
   else begin
    rewrite(output,tapefile,options);
    jsys(mtopr,-1;0:output,mosdm,sjdm8); {use ind compat - in case format U}
    end;
  copyfile;
  if binary <> notbin
    then begin
    close(binaryin);
    close(binaryout);
    done := nextfile(binaryin)
    end
   else begin
   close(input);
   close(output);
666:
   done := nextfile(input)
   end;
  until done = 0;
 end
end.