{
  This program converts VMS binary files into a printable
  representation and back.  The first part of the coded file is
  the FDL definition for the file so that all record
  and file attributes can be restored.
}
[inherit ('SYS$LIBRARY:STARLET')]
program code (input, output, infile, outfile);

const
  line_length = 78;			{ Length of text lines in output }
  MBX_name = 'CODE_MAILBOX';

type
  unsigned_byte = [byte] 0..255;
  unsigned_word = [word] 0..65535;
  block = array [0..511] of unsigned_byte;
  status_block = [volatile, quad] record
		   status, count : unsigned_word;
		   info : unsigned;
		 end;

  string = varying [256] of char;

  spawn_flags = [long] set of (NOWAIT, NOCLISYM, NOLOGNAM, U3, U4, U5, U6, U7,
			       U8, U9, U10, U11, U12, U13, U14, U15, U16, U17,
			       U18, U19, U20, U21, U22, U23, U24, U25, U26,
			       U27, U28, U29, U30, U31);

  sigarray = array [0..1] of integer;
  mecharray = array [0..4] of integer;

var
  action : varying [4] of char;
  line : string;
  infile, outfile, mailbox : [volatile] text;
  infile_name, outfile_name : string;
  chan : [static, volatile] unsigned_word;
  stat, event_flag : integer;
  LIB_proto_FAB : [external, readonly] FAB$TYPE;	{ Initialized FAB }
  LIB_proto_RAB : [external, readonly] RAB$TYPE;	{ Initialized RAB }

{--------------------------  External routines  ------------------------------}

[external]
function LIB$SPAWN (command : packed array [l1..u1:integer] of char:= %IMMED 0;
		    input : packed array [l2..u2:integer] of char := %IMMED 0;
		    output : packed array [l3..u3:integer] of char := %IMMED 0;
		    flags :  spawn_flags := %IMMED 0;
		    process_name : packed array [l4..u4:integer] of char
					:= %IMMED 0;
		    var PID, completion_status : integer := %IMMED 0;
		    EFN : integer := %IMMED 0;
		    %IMMED [unbound] procedure astadr := %IMMED 0;
		    astparam : integer := %IMMED 0
		   ) : integer; extern;

[external, asynchronous, unbound]
procedure LIB$SIGNAL (%IMMED stat : integer); extern;

[external]
function FDL$CREATE (fdl_str : [class_s] packed array [l1..u1:integer] of char;
		     fil_spc : [class_s] packed array [l2..u2:integer] of char
			       := %IMMED 0;
		     def_nam : [class_s] packed array [l3..u3:integer] of char
			       := %IMMED 0;
		     var res_nam : [class_s] packed array [l4..u4:integer]
				   of char := %IMMED 0
		    ) : integer; extern;

[external]
function OTS$CVT_TZ_L (hex_string : [class_s] packed array [l1..u1:integer]
				    of char;
		       %REF number : [unsafe] array [l2..u2:integer]
				     of unsigned_byte;
		       %IMMED val_size : integer := %IMMED 4;
		       %IMMED flags : integer := %IMMED 0
		      ) : integer; extern;

[external]
function CLI$GET_VALUE (name : [class_s] packed array [l1..u2:integer] of char;
			var retbuf : varying [maxlen] of char
		       ) : integer; extern;

