DataMuseum.dk

top - metrics - download

    Length: 5376 (0x1500)
    Types: TextFile
    Names: »tnewreclcf  «

└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
    └─⟦75ff9bef3⟧ 
        └─⟦this⟧ »tnewreclcf  « 

TextFile

(
head 1
if 0.yes
  newreclcf=algol list.yes survey.yes xref.yes
if 0.no
  newreclcf=algol
end
head 1
)

external
procedure  new_recl_cf(z, newlength);
value  newlength;
zone  z;
integer  newlength;
comment


  the procedure changes the length of the current master
  record.
  this is done without change of the chains connected to the
  record.

  resultcf                      current record

  1  ok                         same with new length
  2  only this rec in file      same with old length
  3  too expensive              -
  4  file is full               -
  5  length error               -
  6  only one buffer            -


  the method is the following:

  1.  copy the record and the chainpart into a local array.
  2.  delete the record after having set the chainpart to all zero.
  3.  insert the record with new length.
  4.  copy the chainpart from the local array.

  if something goes wrong the old record is reestablished.
  this should always be possible through a simple insertion.
;
\f


begin
  integer
    chain_part_size_zb,
    rec_length_pos_zb,
    rec_length_type_zb,
    save_result,
    tot_size,
    z_state;

  integer field
    ifld;

  integer array
    zd_1, zd_2(1:20);

  real array field
    oldlength;



  procedure  alarm(text, int);
  value  text, int;
  integer  text, int;
  comment

    prints a runtime alarm selected be the parameters;
  begin

    write(out, <:<10><10>***newreclcf  alarm:<10>:>);

    system(9, int, case text of(
      <:<10>cf-error:>,
      <:<10>fixed l.:>,
      <:<10>z.state :>));
  end  alarm;


\f


  procedure  setlength(rec, length);
  value  length;
  real array  rec;
  integer  length;
  comment

    inserts the second parameter as the length field of the first
    parameter;
  begin
    boolean field  bfld;
    integer field  ifld;
    long    field  lfld;
    real    field  rfld;

    bfld:= ifld:= lfld:= rfld:= rec_length_pos_zb;

    case  rec_length_type_zb//6  of
    begin
      rec.bfld:= false add length;
      rec.ifld:= length;
      rec.lfld:= length;
      rec.rfld:= length
    end;
  end  setlength;



  integer
  procedure  word(rel_addr);
  integer  rel_addr;
  comment

    the procedure returns the content of the word in z-buf with
    the absolute address:  cf_buf_ref + rel_addr.
    the rel_addr should be fetched from some b-name;
  begin
    integer field  abs_addr;

    abs_addr:= rel_addr + z(1) extract 24 + 1;
    word:= z.abs_addr;
  end  word;

\f




comment
  body of procedure newreclcf;

  getzone6(z, zd_1);
  getzone6(z, zd_2);  comment  zd_2 if kept unchanged;

  z_state:= zd_2(13);
  if z_state <> 18 and z_state <> 19 then
    alarm(3, z_state);

  oldlength:= zd_2(16);

comment
  let the zone record describe the whole zone buffer, and fetch
  constants from the file head;

  zd_1(14):= zd_2(19);    comment  rec_base:= base_buffer;
  zd_1(16):= zd_2(20)*4;  comment  rec_size:= buflength*4;
  setzone6(z, zd_1);


  chain_part_size_zb:= word(20);  comment  b9;
  rec_length_pos_zb:=  word(-2);  comment  b11;
  rec_length_type_zb:= word(-4);  comment  b10;

  if rec_length_type_zb = 0 then  alarm(2, 0);

  tot_size:= oldlength + chain_part_size_zb;

  begin
    real array
      save_rec(1:(tot_size + 3)//4);

  comment
    save the record including the chainpart;

    zd_1(14):= zd_2(14);
    zd_1(16):= tot_size;
    setzone6(z, zd_1);

    for ifld:= 2 step 2 until tot_size do
      save_rec.ifld:= z.ifld;

  comment
    put zeroes in the chainpart to avoid that deletem deletes
    the chains;

    for ifld:= 2 step 2 until chain_part_size_zb do
      z.oldlength.ifld:= 0;

  comment
    reset the zone record;
    setzone6(z, zd_2);

    deletem(z);

    if resultcf = 3 then
    begin
    comment
      only this record in the file, deletion is forbidden;
      save_result:= 2;
      goto reset_chain_part;
    end  resultcf = 3;


  comment
    insert the record with the new length;

    setlength(save_rec, newlength);

    save_result:= 1;

insert:
    insertm(z, save_rec);

    if resultcf <> 1 then
    begin

      if save_result <> 1 or resultcf = 2 then
        alarm(1, resultcf);

      save_result:= resultcf;
    comment
      insert the old record again;

      setlength(save_rec, oldlength);
      goto insert;
    end  insertion no success;


reset_chain_part:
    getzone6(z, zd_2);
  comment
    reestablish the chainpart;

    zd_1(14):= zd_2(14) + zd_2(16);  comment  chain_part_base;
    zd_1(16):= chain_part_size_zb;
    setzone6(z, zd_1);

    for ifld:= 2 step 2 until chain_part_size_zb do
      z.ifld:= save_rec.old_length.ifld;

    setzone6(z, zd_2);

    resultcf:= save_result;
  end  block with save_rec;
end  new_recl_cf;
end

▶EOF◀