$pascal '92070-1X291 REV.2001 800606'$
$heap 0$
$segment$ 
PROGRAM PFS3; 
{ 
*NAME:   PFS3 
*SOURCE: 92070-18291
*RELOC:  92070-16291
*PGMR:   DAVE NEFF
* 
****************************************************************
* (C) COPYRIGHT HEWLETT-PACKARD COMPANY, 1979. ALL RIGHTS      *
* RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED,        *
* REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT *
* THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.        *
****************************************************************
} 
  
 {PFS3 contains the procedures used for part 3 of the formatting
  process. It is in memory most of the time PFORM is running.}
{Read in global constants,types, and variables.}
 $include 'PFGBL'$
  
{External procedure definitions. Calls to FMP.} 
  
PROCEDURE readf(VAR idcb:dcb; VAR ierr:integer; VAR ibuff:buffer; 
               ilen,len,num:integer);external;
PROCEDURE close(VAR idcb:dcb);external; 
PROCEDURE locf(VAR idcb:dcb; VAR ierr,irec,irb,ioff,jsec,jlu,jty:integer);
                                                           external;
PROCEDURE writf(VAR idcb:dcb; VAR ierr:integer; VAR ibuff:buffer; 
                ilen,rec_num:integer);external; 
PROCEDURE purge(VAR idcb:dcb; VAR ierr:integer; VAR name:fname; 
                VAR isecu,icr:integer);external;
PROCEDURE open(VAR idcb:dcb; VAR ierr:integer; VAR name:fname;
               iopin,isecu,icr:integer);external; 
  
{Declaration of external assembly language routines.} 
  
FUNCTION andi(i1,i2:integer):integer;external;
FUNCTION ori(i1,i2:integer):integer;external; 
  
{rshift shifts an integer right 1 bit, and puts 0 in the high bit.} 
PROCEDURE rshift(int:integer);external; 
PROCEDURE split_namr(VAR iline:input_line; VAR len:integer; 
                     VAR name:fname; VAR security,cartridge,start_char, 
                     namr_type:integer);external; 
  
{External procedures used by PFS3,but in the main program.} 
  
FUNCTION getword(addr:integer; VAR idcb:dcb; VAR ibuff:buffer;
              VAR name:fname; VAR curr_rec:integer):integer;external; 
PROCEDURE putword(word,address:integer;VAR idcb:dcb; VAR ibuff:buffer;
                VAR name:fname; VAR curr_rec:integer; ship:boolean);
                                                       external;
PROCEDURE writline(line:input_line);external; 
PROCEDURE readline(line:input_line; len:integer);external;
  
PROCEDURE fmp_error(ierr:integer; VAR file_name:fname);external;
  
{The routines in this segment are next.}
  
  {make_word is a FUNCTION which accepts two characters, and returns
   the value of the the 16 bit integer which corresponds to the 
   first character in the upper byte and the second character in the
   lower byte.} 
  {     upper_byte:           The first character passed. 
        lower_byte:           The second character passed.} 
  FUNCTION make_word(upper_byte,lower_byte:char):integer; 
    BEGIN 
      make_word:=ori(ord(upper_byte)*256,ord(lower_byte));
    END; {make_word}
  
{right_shift is a function which rotates an integer right the 
 passed number of bits.  This function is used to adjust for
 fields rather than through the use of the DIV operator to prevent
 problems due to a possibly set bit 15 (DIV preserves sign).} 
{     num:           The integer to be rotated. 
      bits:          The number of bits to rotate.} 
FUNCTION right_shift(num,bits:integer):integer; 
  VAR 
    i,               {A loop index.}
    tnum:integer;    {The temporary and running rotation result.} 
  BEGIN {right_shift} 
    IF bits<=0 THEN right_shift:=num
      ELSE IF bits>=16 THEN right_shift:=0
        ELSE
          BEGIN 
            tnum:=num;
            FOR i:=1 to bits DO rshift(tnum); 
            right_shift:=tnum;
          END;
  END; {right_shift}
  
{getidseg uses getword to retrieve an entire idsegment from the 
 system memory image file.} 
 {     start_addr:          The starting address of the id segment
                            to be retrieved from the system image file. 
        idcb:               The dcb of the current system image.
        ibuff:              The buffer associated with the dcb. 
        name:               The name of the system image file.
        curr_rec:           The record number of the system image 
                            which corresponds to the current contents 
                            of ibuff. 
        segment:            The array which contains the returned id
                            segment.} 
  