{-----------------------------------------------------------------------------}

  {
    This exception handler merely exits when something bad happens.
  }
  [asynchronous, unbound]
  function Exit_on_error (var sig_args : sigarray;
			  var mech_args : mecharray
			 ) : integer;

  begin (* Exit_on_error *)
    $EXIT (sig_args[1]);
    Exit_on_error := SS$_RESIGNAL;
  end; (* Exit_on_error *)

  {
    This AST procedure is invoked when the spawned subprocess dies.  It
    is responsible for writing an EOF to the mailbox so that Pascal's read
    on the mailbox terminates.
  }
  [asynchronous, unbound]
  procedure Spawn_terminator;

  var
    stat : integer;
    chan : unsigned_word;
    iosb : status_block;

  begin  (* Spawn_terminator *)
    stat := $ASSIGN (DEVNAM := MBX_name,
		     CHAN := chan);
    if not odd (stat) then LIB$SIGNAL (stat);
    stat := $QIOW (CHAN := chan,
		   FUNC := IO$_WRITEOF + IO$M_NOW,
		   IOSB := iosb);
    if not odd (stat) then LIB$SIGNAL (stat);
    if not odd (iosb.status) then LIB$SIGNAL (stat);
    stat := $DELMBX (CHAN := chan);
    if not odd (stat) then LIB$SIGNAL (stat);
  end; (* Spawn_terminator *)

  {
    This procedure reads blocks from the input file and writes them
    to the output file in hexadecimal.  This is not the most
    efficient mechanism, but does allow us to create intermediate
    files that can be edited and then converted back to binary.

    We open the files we are passed.  "infile_name" is opened
    using VAX-11 RMS so that we can do block I/O.  "outfile" must already
    have been opened as a standard Pascal "file of char".
  }
  procedure Convert_blocks_to_text (var infile_name, outfile_name : string);

  var
    i, stat : integer;
    input_block : block;
    infile_FAB : FAB$TYPE;
    infile_RAB : RAB$TYPE;

  begin  (* Convert_blocks_to_text *)

    infile_FAB := LIB_proto_FAB;	{ Set up FAB and RAB for block I/O }
    infile_RAB := LIB_proto_RAB;

    with infile_FAB do
    begin
      FAB$V_BIO := true;  FAB$V_GET := true;
      FAB$L_FNA := iaddress (infile_name.body);
      FAB$B_FNS := infile_name.length;
    end;

    with infile_RAB do
    begin
      RAB$L_FAB := iaddress (infile_FAB);
      RAB$V_BIO := true;
      RAB$L_UBF := iaddress (input_block);
      RAB$W_USZ := size (input_block);
    end;

    stat := $OPEN (FAB := infile_FAB);
    if not odd (stat) then LIB$SIGNAL (stat);
    stat := $CONNECT (RAB := infile_RAB);
    if not odd (stat) then LIB$SIGNAL (stat);

    open (outfile, outfile_name, NEW);
    rewrite (outfile);
    stat := $CREMBX (CHAN := chan,
		     MAXMSG := 80,
		     PROMSK := %X'FF0F',
		     LOGNAM := MBX_name);
    if not odd (stat) then LIB$SIGNAL (stat);
    stat := LIB$SPAWN ('ANALYZE/RMS/FDL/OUTPUT='+ MBX_name +' '+ infile_name,
		       'NL:', 'NL:', [NOWAIT, NOCLISYM],
		       , , , , Spawn_terminator);
    if not odd (stat) then LIB$SIGNAL (stat);
    open (mailbox, MBX_name);
    reset (mailbox);
    while not EOF (mailbox) do
    begin
      readln (mailbox, line);
      writeln (outfile, line);
    end;
    write (outfile,
           '----------------------------------------------------------------');
    repeat
      stat := $READ (RAB := infile_RAB);
      if odd (stat) then
	for i := 0 to infile_RAB.RAB$W_RSZ - 1 do
	begin
	  if i mod 32 = 0 then writeln (outfile);
	  write (outfile, hex (input_block[i], 2, 2));
	end
      else
	if stat <> RMS$_EOF then LIB$SIGNAL (stat);
    until stat = RMS$_EOF;
    close (outfile);
  end;  (* Convert_blocks_to_text *)

  {
    This AST procedure is called whenever a read is detected on the
    mailbox.  Each time, we read a line from "infile" and write it to
    the mailbox.
  }
  [asynchronous, unbound]
  procedure Write_MBX;

  label
    999;

  var
    stat : integer;
    iosb : status_block;
    line : string;

  begin  (* Write_MBX *)
    readln (infile, line);
    if length (line) >= 1 then
      if line[1] = '-' then
      begin
	stat := $QIOW (CHAN := chan,
		       FUNC := IO$_WRITEOF + IO$M_NOW,
		       IOSB := iosb);
	if not odd (stat) then LIB$SIGNAL (stat);
	if not odd (iosb.status) then LIB$SIGNAL (stat);
	goto 999;
      end;
    stat := $QIOW (CHAN := chan,
		   FUNC := IO$_WRITEVBLK + IO$M_NOW,
		   IOSB := iosb,
		   P1 := line.body,
		   P2 := line.length);
    if not odd (stat) then LIB$SIGNAL (stat);
    if not odd (iosb.status) then LIB$SIGNAL (stat);

    stat := $QIOW (CHAN := chan,
		   FUNC := IO$_SETMODE + IO$M_READATTN,
		   P1 := %IMMED Write_MBX);
    if not odd (stat) then LIB$SIGNAL (stat);

