⟦4f1580f4f⟧

TextFile


external 
procedure  head_l(file_name, file_no, chains, size_l);
value  file_no;
string  file_name;
integer  file_no;
integer array  chains, size_l;
comment

    file_name   the name of a backing store area large enough to hold
                a list-file head including the first segment of the
                block-table.

    file_no     the logical number of the list-file.

    chains      specifications of all chains  in the system.

    size_l      contains the following 4 integers:

                fixed_rec_length
                min_rec_length
                segs_per_block
                max_blocks.

    The procedure outputs a list-file head in accordance with the
    parameters.
;
begin
  integer
    b2,
    b61,
    cf_base_addr,
    cf_buf_ref,
    chain_addr,
    chain_number_tbl,
    chain_part_size_zb,
    chain_seq_number_tbl,
    chain_type,
    chfld_rel_tbl,
    compressed_key_size,
    first_d_ch_addr_zb,
    first_m_ch_addr_zb,
    first_segs_zb,
    fixed_rec_length,
    fix_rec_size_zb,
    f10,
    f11,
    f18,
    f20,
    head_field_size_tbl,
    i,
    jl_x3,
    k,
    low,
    max_blocks,
    max_free,
    min_rec_length,
    next_chain_addr,
    recs_in_block_zb,
    segs_in_head_zb,
    segs_per_block,
    up;

  long
    sum;

  real
    r;

  integer array
    tail(1:10);



