{[l-,r+,b+]}
{$nomain}
{$nowalkback}
{
  Dump internal file information for a file
}

%INCLUDE 'libdef';


PROCEDURE fdump(VAR dumpfile: text);
  EXTERNAL;


PROCEDURE fdump;

  CONST
    tab = '                    ';
    null = '     ';

  VAR
    f: user_file_variable;
    tbyte: char;

{
  Print a decimal value with a trailing decimal point
}


  PROCEDURE decimal(i: integer);


    BEGIN
      write(i: 7);
      IF abs(i) < 10 THEN write(' ')
      ELSE write('.');
      write('     ');
    END;

{
  Print an octal value with a trailing "B"
}


  PROCEDURE octal(i: word);


    BEGIN
      write(i: - 7);
      IF i < 8 THEN write(' ')
      ELSE write('B');
      write('     ');
    END;

{
  Print a RAD50 word as up to 3 chars
}


  PROCEDURE rad50(i: word);

    CONST
      rad = ' ABCDEFGHIJKLMNOPQRSTUVWXYZ$.?0123456789';


    BEGIN
      write(rad[i DIV 1600 + 1]);
      i := i MOD 1600;
      write(rad[i DIV 40 + 1]);
      write(rad[i MOD 40 + 1]);
    END;




  BEGIN { Fdump }
    f := loophole(user_file_variable, dumpfile);
    IF (f = NIL) OR odd(loophole(integer, f)) THEN
      writeln('FDUMP: file is not open')
    ELSE
      WITH f^ DO
        BEGIN
        writeln;
        write('File information for file variable at:');
        octal(loophole(word, f));
        writeln;
        writeln;
        writeln('Contents of file variable:');
        writeln;
        write('Ptr: ');
        octal(ptr);
        writeln('Pointer to data in file buffer');
        write('Lun: ');
        decimal(lun);
        writeln('Logical Unit Number');
        write('Stat:');
        tbyte := loophole(char, stat);
        octal(ord(tbyte) AND 255);
        writeln('File status');
        IF feof IN stat THEN writeln(tab, 'End of file');
        IF feoln IN stat THEN writeln(tab, 'End of line');
        IF def IN stat THEN writeln(tab, 'Current character is defined')
        ELSE IF txt IN stat THEN
          writeln(tab, 'Current character not defined');
        IF txt IN stat THEN writeln(tab, 'Text file')
        ELSE writeln(tab, 'Record file');
        IF ftn IN stat THEN writeln(tab, 'Fortran carriage control');
        IF inp IN stat THEN writeln(tab, 'Input operations permitted');
        IF out IN stat THEN writeln(tab, 'Output operations permitted');
        IF rnd IN stat THEN writeln(tab, 'Random access file');
        write('Iov: ');
        octal(iov);
        writeln('I/O vector address');
        write('Buf: ');
        octal(buf);
        writeln('Record buffer address');
        write('Siz: ');
        decimal(siz);
        writeln('Record buffer size');
        write('Fdb: ');
        octal(loophole(word, fdb));
        writeln('FDB address');
        write('End: ');
        octal(bend);
        writeln('Pointer past end of buffer');
        write('Efla:');
        decimal(eflag);
        writeln('Error flag');
        IF eflag = 0 THEN writeln(tab, 'No error has been flagged')
        ELSE writeln(tab, 'An error has been detected');
        write('Nfla:');
        decimal(nflag);
        writeln('No I/O error flag');
        IF nflag = 0 THEN writeln(tab, 'I/O errors are fatal')
        ELSE writeln(tab, 'I/O errors are not fatal');
        write('Iosb:');
        octal(iosb);
        writeln('I/O status of last operation');
        write('Len: ');
        decimal(len);
        writeln('Length of last I/O transfer');
        writeln('Dev:      ', dev, '      Device name');
        write('Unit:');
        decimal(unit);
        writeln('Unit number');
        write('Tmod:');
        octal(tmod);
        writeln('Terminal I/O subfunction bits');
        write('Flg2:');
        tbyte := loophole(char, flg2);
        octal(ord(tbyte) AND 255);
        writeln('Extended file status flags');
        IF cup IN flg2 THEN
          writeln(tab, 'Terminal independent cursor addressing');
        writeln;
        IF fdb <> NIL THEN
          BEGIN
          writeln;
          writeln('Contents of File Descriptor Block:');
          writeln;
          WITH fdb^ DO
            BEGIN
            write('Rtyp:');
            octal(rtyp);
            writeln('Record type');
            CASE rtyp OF
              r$fix: writeln(tab, 'Fixed length records');
              r$var: writeln(tab, 'Variable length records');
              r$seq: writeln(tab, 'Sequenced records');
              OTHERWISE writeln(tab, 'Unknown record type');
              END;
            write('Ratt:');
            tbyte := loophole(char, ratt);
            octal(ord(tbyte) AND 255);
            writeln('Record attributes');
            IF fd$ftn IN ratt THEN writeln(tab, 'Fortran carriage control');
            IF fd$cr IN ratt THEN writeln(tab, 'Normal carriage control');
            IF fd$blk IN ratt THEN
              writeln(tab, 'Records do not cross block boundaries')
            ELSE writeln(tab, 'Records cross block boundaries');
            write('Rsiz:');
            decimal(rsiz);
            writeln('Record size');
            write('Hibk:');
            decimal(hibk[1]);
            writeln('Highest allocated block (MSB)');
            write(null);
            decimal(hibk[2]);
            writeln('(LSB)');
            write('Efbk:');
            decimal(efbk[1]);
            writeln('Highest used block (MSB)');
            write(null);
            decimal(efbk[2]);
            writeln('(LSB)');
            write('Ffby:');
            octal(ffby);
            writeln('First free byte in last block');
            write('Racc:');
            tbyte := loophole(char, racc);
            octal(ord(tbyte) AND 255);
            writeln('Record access modes');
            IF fd$rwm IN racc THEN writeln(tab, 'READ$/WRITE$')
            ELSE writeln(tab, 'GET$/PUT$');
            IF fd$ran IN racc THEN writeln(tab, 'Random access');
            IF fd$plc IN racc THEN writeln(tab, 'Locate mode')
            ELSE writeln(tab, 'Move mode');
            IF fd$ins IN racc THEN writeln(tab, 'Insert records');
            write('Rctl:');
            tbyte := loophole(char, rctl);
            octal(ord(tbyte) AND 255);
            writeln('Device characteristics');
            IF fd$rec IN rctl THEN writeln(tab, 'Record oriented')
            ELSE writeln(tab, 'Block oriented');
            IF fd$ccl IN rctl THEN writeln(tab, 'Carriage-control device');
            IF fd$tty IN rctl THEN writeln(tab, 'Terminal');
            IF fd$dir IN rctl THEN writeln(tab, 'Directory structured');
            IF fd$sdi IN rctl THEN writeln(tab, 'Single directory');
            IF fd$sqd IN rctl THEN writeln(tab, 'Sequential blocks');
            write('Urbd:');
            decimal(urbd.length);
            writeln('User record length');
            write(null);
            octal(loophole(word, urbd.buffer));
            writeln('User buffer address');
            write('Nrbd:');
            decimal(nrbd.length);
            writeln('Next record length');
            write(null);
            octal(loophole(word, nrbd.buffer));
            writeln('Next record address');
            write('Nrec:');
            octal(nrec);
            writeln('Address of next record');
            write('Eobb:');
            octal(eobb);
            writeln('End of block buffer');
            write('Rcnm:');
            decimal(rcnm[1]);
            writeln('Record number (MSB)');
            write(null);
            decimal(rcnm[2]);
            writeln('(LSB)');
            write('Aloc:');
            decimal(aloc);
            writeln('Number of blocks to extend file');
            IF aloc <> 0 THEN
              IF aloc > 0 THEN writeln(tab, 'Contiguous extension')
              ELSE writeln(tab, 'Non-contiguous extension');
            write('Lun: ');
            decimal(lun);
            writeln('Logical Unit Number');
            write('Facc:');
            tbyte := loophole(char, facc);
            octal(ord(tbyte) AND 255);
            writeln('File access bits');
            IF fa$rd IN facc THEN writeln(tab, 'Read only');
            IF fa$wrt IN facc THEN writeln(tab, 'Write');
            IF fa$ext IN facc THEN writeln(tab, 'Extend');
            IF fa$cre IN facc THEN writeln(tab, 'Create new file')
            ELSE writeln(tab, 'Open existing file');
            IF fa$tmp IN facc THEN writeln(tab, 'Temporary file');
            IF fa$apd IN facc THEN
              IF fa$cre IN facc THEN
                writeln(tab, 'Don''t supersede existing file')
              ELSE writeln(tab, 'Append to existing file');
            write('Dspt:');
            octal(dspt);
            writeln('Address of dataset descriptor');
            write('Dfnb:');
            octal(dfnb);
            writeln('Address of default filename block');
            write('Efn: ');
            decimal(efn);
            writeln('Event flag');
            write('Bkp1:');
            octal(bkp1);
            writeln('Bookkeeping bits');
            write('Err: ');
            decimal(err);
            writeln('Error code');
            write('Err1:');
            decimal(err1);
            writeln('Error flag');
            IF err1 < 0 THEN writeln(tab, 'Directive error code ($DSW)')
            ELSE writeln(tab, 'I/O error code');
            write('Mbct:');
            decimal(mbct);
            writeln('Multiple buffer count');
            write('Mbc1:');
            decimal(mbc1);
            writeln('Number of buffers in use');
            write('Mbfg:');
            decimal(mbfg);
            writeln('Multiple buffer flag');
            IF (mbfg AND 1) <> 0 THEN writeln(tab, 'Read-ahead')
            ELSE IF (mbfg AND 2) <> 0 THEN writeln(tab, 'Write-behind');
            write('Bgbc:');
            decimal(bgbc);
            writeln('Big buffer block count');
            write('Vbsz:');
            decimal(vbsz);
            writeln('Device buffer size');
            write('Bbfs:');
            decimal(bbfs);
            writeln('Block buffer size');
            write('Vbn: ');
            decimal(vbn[1]);
            writeln('Virtual block number (MSB)');
            write(null);
            decimal(vbn[2]);
            writeln('(LSB)');
            write('Bdb: ');
            octal(loophole(integer, bdb));
            writeln('Block-buffer descriptor address');
            write('Spdv:');
            octal(spdv);
            writeln('Spooler output device');
            write('Spun:');
            decimal(spun);
            writeln('Spooler unit number');
            write('Chr: ');
            octal(xchr);
            writeln('Reserved for system use');
            write('Actl:');
            decimal(retp);
            writeln('Number of retrieval pointers');
            write(null);
            tbyte := loophole(char, actl);
            octal(ord(tbyte) AND 255);
            writeln('Device access control bits');
            IF fa$enb IN actl THEN
              BEGIN
              writeln(tab, 'Control bits are enabled');
              IF fa$dlk IN actl THEN writeln(tab, 'Don''t lock file');
              IF fa$rwd IN actl THEN writeln(tab, 'Rewind magtape');
              IF fa$pos IN actl THEN
                writeln(tab, 'Position tape to end of file')
              ELSE writeln(tab, 'Position tape to end of tape');
              END
            ELSE writeln(tab, 'Control bits not enabled');
            write('Seqn:');
            decimal(seqn);
            writeln('Record sequence number');
            writeln;
            writeln('Contents of filename block in FDB');
            writeln;
            WITH fnb DO
              BEGIN
              write('Fid: ');
              decimal(fid[1]);
              writeln('File ID');
              write(null);
              decimal(fid[2]);
              writeln;
              write(null);
              decimal(fid[3]);
              writeln;
              write('Fnam: ');
              rad50(fnam[1]);
              rad50(fnam[2]);
              rad50(fnam[3]);
              writeln('   File name');
              write('Ftyp:    ');
              rad50(ftyp);
              writeln('      File type');
              write('Fver:');
              decimal(fver);
              writeln('Version number');
              write('Stat:');
              octal(loophole(word, stat));
              writeln('Filename block status bits');
              IF nb$dev IN stat THEN writeln(tab, 'Explicit Device');
              IF nb$dir IN stat THEN writeln(tab, 'Explicit UIC');
              IF nb$nam IN stat THEN writeln(tab, 'Explicit filename');
              IF nb$typ IN stat THEN writeln(tab, 'Explicit type');
              IF nb$ver IN stat THEN writeln(tab, 'Explicit version number');
              IF nb$sd1 IN stat THEN writeln(tab, 'Wildcard group in UIC');
              IF nb$sd2 IN stat THEN writeln(tab, 'Wildcard owner in UIC');
              IF nb$snm IN stat THEN writeln(tab, 'Wildcard filename');
              IF nb$stp IN stat THEN writeln(tab, 'Wildcard type');
              IF nb$svr IN stat THEN writeln(tab, 'Wildcard version number');
              write('Next:');
              octal(next);
              writeln('Wildcard context');
              write('Did: ');
              decimal(did[1]);
              writeln('Directory ID');
              write(null);
              decimal(did[2]);
              writeln;
              write(null);
              decimal(did[3]);
              writeln;
              writeln('Dvnm:     ', dvnm, '      Device name');
              write('Unit:');
              decimal(unit);
              writeln('Unit number');
              END;
            END;
          END;
        END;
  END; { Fdump }