999:
  end;  (* Write_MBX *)

  {
    This procedure reads hexadecimal text from the input file and writes
    binary blocks to the output file.

    We open the files we are passed.  "outfile_name" is opened
    using VAX-11 RMS so that we can do block I/O.  "infile_name" is
    opened as a standard Pascal "file of char".
  }
  procedure Convert_text_to_blocks (var infile_name, outfile_name : string);

  label
    999;

  var
    i, stat : integer;
    output_block : block;
    outfile_FAB : FAB$TYPE;
    outfile_RAB : RAB$TYPE;
    result_name : packed array [1..256] of char;
    hex_number : packed array [1..2] of char;

  begin  (* Convert_text_to_blocks *)

    outfile_FAB := LIB_proto_FAB;	{ Set up FAB and RAB for block I/O }
    outfile_RAB := LIB_proto_RAB;

    open (infile, infile_name, OLD);
    reset (infile);

    stat := $CREMBX (CHAN := chan,
		     MAXMSG := 80,
		     PROMSK := %X'FF0F',
		     LOGNAM := MBX_name);
    if not odd (stat) then LIB$SIGNAL (stat);

    Write_MBX;
    stat := FDL$CREATE (MBX_name, outfile_name, , result_name);
    if not odd (stat) then LIB$SIGNAL (stat);

    stat := $DELMBX (CHAN := chan);
    if not odd (stat) then LIB$SIGNAL (stat);

    with outfile_FAB do
    begin
      FAB$V_BIO := true;
      FAB$V_PUT := true;
      FAB$L_FNA := iaddress (result_name);
      FAB$B_FNS := index (result_name, ' ') - 1;
    end;

    with outfile_RAB do
    begin
      RAB$L_FAB := iaddress (outfile_FAB);
      RAB$V_BIO := true;
      RAB$L_RBF := iaddress (output_block);
    end;

    stat := $OPEN (FAB := outfile_FAB);
    if not odd (stat) then LIB$SIGNAL (stat);
    stat := $CONNECT (RAB := outfile_RAB);
    if not odd (stat) then LIB$SIGNAL (stat);

    repeat
      i := 0;
      repeat
	if EOLN (infile) then readln (infile);
	if EOF (infile) then goto 999;
	read (infile, hex_number);
	stat := OTS$CVT_TZ_L (hex_number, output_block[i], 1, 1);
	if not odd (stat) then LIB$SIGNAL (stat);
	i := i + 1;
      until i = 512;
999:
      outfile_RAB.RAB$W_RSZ := i;
      stat := $WRITE (RAB := outfile_RAB);
      if not odd (stat) then LIB$SIGNAL (stat);
    until EOF (infile);

    close (infile);
  end;  (* Convert_text_to_blocks *)

begin  (* program Code *)

  establish (Exit_on_error);

  stat := CLI$GET_VALUE ('$VERB', action);
  if not odd (stat) then LIB$SIGNAL (stat);

  stat := CLI$GET_VALUE ('P1', infile_name);
  if not odd (stat) then LIB$SIGNAL (stat);

  stat := CLI$GET_VALUE ('P2', outfile_name);
  if not odd (stat) then LIB$SIGNAL (stat);

  if action = 'ENCO' then
    Convert_blocks_to_text (infile_name, outfile_name)
  else if action = 'DECO' then
    Convert_text_to_blocks (infile_name, outfile_name)
  else
    writeln ('%CODE-E-NOSUCHFUNC, no such function');

end.  (* program Code *)