module hot_files(ident = 'V01-006', main = hf, version = 'BOs proto') = 

!
! COPYRIGHT (©) 1988 BY
! DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASSACHUSETTS.
! ALL RIGHTS RESERVED.  DIGITAL INTERNAL USE ONLY.
!
! THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
! ONLY  IN  ACCORDANCE  OF  THE  TERMS  OF  SUCH  LICENSE  AND WITH THE
! INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR  ANY  OTHER
! COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
! OTHER PERSON.  NO TITLE TO AND  OWNERSHIP OF THE  SOFTWARE IS  HEREBY
! TRANSFERRED.
!
! THE INFORMATION IN THIS SOFTWARE IS  SUBJECT TO CHANGE WITHOUT NOTICE
! AND  SHOULD  NOT  BE  CONSTRUED  AS A COMMITMENT BY DIGITAL EQUIPMENT
! CORPORATION.
!
! DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE  OR  RELIABILITY OF ITS
! SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.

! Build instructions:
!
! $ BLISS HOT_FILES
! $ LINK  HOT_FILES, SYS$SYSTEM:SYS.STB/SELECT

begin

! 001 Main version
! 002 Rework logic around "foolish FCBs"
! 003 Don't chase down ss member FCBs
! 004 Change 'and' to 'or' in display logic (bug fix)
! 005 Fix bug introduced by memory expansion failing to expand SORT_BASE array.
! 006 SMP support
builtin movpsl;

library 'sys$library:lib';

linkage
    ioc_linkage = JSB : global(ucb = 10, ddb = 11),
    sch_linkage = JSB(register=4) : nopreserve(0,1,2);

external
  CTL$GL_PHD		: Addressing_mode (General),
  CTL$GL_PCB		: Addressing_mode (Absolute),
  SGN$GW_MAXPRCCT	: Word Addressing_mode (Absolute);

external routine 
  IOC$SCAN_IODB		: Addressing_mode(Absolute) ioc_linkage,
  FOR$CVT_D_TF		: Addressing_mode(General),
  LIB$FID_TO_NAME	: Addressing_mode(General),
  LIB$FREE_VM		: Addressing_mode(General),
  LIB$GET_VM		: Addressing_mode(General),
  LIB$SUBX		: Addressing_mode(General),
  SCH$IOLOCKR		: Addressing_mode(Absolute) sch_linkage novalue,
  SCH$IOUNLOCK		: Addressing_mode(Absolute) sch_linkage novalue;

field bb_field =
  SET
    bb_top = [ 0, 0,  8, 0],	! First byte of each block
    bb_fcb = [ 0, 0, 32, 0],	! FCB address
    bb_ucb = [ 4, 0, 32, 0],	! UCB address
    bb_rd  = [ 8, 0, 32, 0],	! Read  count
    bb_wr  = [12, 0, 32, 0],	! Write count
    bb_ord = [16, 0, 32, 0],	! Old read  count
    bb_owr = [20, 0, 32, 0],	! Old write count
    bb_    = [24, 0, 16, 0],	! Unused
    bb_ok  = [26, 0,  8, 0],	! 1 if found this scan, else 0
    bb_kps = [27, 0,  8, 0],	! Kount-down value to re-get name
    bb_naml= [28, 0,  8, 0],	! ASCIC filename length
    bb_name= [29, 0,  8, 0]	! ASCIC filename text (MUST BE LAST!!!)
  TES;


global 
  fb_ddb,
  fb_fcb,
  fb_ucb,
  fcb, 
  vcb,
  wcb,
  sv_wcb;

literal 
  bb_len= 92,		! Block length
  c_len = 132,		! Output string length
  d_len = 31,		! Device name string
  f_len = 300,		! File spec string
  o_len = 7,		! String to display
  initial_kps = 10;	! Kountdown Kontrol

macro
  ob(a,b,c,d) = a%,
  ok = if not .s then signal(.s)%,

	put_desc(desc) = 
	(if .desc[DSC$W_LENGTH] gtr .line_width then
	  out_rab[RAB$W_RSZ] = .line_width else
	  out_rab[RAB$W_RSZ] = .desc[DSC$W_LENGTH];
	out_rab[RAB$L_RBF]   = .desc[DSC$A_POINTER];
	s = $put(rab=out_rab); ok)%;