procedure  alarm(int, text);
value  int;
integer  int;
string  text;
comment
  the procedure prints an alarm headline, and calls
  system(9...;
begin
  write(out, <:<10><10>***headl  alarm:<10>:>);
  system(9, int, text);
end  alarm;


procedure  checkloops(motherindex, connections);
integer  motherindex, connections;
comment

    motherindex is an index value of a mother-file in array chains.
    This mother-file is selected as the starting point of a step to the
    corresponding daughter-file, followed by a search through array
    chains for all mother-files identical to this daughter-file.
    When such a file is found, the procedure is called recursively
    with a value of connections which is 4 greater.
    At entry, the procedure checks that conections does not exceed
    the upper index of array chains. If this is the case, a loop has
    been found, and exit to diagnos2 is made;

begin
  integer  newmotherindex;

  if connections>up then  goto  diagnos2;

  for newmotherindex:= 1 step 4 until up do
  begin
    if chains(motherindex + 1) = chains(newmotherindex) then
      checkloops(newmotherindex, connections + 4);
  end  newmotherindex;
end  checkloops;


comment
    initialize constants;

comment
    the content of the head, except the first double-word, is
    based upon cf-base_addr;

  cf_base_addr:= 0;

comment
    integers equivalent to slang-names of the code-procedures:

    first cf-variable used for list-files only, rel to cf_buf_ref;

  b2:= -10;

comment
    address of checksum rel to cf_buf_ref;

  b61:= 54;

comment
    size of mother-chain-table, and rel addr of prior-tbl in
    daughter-chain-table;

  f10:= 8;
  f11:= 12;

comment
    first word of block-table rel to victim_zb;

  f18:= 10;

comment
    free_bytes rel to block_ref, = (-bytes) before rec-base table
    in list-file block;

  f20:= -6;


  jl_x3:= 13 shift 18 + 3 shift 12;

comment
    check array chains;

    i:= 0;    comment    see diagnos1;

  low:= system(3, up, chains);

  if low<>1 or up mod 4 <>0 or up>8195 then  goto diagnos1;

comment
    check that no loops are present in the chaining structure;

  for i:= 1 step 4 until up do
    checkloops(i, 1);

comment
    check chain-type and compressed-key-size and calculate:
    cf_buf_ref, chain_part_size, first_d_ch_zb, first_m_ch_zb.

    The addresses are expressed as byte-values relative to the
    first byte of the file-head;

  first_m_ch_addr_zb:= cf_base_addr + 6;

  cf_buf_ref:= chain_part_size_zb:= first_d_ch_addr_zb:= 0;

  for i:= 1 step 4 until up do
  begin

    if chains(i) = file_no then
    begin 
    comment
        chain with the list-file as the mother-file;

      chain_type:= chains(i+2);
      if chain_type<0  or  chain_type>1 then  goto diagnos1;

    comment
      return compressed-key-size;

      chains(i+3):= 2;
      first_d_ch_addr_zb:= first_d_ch_addr_zb + f10;
      chain_part_size_zb:= chain_part_size_zb + 2;
    end  mother-file
    else
    if chains(i+1) = file_no then
    begin
    comment
      chain with the list-file as the daughter-file;

      chain_type:= chains(i+2);
      compressed_key_size:= chains(i+3);

      if chain_type<0  or  chain_type>1 then  goto diagnos1;

      if compressed_key_size<2  or
         compressed_key_size>512  or
         compressed_key_size mod 2<>0  then  goto diagnos1;
      cf_buf_ref:= cf_buf_ref + f11 + 3*2 + compressed_key_size;
      chain_part_size_zb:= chain_part_size_zb + 2
                           + chain_type * compressed_key_size;
    end  daughter-file;
  end  for  i;

comment
    check that the list-file is the daughter of at least one chain;

  if cf_buf_ref=0 then  goto diagnos1;

  first_d_ch_addr_zb:= first_m_ch_addr_zb + 2 + first_d_ch_addr_zb;

  cf_buf_ref:= first_d_ch_addr_zb + cf_buf_ref - b2;

comment
    check the size parameters;

  fixed_rec_length:= (size_l(1) + 1)//2 * 2;
  min_rec_length:= (size_l(2) + 1)//2 * 2;
  segs_per_block:= size_l(3);
  max_blocks:= size_l(4);

  if fixed_rec_length<>0 then
    min_rec_length:= fixed_rec_length;

  if min_rec_length<1 then  goto diagnos3;

  if segs_per_block<1  or  segs_per_block>8 then  goto diagnos3;

comment
    calculate recs-in-block;

  recs_in_block_zb:=
    (segs_per_block * 512 - (-f20))//
    (min_rec_length + chain_part_size_zb + 1);

  if recs_in_block_zb=0 then  goto diagnos3;

  fix_rec_size_zb:=
    if fixed_rec_length = 0 then  0
    else  fixed_rec_length + chain_part_size_zb;

  if fix_rec_size_zb=0 then
  begin
  comment
      recs-in-block are rounded up to an even number to suit the
      squeeze routine of insert-n;

    recs_in_block_zb:=
      (recs_in_block_zb + 1)//2 * 2;

  comment
      max free bytes in a list-file block;

    max_free:= segs_per_block * 512 - (-f20) - recs_in_block_zb - 2;
  end  variable record-length
  else
    max_free:= fix_rec_size_zb * recs_in_block_zb;

  if max_blocks<1  or
     max_blocks>= 8388606//recs_in_block_zb then  goto diagnos3;

  first_segs_zb:= (cf_buf_ref + b61 + 511)//512;

  segs_in_head_zb:= first_segs_zb
                    + (f18 - 2 + (max_blocks + 3)//4 * 2 + 511)//512;


begin
comment
    the inner block, where the file-head eventually is created;

  zone  z_head(first_segs_zb * 128, 1, stderror);



procedure  store(word);
value  word;
integer  word;
comment
    the procedure stores word in the zone z_head at the address
    given by the global integer k, and increments k by 2.
    The address is relative to the first byte of the current zone-
    record, i.e. the first word has got the address zero;

begin
  integer  elementno;

  elementno:= k//4 + 1;

  z_head(elementno):=
    if k mod 4 < 2 then
      0.0 shift 24 add word shift 24 add
      (z_head(elementno) extract 24)
  else
    z_head(elementno) shift (-24) shift 24 add word;

  k:= k+2;
end  store;



  open(z_head, 4, file_name, 0);

comment
    lookup the file before possible extension during outrec;
  tail(1):= 0;
  monitor(42, z_head, 0, tail); <* lookup *>

  outrec6(z_head, first_segs_zb * 512);

comment
    store 0, cf-buf-ref-rel in the first double-word;

  k:= 0;
  store(0);
  store(cf_buf_ref + 1);

comment
    store mother-chain-tables;

  k:= first_m_ch_addr_zb -2;
  store(-1);
  comment initialize dbtable address;

  chain_seq_number_tbl:= 2;
  chfld_rel_tbl:= 2;

  for i:= 1 step 4 until up do
  begin
 
    if chains(i) = file_no then
    begin
      chain_number_tbl:= (i+3)//4;

      store(-1);
      store(-1);
      store(chfld_rel_tbl);
      store(chain_number_tbl shift 12 
            add chain_seq_number_tbl);

      chain_seq_number_tbl:= chain_seq_number_tbl + 2;
      chfld_rel_tbl:= chfld_rel_tbl + 2;
    end  chains(i) = file_no;
  end  mother-chain-tables;

  store(0);

comment
    store daughter-chain-tables;

  for i:= 1 step 4 until up  do
  begin
    if chains(i+1) = file_no then
    begin
      chain_number_tbl:= (i+3)//4;

      chain_type:= chains(i+2);
      compressed_key_size:= chains(i+3);

      head_field_size_tbl:= chain_type * compressed_key_size;

      chain_addr:= k;
      next_chain_addr:= chain_addr + f11 + 3*2 + compressed_key_size;

      store(-1);
      store(-1);
      store(chfld_rel_tbl);
      store(chain_number_tbl shift 12
            add chain_seq_number_tbl);

      store(next_chain_addr - cf_buf_ref);
      store(head_field_size_tbl);

      for k:= k while k<next_chain_addr do  store(0);

      chfld_rel_tbl:= chfld_rel_tbl + 2 + head_field_size_tbl;
      chain_seq_number_tbl:= chain_seq_number_tbl + 2;
    end  chains(i+1) = file_no;
  end  daughter-chain-tables;

comment
    next_d_ch_tbl of the last chain-table should be zero;

  k:= chain_addr + 8;  store(0);

  k:= next_chain_addr;

comment
    store list-file and file-n variables;

  for i:= 1, i+1 while k<=cf_buf_ref + b61 do
  store(case i of(

    jl_x3, 
    0,
    (if fix_rec_size_zb = 0 then
      max_free
    else
      fix_rec_size_zb)
    - chain_part_size_zb,
    first_d_ch_addr_zb - cf_buf_ref,
    0,


    jl_x3,
    0,
    0,
    0,
    0,
    0,
    0,
    0,
    0,
    0,
    chain_part_size_zb,
    2,
    file_no shift 4 add 1,
    first_m_ch_addr_zb - cf_buf_ref,
    0,


    fix_rec_size_zb,
    0,
    segs_in_head_zb,
    segs_per_block,
    recs_in_block_zb,
    max_free shift 3,
    fix_rec_size_zb,
    first_segs_zb,
    segs_per_block * 512 + 2,
    max_blocks,
    0,
    0,
    0));

comment
    compute checksum in a long to avoid spill;

  sum:= long<:lst:> shift (-24);

  for i:= 1 step 1 until (cf_buf_ref + b61 + 3)//4 do
    sum:= sum -(z_head(i) shift (-24) extract 24)
              -(z_head(i) extract 24);

  k:= cf_buf_ref + b61;

  store(sum extract 24);

  for k:= k while k<first_segs_zb * 512 do  store(0);

comment
    set zeroes in the first segment of the block-table;

  outrec6(z_head, 512);

  for k:= 0, k while k<512 do  store(0);

comment
  change the length of the file to contain an integral number of blocks,
  at least one;
  i:= (tail(1) - segs_in_head_zb) // segs_per_block * segs_per_block;
  tail(1):= segs_in_head_zb
    + (if i < segs_per_block then  segs_per_block else  i);
  for i:= 2 step 1 until 10 do  tail(i):= 0;
  tail(6):= systime(7, 0, r); <* shortclock *>
  tail(9):= 23 shift 12 add 1; <* cflist *>
  monitor(44, z_head, 0, tail); <* change entry *>

  close(z_head, true);

  goto ok;
end  inner_block;


diagnos1:  alarm((i+3)//4, <:<10>chains p:>);
diagnos2:  alarm(0, <:<10>loop-ch :>);
diagnos3:  alarm(0, <:<10>size-l p:>);

ok:

  result_cf:= 1;
end  head_l;
end
▶EOF◀
DataMuseum.dk

RC4000/8000/9000

⟦4f1580f4f⟧ TextFile

Derivation

TextFile