PROCEDURE getidseg(start_addr:integer;VAR idcb:dcb; VAR ibuff:buffer; 
                 VAR name:fname; VAR curr_rec:integer; VAR segment:idseg);
  VAR 
    addr,                  {The address of the current word being retrieved 
                            from the system image.} 
    i:integer;             {Counts through the id segment to retrieve 
                            30 words.}
  BEGIN 
    io_error:=false;
    i:=0; 
  
    {Loop using getword until the entire id segment has been retrieved
     or until an FMP error occurs.} 
  
    WHILE (i<idseg_length) AND (NOT io_error) DO
      BEGIN 
        addr:=start_addr+i; 
        i:=i+1; 
        segment[i]:=getword(addr,idcb,ibuff,name,curr_rec); 
      END;
  END; {getidseg} 
  
{putidseg is the inverse of getidseg. It has the same calling 
 sequence as getidseg, and uses putword to store the words.}
  
PROCEDURE putidseg(start_addr:integer;VAR idcb:dcb;VAR ibuff:buffer;
             VAR name:fname;VAR curr_rec:integer;VAR segment:idseg);
  VAR 
    addr,                  {The address of the current word being 
                            stored into the destination system.}
    i:integer;             {Counter used for looping through the
                            id segments.} 
  BEGIN 
    io_error:=false;
    i:=0; 
  
    {Loop until the entire id segment is stored or an FMP error 
     occurs, whichever comes first.}
  
    WHILE (i<idseg_length) AND (NOT io_error) DO
      BEGIN 
        addr:=start_addr+i; 
        i:=i+1; 
        IF i<idseg_length THEN
  
        {Send out the word, but write the record only if it is a block
         boundary.} 
  
          putword(segment[i],addr,idcb,ibuff,name,curr_rec,false) 
        ELSE
  
          {Send the word and write the record.} 
  
          putword(segment[i],addr,idcb,ibuff,name,curr_rec,true); 
      END;
  END; {putidseg} 
  
  {fl_conflict is a FUNCTION which is true if the passed file name
   is the same as some other file name already in the file directory.}
  {     name:               The name of the file to check for conflicts with. 
        idcb:               The dcb of the PROM image file. 
        ibuff:              The buffer associated with idcb.
        ffde_rec:           The record number of the first file directory 
                            track.} 
  
  FUNCTION fl_conflict(VAR name:fname; VAR idcb:dcb; VAR ibuff:buffer;
                         ffde_rec:integer):boolean; 
    VAR 
      tname:ARRAY [1..3] OF integer; {name is converted from string to
                                      integer type, and stored in tname.} 
  
      {boolean type declarations.}
      conflict,                      {true if a conflict has occurred, false
                                      as long as no conflict occurs.} 
      done:boolean;                  {true when the search is done (an
                                      empty directory entry occurred),
                                      false otherwise.} 
  
      {integer type declarations.}
      cur_fde_rec,                   {The record number which contains
                                      the file directory entry currently
                                      being checked.} 
      first_track_rec,               {The record number of the starting 
                                      of the track which contains cur_fde_rec.} 
      i,                             {Counter for converting name to tname.}
      ierr,                          {Error code returned by readf calls.}
      len,                           {The actual length of the record read
                                      in a readf call.} 
      offset:integer;                {The offset into ibuff which points to 
                                      the start of the file directory entry 
                                      currently being checked.} 
  BEGIN 
  
    {Initialize the local variables.} 
  
    cur_fde_rec:=ffde_rec;
    first_track_rec:=ffde_rec;
    conflict:=false;
    done:=false;
  
    {Have the offset point past the entry for the cartridge itself, 
     thus pointing to the actual first file directory entrty.}
  
    offset:=fdir_length+1;
  
    {Convert name to an integer array.} 
    FOR i:=1 to 3 DO
      tname[i]:=make_word(name[i*2-1],name[i*2]); 
  
    {Get the first file directory record.}
  
    readf(idcb,ierr,ibuff,recd_len,len,ffde_rec); 
  
    {Loop until a conflict or an empty directory entry is found.} 
    {An empty entry should start with -1 since the file was filled
     with -1.}
  
    WHILE NOT (conflict OR done) DO 
      BEGIN 
        IF (ibuff[offset]  =tname[1]) AND 
           (ibuff[offset+1]=tname[2]) AND 
           (ibuff[offset+2]=tname[3]) THEN
           conflict:=true 
          ELSE IF ibuff[offset]=-1 THEN done:=true; 
        IF NOT (conflict OR done) THEN
          BEGIN 
  
            {Make the offset point to the next directory entry.}
  
            offset:=offset+fdir_length; 
            IF offset>recd_len THEN 
              BEGIN 
  
                {Must get a new record.}
  
                offset:=1;
                cur_fde_rec:=cur_fde_rec+1; 
  
                {Check to see if the new current record is off the
                 current track.  If so, adjust the pointers accordingly.} 
  
                IF ((cur_fde_rec-first_track_rec)=recs_per_track) THEN
                  BEGIN 
                    {Must move to the next file directory track.} 
                    first_track_rec:=first_track_rec-recs_per_track;
                    cur_fde_rec:=first_track_rec; 
                  END;
  
                {Get the next record.}
                readf(idcb,ierr,ibuff,recd_len,len,cur_fde_rec);
              END;
          END;
      END;
    fl_conflict:=conflict;
  END; {fl_conflict}
  