map
  fb_ddb: ref $bblock[DDB$K_LENGTH],
  fb_fcb: ref $bblock[FCB$K_LENGTH],
  fb_ucb: ref $bblock[UCB$K_LENGTH],
  fcb	: ref $bblock[FCB$K_LENGTH],
  vcb	: ref $bblock[VCB$K_LENGTH],
  sv_wcb: ref $bblock[WCB$K_LENGTH],
  wcb	: ref $bblock[WCB$K_LENGTH];
  
own
  base_priority	: volatile,
  bbase 	: ref blockvector[ , bb_len, byte] field(bb_field),
  bmax,				! Maximum bb index currently in use
  bnum,				! Pointer to bb of interest
  bsize,			! Size of blockvector to allocate
  bcount	: initial (200),	! Count of bb's actually allocated
  class		: initial(0) volatile,	! SYS$OUTPUT device class
  clr_screen	: $bblock[8],
  clue_efn	: initial(5),		! Efn for drop_clue to use
  clue_time	: vector[2, long] initial(-10000000 * 1, -1),
  count_text	: $bblock[c_len],
  count_desc	: $bblock[8],
  device_name	: $bblock[d_len],
  dev_desc	: $bblock[8],
  efn_flag	: initial(4),	! Efn for main timer
  elapsed_seconds,
  run_priority	: initial(8) volatile,
  file_name	: $bblock[f_len],
  file_desc	: $bblock[8],
  last_wcb,
  line_width	: initial(c_len) volatile,
  lock_mem	: initial(0),
  node_name	: volatile vector[16, byte],
  node_name_len	: volatile,
  old_pri	: initial(0) volatile,
  out_fab	: $fab(fnm='sys$output', dnm='hot_files.lis', rat=cr),
  out_rab	: $rab(fab=out_fab, rop=eof),
  out_str	: volatile $bblock[c_len],
  out_str_desc	: volatile $bblock[8],
  page_size	: initial(0) volatile,
  proc_name	: volatile vector[80, byte],
  proc_name_len	: volatile,
  read_rate	: vector[o_len, byte],
  rc, wc,			! read-count, write-count
  s, 				! generic status value
  sort_base	: ref vector[],
  start_time	: vector[2, long],
  time		: vector[2, long] initial(-10 * 1000 * 1000 * 10, -1),
  tt_wrap	: initial(1) volatile,
  write_rate	: vector[o_len, byte],
  zero_time	: vector[2, long];

  bind esc_seq	= uplit( byte( %ascic ''));

  bind dvi_ptr  = uplit  (
		  word(4), word(DVI$_DEVCLASS), long(class),      long(0),
		  long(0)	);

  bind tt_ptr  	= uplit  (
		  word(4), word(DVI$_TT_PAGE),  long(page_size),  long(0),
		  word(4), word(DVI$_DEVBUFSIZ),long(line_width), long(0),
		  long(0)	);

  bind jpi_ptr  = uplit  (
		  word( 4), word(JPI$_PRIB), long(base_priority), long(0),
		  word(16), word(JPI$_PRCNAM), long(proc_name+1), 
		  long(proc_name_len),
		  long(0)	);

  bind syi_ptr  = uplit  (
		  word(16), word(SYI$_NODENAME), long(node_name+1), 
		  long(node_name_len),
		  long(0)	);

! ------- Special patch area for customization --------

psect global = $$patch( Align(9),
	Write, Execute, Concatenate, Global, Read, Noshare, Nopic);

literal patch_size = 2040;

forward patch_area: $bblock[patch_size];

global
  patch_descriptor	: vector[2, long] psect($$patch)
			  initial(patch_size, patch_area),
  patch_area		: $bblock[patch_size] psect($$patch);


! ------- Code -------

routine drop_clue(txt, locn) : novalue =	! Debugging help
begin

local psl: $bblock[4];

  movpsl(psl);		! Do nothing if Kernel mode (can't call RMS)
  if .psl[PSL$V_CURMOD] eql 0 then return;

  count_desc[DSC$A_POINTER] = count_text;
  count_desc[DSC$W_LENGTH]  = c_len;
  $fao( $Descriptor('Trace point: !AS !XL'), count_desc, count_desc, 
	.txt, .locn);
  put_desc(count_desc);
  $setimr(efn= .clue_efn, daytim= clue_time);
  $waitfr(efn= .clue_efn);
end;	! drop_clue

routine calc_ratio(a,b,outto) : novalue = ! Calculate a/b to 2 decimal places
begin
  builtin cvtlf, divf;
  local af, bf, flo: vector[2, long], ostr: $bblock[8];
  map outto: ref $bblock[o_len];

  ostr[DSC$W_LENGTH]  =  o_len - 1;
  ostr[DSC$A_POINTER] = .outto + 1;

  cvtlf(a, af); cvtlf(b, bf); flo[1] = 0;
  if .b eql 0 then flo[0] = 0 else divf(bf, af, flo); 
  s = FOR$CVT_D_TF(flo, ostr, 2);
  (.outto)<0,8> = o_len;
end; ! of calc_ratio

routine lock_everything : novalue =
begin
  local
    phd		: $bblock[PHD$K_LENGTH],
!    checksum_pre, checksum_post,
    range	: vector[2, long];

  phd = .CTL$GL_PHD;
  range[0] = %X'200';
  range[1] = .phd[PHD$L_FREP0VA] - 1;
!  checksum_pre = 0;
!  incr i from .range[0] to .range[1] by 4 do 
!    checksum_pre = (.checksum_pre ^ 1) + ..i;

  lock_mem = $lkwset(inadr = range);

!  checksum_post = 0;
!  incr i from .range[0] to .range[1] by 4 do 
!    checksum_post = (.checksum_post ^ 1) + ..i;

!  if .checksum_pre eql .checksum_post then return;
!  drop_clue($descriptor('****CHECKSUM ERROR after $LKWSET call'));
!  $exit(code=SS$_BUGCHECK);
end; ! lock_everything

routine check_expansion : novalue = ! See if we've run out of storage space
begin
  local
    temp_bbase,
    temp_bcount,
    temp_bsize;

  if .bmax + 4 lss .bcount then return;	! Lots of room for expansion

  temp_bcount = (3 * .bcount / 2) + 1;
  drop_clue($descriptor('Expanding entry count to '), .temp_bcount);

  temp_bsize = bb_len * .temp_bcount;
  s = LIB$GET_VM(temp_bsize,temp_bbase); if not .s then return;
  ch$move(.bsize, .bbase, .temp_bbase);	! Copy old area
  LIB$FREE_VM(bsize, bbase); 
  LIB$FREE_VM(%ref(%upval * .bcount), sort_base);
  s = LIB$GET_VM( %ref(%upval * .temp_bcount), sort_base); 
  if not .s then return;

  bsize = .temp_bsize;
  bbase = .temp_bbase;
  bcount= .temp_bcount;
  lock_everything();
  return
end;	! Check expansion

routine cleanup(v) : novalue =
begin
  if .old_pri gtr 0 then $setpri(pri= .old_pri);
  $close(fab= out_fab);
  $exit(code= .s)
end;

routine sort_table : novalue =
begin
  local i,j,t;

  if .bmax leq 0 then return;	! Really a debugging aid

  incr i from 0 to .bmax do
    if .bbase[.i, bb_ok] eql 0 then
      begin	! Remove expired files
        ch$move(bb_len, bbase[.bmax, bb_top], bbase[.i, bb_top]);
        bbase[.bmax, bb_ok] = 0;	! Avoid duplication
        bmax = .bmax - 1;
      end;	! Remove expired files

  incr i from 0 to .bmax do sort_base[.i] = .i;

  incr ii from 0 to .bmax do
    incr jj from 0 to .ii do
     begin
      i = .sort_base[.ii]; j = .sort_base[.jj];
      if  ((.bbase[.i, bb_rd]  - .bbase[.i, bb_ord]) 
	+ (.bbase[.i, bb_wr]  - .bbase[.i, bb_owr]) gtr
	  (.bbase[.j, bb_rd]  - .bbase[.j, bb_ord])
	+ (.bbase[.j, bb_wr]  - .bbase[.j, bb_owr])) then
        begin
	  t=.sort_base[.ii]; sort_base[.ii]=.sort_base[.jj]; sort_base[.jj]=.t;
        end;
     end;
end;

routine signal_screwup(xx, dd) : novalue =
begin
  map dd: ref $bblock[];

  count_desc[DSC$A_POINTER] = count_text;
  count_desc[DSC$W_LENGTH]  = c_len;
  s = $fao( $descriptor('Screw-up (!8XL) on !AF(!UL,!UW,!UW)'),
	count_desc, count_desc,
	.xx, .dd[DSC$W_LENGTH], .dd[DSC$A_POINTER],
	.fb_fcb[FCB$B_FID_NMX] ^ 16 + .fb_fcb[FCB$W_FID_NUM],
	.fb_fcb[FCB$W_FID_SEQ], .fb_fcb[FCB$B_FID_RVN]);
  put_desc(count_desc)

end; ! signal_screwup

routine print_filename(index) : novalue =
begin
  local
    msg_desc	: $bblock[8],
    msg_text	: $bblock[c_len],
    dev_node	: vector[7,byte],
    sb		: ref $bblock[];

  calc_ratio(.rc, .elapsed_seconds, read_rate);
  calc_ratio(.wc, .elapsed_seconds, write_rate);

  if .rc + .wc gtr 65000 then drop_clue(
	$descriptor(' out-of-range value at '), .index);

! Construct a device name string 

  fb_ucb = .bbase[.index, bb_ucb];
  fb_fcb = .bbase[.index, bb_fcb];
  fb_ddb = .fb_ucb[UCB$L_DDB];
  sb = .fb_ddb[DDB$L_SB];
  dev_desc[DSC$A_POINTER] = device_name;
  dev_desc[DSC$W_LENGTH]  = d_len;
  if .sb eql 0 then dev_node[0] = 0 else
      ch$move(7, sb[ob(SB$T_NODENAME), 0, 8, 0], dev_node[0]);

  s = $fao( $descriptor('!AC$!AC!UW:'), dev_desc, dev_desc,
          dev_node[0], fb_ddb[DDB$T_NAME], .fb_ucb[UCB$W_UNIT]); ok;

  if .dev_node[0] eql 0 then	! If no nodename
    begin			! Trim spurious leading '$'
      dev_desc[DSC$A_POINTER] = .dev_desc[DSC$A_POINTER] + 1;
      dev_desc[DSC$W_LENGTH]  = .dev_desc[DSC$W_LENGTH] - 1
    end;

  count_desc[DSC$A_POINTER] = count_text;
  count_desc[DSC$W_LENGTH]  = c_len;
  file_desc[DSC$A_POINTER] = file_name;
  file_desc[DSC$W_LENGTH]  = f_len;
  if .bbase[.index, bb_kps] eql 0 then
    begin
      s = LIB$FID_TO_NAME(dev_desc, fb_fcb[FCB$W_FID_NUM], file_desc,file_desc);
      if .s then 
       begin
        bbase[.index, bb_kps]  = initial_kps;
        bbase[.index, bb_naml] = min(.file_desc[DSC$W_LENGTH],
				 bb_len - %FIELDEXPAND(bb_name,0));
        ch$move( .bbase[.index, bb_naml],
		     .file_desc[DSC$A_POINTER], bbase[.index, bb_name]);
       end
    end else
      begin	! Typical case
        bbase[.index, bb_kps] = .bbase[.index, bb_kps] - 1;
        s = SS$_NORMAL	! Fake up a successful FID_TO_NAME call
      end;

  if .s eql SS$_NOSUCHFILE then s = .s or 1;

  if not .s then 
    begin 
      bbase[.index, bb_naml]  = 0;	! Forget any file name
      msg_desc[DSC$A_POINTER] = msg_text;
      msg_desc[DSC$W_LENGTH]  = c_len;
      s = $getmsg(msgid = .s, msglen = msg_desc, bufadr = msg_desc, flags = 1);
      if (.msg_text[0, 0, 8, 0] geq %C'a') and (.msg_text[0, 0, 8, 0] leq %C'z')
        then msg_text[0, 0, 8, 0] = .msg_text[0, 0, 8, 0] - %C'a' + %C'A';
      s = $fao( $descriptor('!7UL !6AC !6AC  !AF(!UL,!UW,!UW) !AS'),
	count_desc, count_desc, .rc + .wc,  read_rate, write_rate,
	.dev_desc[DSC$W_LENGTH], .dev_desc[DSC$A_POINTER],
	.fb_fcb[FCB$B_FID_NMX] ^ 16 + .fb_fcb[FCB$W_FID_NUM],
	.fb_fcb[FCB$W_FID_SEQ], .fb_fcb[FCB$B_FID_RVN], msg_desc); ok;
      put_desc(count_desc);
      return
    end;

  if .s eql (SS$_NOSUCHFILE or 1) then
    begin
      s = $fao( $descriptor('!7UL !6AC !6AC  !AF(!XL,!XW,!XW)'),
	count_desc, count_desc, .rc + .wc, read_rate, write_rate,
	.dev_desc[DSC$W_LENGTH], .dev_desc[DSC$A_POINTER],
	.fb_fcb[FCB$B_FID_NMX] ^ 16 + .fb_fcb[FCB$W_FID_NUM],
	.fb_fcb[FCB$W_FID_SEQ], .fb_fcb[FCB$B_FID_RVN]); ok;
    end else
    begin ! This is the normal case
      s = $fao( $descriptor('!7UL !6AC !6AC  !AC'),
	count_desc, count_desc, .rc + .wc, read_rate, write_rate, 
	bbase[.index, bb_naml]); ok;
    end; ! Normal case
  put_desc(count_desc)
end; ! print_filename

routine locate_bb : ioc_linkage =
begin

external register
  ddb = 11 : ref $bblock[DDB$K_LENGTH],
  ucb = 10 : ref $bblock[UCB$K_LENGTH];

  bnum = (incr i from 0 to .bmax do
	  if .bbase[.i, bb_fcb] eql .fcb then exitloop .i);

  if .bnum geq 0 then begin bbase[.bnum, bb_ok] = 1; return .bnum; end;

! Allocate new bb.  If there aren't enough, we lose for now -- inner mode

  if .bmax geq .bcount - 1 then return -1;! Out of space (cause expansion later)

  bmax = .bmax + 1;
  bnum = .bmax;	! So allocate it already
  bbase[.bnum, bb_fcb] = .fcb;
  bbase[.bnum, bb_ucb] = .ucb;
  bbase[.bnum, bb_rd]  = 0;
  bbase[.bnum, bb_wr]  = 0;
  bbase[.bnum, bb_ok]  = 1;
  bbase[.bnum, bb_kps] = 0;
  .bnum
end;

routine scan_file_chain : ioc_linkage novalue = 
begin	! Scan an FCB chain for good files

external register
  ddb = 11 : ref $bblock[DDB$K_LENGTH],
  ucb = 10 : ref $bblock[UCB$K_LENGTH];

  last_wcb = .fcb[FCB$L_WLFL];
  wcb = .fcb[FCB$L_WLBL];

  if .wcb geq 0 then return;			! Just in case
  if .wcb eql .wcb[WCB$L_WLFL] then return;	! No WCB (e.g., installed file)

! WCB, hence IOs to count.  Find the bb for this FCB, create one if none exists

  bnum = locate_bb();
  if .bnum lss 0 then return;	! No room, can't use this FCB, expand later

! Move WCB data to be "old" WCB data; initialize for new round of additions

  bbase[.bnum, bb_ord] = .bbase[.bnum, bb_rd];
  bbase[.bnum, bb_owr] = .bbase[.bnum, bb_wr];
  bbase[.bnum, bb_rd]  = 0;
  bbase[.bnum, bb_wr]  = 0;

! Go thru the WCB chain, adding up IO counts

  do if .wcb neq 0 then
    begin	! Chain thru WCBs for a file
      sv_wcb = .wcb;

      if .sv_wcb[WCB$B_TYPE] eql DYN$C_WCB then 
      while .sv_wcb neq 0 do 
        begin	! Chain thru WCBs for this channel
	   bbase[.bnum, bb_rd] = .bbase[.bnum, bb_rd] + .sv_wcb[WCB$L_READS];
	   bbase[.bnum, bb_wr] = .bbase[.bnum, bb_wr] + .sv_wcb[WCB$L_WRITES];
	   sv_wcb = .sv_wcb[WCB$L_LINK];
	end;

      wcb = .wcb[WCB$L_WLBL];		! Step to next entry
      if .wcb[WCB$B_TYPE] neq DYN$C_WCB then return
    end until (.wcb eql .last_wcb); 	! End of chain
end;

routine scan_volume : ioc_linkage novalue = 
begin ! Scan a volume for FCBs

external register
  ddb = 11 : ref $bblock[DDB$K_LENGTH],
  ucb = 10 : ref $bblock[UCB$K_LENGTH];

bind dc2 = ucb[UCB$L_DEVCHAR2] : $bblock[4];

local psl: $bblock[4];

  if .dc2[DEV$V_SSM] then return; ! ss member, skip it (only do master)

  movpsl(psl);		! If possible, raise IPL and synch with IO database
  if .psl[PSL$V_CURMOD] eql 0 then 
    begin
      SCH$IOLOCKR(.CTL$GL_PCB);
      if .lock_mem then SYS_LOCK(FILSYS,IPL$_SYNCH) ! Raise IPL
    end;	! K-mode

  fcb = .vcb[VCB$L_FCBFL];
  while (.fcb neqa .vcb) and (.fcb lss 0) do
    begin
      if .fcb[FCB$B_TYPE] neq DYN$C_FCB then 
        begin
          drop_clue($descriptor('Foolish FCB at '), .fcb);
          exitloop 
        end
        else scan_file_chain();
      fcb = .fcb[FCB$L_FCBFL]	! Step to next FCB on this volume
    end;

  if .psl[PSL$V_CURMOD] eql 0 then 
    begin
      SCH$IOUNLOCK(.ctl$GL_PCB);
      SYS_UNLOCK(FILSYS,0) ! Lower IPL to 0
    end;
end; ! scan_volume

routine scan_system = ! Scan all mounted disks

begin

global register
  ddb = 11: ref $bblock[DDB$K_LENGTH],
  ucb = 10: ref $bblock[UCB$K_LENGTH];

  incr i from 0 to .bmax do bbase[.i, bb_ok] = 0;	! Invalidate entries
  ddb = 0;
  ucb = 0;

  while 1 do
  begin
    if IOC$SCAN_IODB() eql 0 then return SS$_NORMAL;
    if .ucb[UCB$B_DEVCLASS] eql DC$_DISK then 
      begin
        if (vcb = .ucb[UCB$L_VCB]) neq 0 then scan_volume();
      end else ucb = 0;
    end; ! while 1

SS$_NORMAL end; ! scan_system

routine blank_screen : novalue = ! Called to start a new screenful
begin
  builtin ediv;
  local delta: vector[2, long];

  s = LIB$SUBX( zero_time, start_time, delta);
  if not .s then signal(.s);
  s = ediv( %ref(10000000), delta, elapsed_seconds, s);
  if .class eql DC$_DISK then
    begin
      count_desc[DSC$W_LENGTH] = 0;
      incr i from 1 to 4 do put_desc(count_desc);
    end; ! If to file
  count_desc[DSC$A_POINTER] = count_text;
  count_desc[DSC$W_LENGTH]  = c_len;
  s = $fao( $descriptor(
  '!AC  Total  reads writes  !AC file activity as of !20%D'),
  count_desc, count_desc, clr_screen, node_name, zero_time); ok;
  put_desc(count_desc);
  s = $fao( $descriptor('  count   /sec  /sec   '),
		count_desc, count_desc);
  put_desc(count_desc);
  count_desc[DSC$W_LENGTH] = 0;
  put_desc(count_desc);
end;	! blank_screen

routine print_top_files : novalue =
begin
  own 
    argl	: vector[2, long] initial(1,0),
    i,
    out_count;

  out_count = 0;
  incr ii from 0 to .bmax do 
    begin
      i = .sort_base[.ii];
      if (.out_count geq .page_size - 3) and (.page_size gtr 0) then exitloop;
      wc = .bbase[.i, bb_wr] - .bbase[.i, bb_owr];	! Calculate read-
      rc = .bbase[.i, bb_rd] - .bbase[.i, bb_ord];	! and write-count

      if .bbase[.i, bb_ok] and
	  ((.rc gtr 0) or (.wc gtr 0)) and
	 ((.bbase[.i, bb_rd]  gtr .bbase[.i, bb_ord]) or
          (.bbase[.i, bb_wr]  gtr .bbase[.i, bb_owr])) then
	begin	! Something to print.  Check pre-print-activity.
	  if .out_count eql 0 then blank_screen();
	  out_count = .out_count + 1;
	  argl[1] = .i;
	  $cmexec(routin=print_filename, arglst=argl)
	end; ! Output file data
    end;
  if .out_count gtr 0 then $flush(rab= out_rab);
end; ! Print_top_files

! Main code

routine hf =
begin

  own 
    exit_block	: vector[4, long] initial(0, cleanup, 1, s),
    scratch_desc: $bblock[8],
    scratch_text: $bblock[c_len];

  s = $getjpiw(itmlst= jpi_ptr); ok;
  s = $dclexh(desblk= exit_block); ok;
  if .base_priority lss .run_priority then	! Increasing priority?
    s = $setpri(pri= .run_priority, prvpri= old_pri);
  s = $create(fab=out_fab); ok;
  s = $connect(rab=out_rab); ok;

  s = $getsyiw(itmlst = syi_ptr); ok;
  node_name[0] = .node_name_len;
  scratch_desc[DSC$A_POINTER] = .out_fab[FAB$L_FNA];
  scratch_desc[DSC$W_LENGTH]  = .out_fab[FAB$B_FNS];
  s = $getdviw(devnam=scratch_desc, itmlst=dvi_ptr);
  if not .s then 
    begin	! Can't get terminal information? OK, set for non-terminal
      clr_screen[0, 0, 8, 0] = 0;
      page_size = 0;
      line_width = c_len;
      class = DC$_DISK
    end; ! PPF

  if .class eql DC$_TERM then
    begin
      ch$move(.esc_seq<0,8> + 1, esc_seq, clr_screen);
      s = $getdviw(devnam=scratch_desc, itmlst= tt_ptr); ok
    end; ! If terminal

  bmax = -1;
  bcount = .SGN$GW_MAXPRCCT * 5 + 30;	! Guess how many files (can expand)
  bsize = bb_len * .bcount;
  s = LIB$GET_VM(bsize,bbase); ok;

! sort_base is a vector of indices -- exchange pointers, not data blocks

  s = LIB$GET_VM( %ref(%upval * .bcount), sort_base); ok;
  lock_everything();	! TRY to lock all of our memory

ch$fill(0, 8, start_time);	! 1st time flag (that's a pun, folks)

while 1 do
begin
  s = $setimr(efn=.efn_flag, daytim=time); ok;
  s = $cmkrnl(routin=scan_system);
  if .s eql SS$_NOPRIV then s = $cmexec(routin=scan_system); ok;

  sort_table();	! Set up vector sort_base to point to descending entries

  if (.start_time[0] or .start_time[1]) neq 0 then print_top_files();

  check_expansion();
  ch$move(8, zero_time, start_time);
  $gettim(timadr = zero_time);
  s = $waitfr(efn= .efn_flag); ok;
end; ! Loop forever

SS$_NORMAL end; ! of hf

end eludom