{rt_conflict is a function which is true if the passed skel_ids 
 specifies base page, main, or segment addresses which conflict with
 a current id segment in the system image.  The function is false 
 if the skel_ids would be rp'd into the background partition,or there 
 are no conflicts.} 
{     start_addr:            The starting address in the system image 
                             file which points to the beginning of the
                             array of 30 word id segments.
      idcb:                  The dcb of the system image file.
      ibuff:                 The buffer associated with the system dcb. 
                             Type 1 access is used. 
      name:                  The name of the system image file. 
      curr_rec:              The record number which the current contents 
                             of ibuff correspond to.
      skel_ids:              The first 34 words of the header of the
                             type 6 file being checked for conflicts. 
      free_addr:             The address of the first free id segment 
                             availiable.  It is zero if all id segments 
                             are used, and it is -1 if the name in the
                             skeleton id segment is the same as a name
                             already RP'd.} 
  
FUNCTION rt_conflict(start_addr:integer; VAR idcb:dcb; VAR ibuff
                     :buffer;VAR name:fname; VAR curr_rec:integer;
                     VAR skel_ids:lo_idseg; VAR free_addr:integer)
                                                         :boolean;
  VAR 
  
    {boolean TYPE declarations.}
    first_free_found,       {true when an availiable id segment has 
                             been found in the system image, false
                             otherwise.}
    real_time,              {true when the skeleton id segment passed 
                             to the routine corresponds to the real 
                             time partition of the system, false if 
                             the skeleton id segment corresponds to 
                             the background partition.} 
    temp_rt_con:boolean;    {true when a conflict has been found with 
                             currently RP'd real time programs, false 
                             as long as no conflicts are found. Upon
                             return, rt_conflict is assigned this value.} 
  
   {idseg type declaration.}
    curr_ids:idseg;         {The current id segment of the system image 
                             which is being tested.}
  
    {integer types are declared next.}
    curr_bpl,               {The low base page address of the id segment
                             from the system image currently being checked.}
    curr_bph,               {The high base page address of the id segment 
                             from the system image currently being checked.}
    curr_high,              {The high main address of the id segment from 
                             the system image currently being checked.} 
    curr_low,               {The low main address of the idsegment from 
                             the system image currently being checked.} 
    curr_num_segs,          {The number of segments of the id segment from
                             the system image being searched.}
    i,                      {Counts the number of id segments from
                             the system image which have been checked out.} 
   new_bpl,                 {The low base page address from the skeleton
                             id segment passed to the routine.} 
   new_bph,                 {The high base page address from the skeleton 
                             id segment.} 
   new_high,                {The high main address from the skeleton id 
                             segment.}
   new_low,                 {The low main address from the skeleton id
                             segment.}
   new_num_segs:integer;    {The number of segments the skeleton id segment 
                             specifies.}
  
  BEGIN 
  
    {Get the address information from the passed skeleton id segment.}
  
    new_low:=skel_ids[21];
    new_num_segs:=right_shift(skel_ids[24],10); 
    IF new_num_segs>0 THEN
      BEGIN 
  
        {Program to be checked is segmented.} 
  
        new_high:=skel_ids[33]-1; {This includes maximum segment extent}
        new_bph:=skel_ids[34]-1;
        new_bpl:=andi(skel_ids[24],1023); 
      END 
    ELSE
      BEGIN 
  
        {Current program is unsegmented.} 
  
        new_high:=skel_ids[22]-1; 
        new_bph:=skel_ids[25]-1;
        new_bpl:=skel_ids[24];
      END;
    free_addr:=0; 
    i:=0; 
    first_free_found:=false;
    temp_rt_con:=false; 
    WHILE (I<id_num) AND (NOT temp_rt_con) DO 
      BEGIN 
  
        {Loop until a conflict or all id segments have been checked.} 
  
        i:=i+1; 
        getidseg(start_addr,idcb,ibuff,name,curr_rec,curr_ids); 
        IF (curr_ids[1]=0) AND (NOT first_free_found) THEN
          BEGIN 
  
            {A free id segment is found, save the address.} 
  
            first_free_found:=true; 
            free_addr:=start_addr;
          END;
  
        {Have start_addr point to the next address.}
  
        start_addr:=start_addr+idseg_length;
        curr_low:=curr_ids[21]; 
        curr_num_segs:=right_shift(curr_ids[24],10);
  
        {Is program relocated for the realtime partition?}
  
        IF curr_low>=fwbg THEN
          real_time:=false
        ELSE
          real_time:=true;
        IF real_time AND (curr_num_segs>0) THEN 
          BEGIN 
  
            {Only one real time can be segmented. By definition, it 
             must be the last real time in the partition, and its 
             highest segment address is therefore the last word of the
             real time partition.}
  
            curr_high:=fwbg-1;
            curr_bph:=bgbp-1; 
            curr_bpl:=andi(curr_ids[24],1023);
          END 
        ELSE IF real_time THEN
          BEGIN 
  
            {Current idseg from system image is an unsegmented real time.}
  
            curr_high:=curr_ids[23]-1;
            curr_bph:=(andi(curr_ids[25],1023)-1);
            curr_bpl:=curr_ids[24]; 
          END;
        {Check for conflict due to same name already RP'd.} 
        IF (curr_ids[13]=skel_ids[13]) AND
           (curr_ids[14]=skel_ids[14]) AND
           (curr_ids[15]=skel_ids[15]) THEN 
          BEGIN 
            temp_rt_con:=true;
            free_addr:=-1;
          END 
        ELSE
  
          {Real time programs may have address conflicts. Check bounds.}
  
          IF real_time THEN 
            BEGIN 
              IF (((new_low<=curr_high) AND (new_low>=curr_low)) OR 
                  ((new_high<=curr_high) AND (new_high>=curr_low))) 
                THEN temp_rt_con:=true; 
              IF (((new_bpl<=curr_bph) AND (new_bpl>=curr_bpl)) OR
                  ((new_bph<=curr_bph) AND (new_bph>=curr_bpl)))
                THEN temp_rt_con:=true; 
            END;
      END;
    rt_conflict:=temp_rt_con; 
  END;  {rt_conflict} 
  
{convrt_seg accepts a short id segment number (starting at 1) 
 and returns its record number and offset of the ibuff. 
 For example, if segnum is 2, convrt_seg will return recnum=2 
 and offset=9.} 
{     segnum:             The number of the short id segment
                          of which information is desired.
      recnum:             The returned record number which
                          contains the segment number specified 
                          by segnum.
      offset:             The offset (starting at 1) of the 
                          above segnum in the above recnum.}
  
PROCEDURE convrt_seg(segnum:integer;VAR recnum,offset:integer); 
  BEGIN 
    recnum:=((segnum*short_idseg_length-1) DIV recd_len)+2; 
    offset:=((segnum-1) MOD (recd_len DIV short_idseg_length))
            *short_idseg_length;
    offset:=offset+1; 
  END; {convrt_seg} 
  
{getshort_ids gets a short id segment from the specified file,
 and returns the segment in sids (passed by name).} 
{     segnum:             The number of the segment to be retrieved.
      idcb:               The dcb of the memory image file which
                          contains the short id segment desired.
      ibuff:              The buffer associated with the above idcb.
      name:               The name of the file which contains the 
                          short id segment desired. 
      curr_rec:           The record number which the current contents
                          of ibuff corresponds to.
      sids:               The short id segment returned by the routine.}
  
PROCEDURE getshort_ids(segnum:integer; VAR idcb:dcb; VAR ibuff:buffer;
                       VAR name:fname; VAR curr_rec:integer;
                       VAR sids:sh_idseg);
  VAR 
    {integer declarations.} 
    i,                   {Counter used for moving the contents of ibuff 
                          into a short idsegment structure.}
    ierr,                {The ierr code returned by FMP calls.} 
    len,                 {The actual length of a record, read, required 
                          for calls to readf.}
    offset,              {The offset passed to convrt_seg.} 
    recnum:integer;      {The record number passed to convrt_seg.}
  
  BEGIN 
    convrt_seg(segnum,recnum,offset); 
    IF recnum<>curr_rec THEN
      BEGIN 
  
        {Its a miss. Get the correct record,update curr_rec.} 
  
        readf(idcb,ierr,ibuff,recd_len,len,recnum); 
        IF ierr<0 THEN fmp_error(ierr,name) 
          ELSE curr_rec:=recnum;
      END;
    IF ierr>=0 THEN 
      FOR i:=1 TO short_idseg_length DO 
        sids[i]:=ibuff[i+offset-1]; 
  END; {getshort_ids} 
  
{calc_checksum calculates and stores the checksum of a short idseg} 
{     sids:          The short id segment to compute the checksum for.} 
  
PROCEDURE calc_checksum(VAR sids:sh_idseg); 
  VAR 
    {integer type declarations.}
    csw,             {Variable which counts to the checksum word.}
    i:integer;       {Index into the short id segment, which counts 
                      through the sids.}
  
  BEGIN 
    csw:=0; 
    FOR i:=1 TO (short_idseg_length-1) DO 
      csw:=csw+sids[i]; 
    sids[short_idseg_length]:=csw;
  END; {calc_checksum}
  
{rec_to_ts converts the record number passed by value in rec
 into the appropriate values of track and sector.}
{     rec:             The number of the record in the output (PROM image)
                       file, which is to be converted into track, sector
                       information. 
      track:           The track corresponding to the record. 
      sector:          The sector corresponding to the record.} 
  
PROCEDURE rec_to_ts(rec:integer;VAR track,sector:integer);
  BEGIN 
    sector:=((rec-1)*2) MOD sect_per_track; 
    track:=(rec-1) DIV recs_per_track;
  END;{rec_to_ts} 
  
{recd_to_tb converts the passed record number into its track
 and logical block number on the PROM disk. A block is like a record
 (2 sectors) but is device, not file, relative.}
{     rec:              The number of the PROM image record which 
                        is to be converted. 
      track:            The record's corresponding track. 
      block:            The record's corresponding block.}
  
PROCEDURE recd_to_tb(rec:integer; VAR track,block:integer); 
  BEGIN 
    block:=(rec-1) MOD recs_per_track;
    track:=(rec-1) DIV recs_per_track;
  END;{recd_to_tb}
  
{rec_extent is a function which accepts a low address and 
 a high address plus one, and calculates the number of file 
 records such address would extend. The function is used for
 rp-ing a file.}
{     lo_addr:         The low address of the extent. 
      hi_addrp1:       The high address plus one of the extent.}
  
FUNCTION rec_extent(lo_addr,hi_addrp1:integer):integer; 
  VAR 
    {integer declarations.} 
    num_recs,          {The number of records which the addresses extend.}
    num_words,         {The number of words which the addresses extend.}
    remainder:integer; {The number of words in the last record of the 
                        extent.}
  
  BEGIN 
    num_words:=hi_addrp1-lo_addr; 
    num_recs:=num_words DIV recd_len; 
  
    {Find out if there are any remaining words the above
     calculations did not take into account.} 
  
    remainder:=num_words MOD recd_len;
    IF remainder>0 THEN 
  
      {There is one record which the extent partially encompasses.} 
  
      num_recs:=num_recs+1; 
    rec_extent:=num_recs; 
  END; {rec_extent} 
  
{putfde writes a file directory entry into the output file.}
{     entry_num:           The entry number of the file directory.
                           Numbering starts with 1. 
      idcb:                The dcb of the PROM image file.
      ibuff:               The buffer associated with idcb. 
      name:                The PROM image file name.
      start_rec:           The starting record number of the file 
                           directory track the entry is to be 
                           stored on. 
      fde:                 The 16 word file directory entry itself.}
  
PROCEDURE putfde(entry_num:integer; VAR idcb:dcb; ibuff:buffer; 
                 VAR name:fname; start_rec:integer; 
                 VAR fde:file_directory); 
  VAR 
    {integer type declarations.}
    i,              {The index which is used to transfer fde into ibuff.} 
    ierr,           {The error code returned by FMP calls.} 
    len,            {The actual length of the record read, required for 
                     readf calls.}
    offset,         {The offset of the fde in ibuff.} 
    recnum:integer; {The record number which contains the space for the fde.} 
  
  BEGIN 
  
    {Compute the record number using the following simple formula.} 
  
    recnum:=start_rec+((entry_num*fdir_length-1) DIV recd_len); 
    readf(idcb,ierr,ibuff,recd_len,len,recnum); 
    IF ierr<0 THEN fmp_error(ierr,name) 
    ELSE
      BEGIN 
  
        {Put the directory entry at the correct place in the outfile.}