$pascal '92071-1X292 REV.2041  800819'$ 
$heap 0$
$segment$ 
PROGRAM PFS4; 
{ 
* 
*NAME:    PFS4
*SOURCE:  92071-18292 
*RELOC:   92071-16293 
*PGMR:    DAVE NEFF 
* 
****************************************************************
* (C) COPYRIGHT HEWLETT-PACKARD COMPANY, 1980. 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.        *
****************************************************************
} 
  
{PFS4 contains the routines involved with tranfering files to the 
 PROM image.  check_file_for_errors finds errors associated with all
 files (fmp, duplicate directory entries, etc.).  relink_check
 determines if the program must be relinked, but the actual relink
 is performed in segment 5 to provide a large relink table.}
 {Read in the global constants, variables and types.} 
$include '&PFGBL'$
  
{Declaration of FMP routines.}
  
PROCEDURE close(VAR idcb:dcb);external; 
PROCEDURE purge(VAR idcb:dcb; VAR ierr:integer; VAR name:string6; 
                VAR isecu,icrn:integer);external; 
PROCEDURE readf(VAR idcb:dcb; VAR ierr:integer; VAR ibuff:buffer; 
                ilen:integer;  VAR len:integer; num:integer);external;
PROCEDURE writf(VAR idcb:dcb; VAR ierr:integer; VAR ibuff:buffer; 
          ilen,rec_num:integer);external; 
PROCEDURE locf(VAR idcb:dcb; VAR ierr,irec,irb,ioff,jsec,jlu,jty, 
                                               jrec:integer);external;
PROCEDURE open(VAR idcb:dcb; VAR ierr:integer; VAR name:string6;
               iopin,isecu,icr:integer);external; 
  
{Non FMP externals contained in the main program are next.} 
  
PROCEDURE namr(VAR buffer:namr_parse_buffer; VAR iline:input_line;
               length:integer; VAR istrc:integer);external; 
PROCEDURE error(message:input_line);external; 
PROCEDURE writline(line:input_line);external; 
FUNCTION getword(address:integer; VAR idcb:dcb; VAR ibuff:buffer; 
                 VAR name:string6; VAR curr_rec:integer):integer; 
                                                         external;
PROCEDURE putword(word,address:integer; VAR idcb:dcb; VAR ibuff:buffer; 
              VAR name:string6; VAR curr_rec:integer;post:boolean); 
                                                                  external; 
PROCEDURE fmp_error(VAR ierr:integer; VAR name:string6);external; 
  
{scratch_to_system purges the scratch copy of the system file,
 and makes the new system dcb the current prom file dcb.} 
PROCEDURE scratch_to_system; $direct$ 
  BEGIN 
    purge(sys_dcb,ierr,sys_file,sys_secu,sys_crn);
  
    {Make the current prom image file the new system file 
     so future system mods take place correctly.} 
  
    sys_dcb:=prom_dcb;
    sys_file:=prom_file;
    sys_crn:=prom_crn;
    sys_secu:=prom_secu;
  
    cur_prom_file_rec:=sys_len+1; 
   {The bootable_current_file now has no meaning since for
    all practical purposes the system is a file on the prom.} 
  
   bootable_current_file:=false;
  
 END; 
  
{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:string6; 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 
    i:=0; 
  
    {Loop using getword until the entire id segment has been retrieved
     or until a fatal FMP error occurs.}
  
    WHILE (i<idseg_length) AND (NOT abort) DO 
      BEGIN 
        addr:=start_addr+i; 
        i:=i+1; 
        segment.ints[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:string6;VAR curr_rec:integer;VAR segment:idseg);
  VAR 
    post:boolean;          {Tells putword to post its buffer when true.}
    addr,                  {The address of the current word being 
                            stored into the destination system.}
    i:integer;             {Counter used for looping through the
                            id segments.} 
  BEGIN 
    i:=0; 
  
    {Loop until the entire id segment is stored or an FMP error 
     occurs, whichever comes first.}
  
    post:=false;
    WHILE (i<idseg_length) AND (NOT abort) DO 
      BEGIN 
        addr:=start_addr+i; 
        i:=i+1; 
        IF i<idseg_length THEN post:=true;
  
        {Send out the word, but write the record only if it is a block
         boundary or last putword.} 
  
        putword(segment.ints[i],addr,idcb,ibuff,name,curr_rec,post) 
      END;
  END; {putidseg} 
  
{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_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} 
  
{ts_to_rec is the inverse of rec_to_ts} 
{     track:            The passed track number.
      sector:           The passes sector.
 No global variable are modified.}
FUNCTION ts_to_rec(track,sector:integer):integer; 
  BEGIN 
    ts_to_rec:=(track*recs_per_track) + (sector DIV 2) +1;
  END;
  
{fde_num_to_rec_index is a routine which accepts a file 
 directory entry number and calculates the corresponding
 record and directory entry index where the entry should
 be retrieved or stored from prom.} 
{    fde_num:           The passed directory entry number.
     rec:               The returned record number. 
     index:             The index of the entry within the record. 
 No globals are modified.}
PROCEDURE fde_num_to_rec_index(VAR fde_num,rec,index:integer);
  VAR 
    dt_num,            {The directory track holding the entry.} 
    fde_on_track,      {The fde entry which is relative to the
                        current directory track.} 
    first_rec_on_track,{First record corresponding to the 
                        start of the directory track.}
    prom_track:integer;{The prom image file track where the 
                        desired entry is to be found.}
  
  BEGIN 
  
    {Calculate directory track number holding the entry.} 
  
    dt_num:=(fde_num-1) DIV fdir_entries_per_track; 
    fde_on_track:=(fde_num-1) MOD fdir_entries_per_track+1; 
    prom_track:=num_tracks-dt_num-1;
  
    {Calculate the record where the track begins.}
  
    first_rec_on_track:=prom_track*recs_per_track+1;
  
    {Calculate the returned params.}
  
    rec:=first_rec_on_track+((fde_on_track-1) DIV fdirs_per_rec); 
    index:=((fde_on_track-1) MOD fdirs_per_rec)+1;
  END; {fde_num_to_rec_index} 
{putfde writes a file directory entry into the output file.}
{It has a call sequence which is analagous to putword.} 
{     fde:                 The file directory entry.
      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.
      curr_rec:            The record number of the file currently
                           stored in ibuff. 
      post:                Boolean, true when the buffer is to
                           be posted.  A putfde call automatically
                           posts the buffer when a record boundary
                           is detected, allowing convenient 
                           sequential stores.}
PROCEDURE putfde(VAR fde:directory_entry; entry_num:integer;
                 VAR idcb:dcb; VAR ibuff:buffer; VAR name:string6;
                 VAR curr_rec:integer;  post:boolean);
  LABEL 99; 
  VAR 
    {integer type declarations.}
    ierr,           {The error code returned by FMP calls.} 
    index,          {Index of the entry within the record.} 
    recnum:integer; {The record number which contains the space for the fde.} 
  
  BEGIN 
  
    {Figure out the needed record number and file index.} 
  
    fde_num_to_rec_index(entry_num,recnum,index); 
  
    IF recnum<>curr_rec THEN {Must get record from disk.} 
      BEGIN 
        readf(idcb,ierr,idcb.buff,recd_len,irec,recnum);
        IF ierr<0 THEN
          BEGIN 
             fmp_error(ierr,name);
             goto 99; 
           END; 
  
         {Update the curr_rec indicator.} 
  
         curr_rec:=recnum;
       END; 
    {Put the directory entry at the correct place in the outfile.}
    idcb.file_entries[index]:=fde;
  
    IF post OR (index=fdirs_per_rec) THEN 
      BEGIN 
  
        {Must write the buffer to disk.}
        writf(idcb,ierr,idcb.buff,recd_len,recnum); 
        IF ierr<0 THEN fmp_error(ierr,name);
      END;
99: 
  END; {putfde} 
  
{getfde  reads a file directory entry from the prom image file.}
{It has a call sequence which is analagous to putword, but it 
 is not a function.}
{     fde:                 The file directory entry returned. 
      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.
      curr_rec:            The record number of the file currently
                           stored in ibuff.}
PROCEDURE getfde(VAR fde:directory_entry; entry_num:integer;
                 VAR idcb:dcb; VAR ibuff:buffer; VAR name:string6;
                 VAR curr_rec:integer); 
  LABEL 99; 
  VAR 
    {integer type declarations.}
    ierr,           {The error code returned by FMP calls.} 
    index,          {Index of the entry within the record.} 
    recnum:integer; {The record number which contains the space for the fde.} 
  
  BEGIN 
  
    {Figure out the needed record number and file index.} 
  
    fde_num_to_rec_index(entry_num,recnum,index); 
  
    IF recnum<>curr_rec THEN {Must get record from disk.} 
      BEGIN 
        readf(idcb,ierr,idcb.buff,recd_len,irec,recnum);
        IF ierr<0 THEN
          BEGIN 
             fmp_error(ierr,name);
             goto 99; 
           END; 
         curr_rec:=recnum;
       END; 
    {Get the directory entry at the correct place in the outfile.}
    fde:=idcb.file_entries[index];
  
99: 
  END; {getfde} 
  
  {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.}
  {     test_entry:         The directory entry to be checked for conflicts.
        dupl_entry:         Any file entry with the same name as the one
                            passed is returned here.  This paramater
                            is always changed.  This return allows
                            handling the RP,file,newname cases.}
  
  FUNCTION fl_conflict(VAR test_entry,dupl_entry:directory_entry):boolean;
    VAR 
      {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.} 
  
      entry_number:integer;             {The current entry in the directory 
                                      being checked.} 
  BEGIN 
  
    {Initialize the local variables.} 
  
    conflict:=false;
    done:=false;
  
    {Have the offset point past the entry for the cartridge itself, 
     thus pointing to the actual first file directory entrty.}
  
    entry_number:=1;
  
    {Ensure a disk access takes place on the first getfde call.}
  
    rec_in_prom_dcb:=0; 
  
    {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 
  
        {Point to the next entry number.} 
  
        entry_number:=entry_number+1; 
  
        {Get the entry.}
  
        getfde(dupl_entry,entry_number,prom_dcb,prom_dcb.buff,prom_file,
              rec_in_prom_dcb); 
        IF (dupl_entry.files.name=test_entry.files.name)
          THEN conflict:=true 
  
          ELSE IF (dupl_entry.ints[1]=-1) OR (entry_number=cur_fde_num) 
                  THEN done:=true;
      END;
    fl_conflict:=conflict;
  END; {fl_conflict}
  
{check_file_for_errors is a boolean function which tries to find
 all the general error cases associated with storing the file 
 onto the PROM. These include fmp_errors at open time, duplicate file 
 entries, and insufficient space on the prom for storing the file.  If
 no errors occur, the file will be left open and check_file_for_errors
 will return true.  If some error occurs, check_file_for_errors is false, 
 and the file is closed. If there are no errors, the routine defines
 the file directory entry for the file. The routine is not called when
 the last command was RP, since rp_error_check is used instead.}
FUNCTION check_file_for_errors:boolean; $direct$
  LABEL 99; 
  CONST 
    overflow='OVERFLOW OF MEMORY';
    duplicate_file='DUPLICATE FILE NAME'; 
    not_type_6='INCORRECT FILE TYPE'; 
  VAR 
  
    irb,             {locf paramater (next block).} 
    ioff,            {offset returned by locf.} 
    jlu,             {lu returned by locf.} 
    jrec,            {record length returned by locf.}
    jty,             {type returned by locf.} 
    jsec:integer;    {number of sectors in file returned by locf.}
  BEGIN 
  
    {Initially,assume some error occurs.} 
    check_file_for_errors:=false; 
    done_with_rp:=false;
  
    {Initialize the first_prom_file_rec indicator for possible recovery 
     from errors some records have been moved to the PROM.  Such errors 
     are typically very oddball, (i.e. disk errors, track offset overflows).} 
  
    first_prom_file_rec:=cur_prom_file_rec; 
    cur_file_rec:=1;
    {Get the file name.}
  
    namr(namr_buffer,inline,line_length,istrc); 
  
    IF namr_buffer.types.param1<>ascii THEN 
      BEGIN 
        error(bad_type);
        goto 99;
      END;
  
    file_name:=namr_buffer.param1;
    {Open the file once to get its original type.}
  
    WITH namr_buffer DO 
    open(file_dcb,ierr,file_name,0,param2.int,param3.int);
  
    IF ierr<0 THEN
      BEGIN 
        fmp_error(ierr,file_name);
        goto 99;
      END;
  
    {ierr has the file type, put it in its directory entry.}
    directory.files.file_type:=ierr;
  
    {Must close the file and reopen forced to type 1 access.} 
  
    close(file_dcb);
  
    WITH namr_buffer DO 
    open(file_dcb,ierr,file_name,4,param2.int,param3.int);
  
    IF ierr<0 THEN
      BEGIN 
        fmp_error(ierr,file_name);
        goto 99;
      END;
  
  
    {The actual file size depends upon the last command given 
     and the mapping attributes of the destination system.} 
  
    IF (last_command.command<>'FI') THEN
      BEGIN 
  
        {Must insure the file is type 6 so the information
         returned by the below readf call is not misinterpreted.} 
  
        IF directory.files.file_type<>6 THEN
          BEGIN 
  
            error(not_type_6);
            goto 99;
          END;
  
        {The file size to store on the PROM must be obtained from 
         the file in the mapped case header.  This is to keep the 
         the loader relink table off of 
         the PROM.  Once stored onto the PROM, relinking is 
         impossible, so the relink table wastes prom space.}
  
        readf(file_dcb,ierr,file_dcb.buff,recd_len,irec,1); 
  
  
        IF ierr<0 THEN
          BEGIN 
            fmp_error(ierr,file_name);
            close(file_dcb);
            goto 99;
          END;
  
        {Initialize the pointer to the header of the most recent
         program stored on prom.} 
  
        first_prog_rec:=cur_prom_file_rec;
      END;
  
   {Call locf to pick up original file length, and its lu.} 
   locf(file_dcb,ierr,irec,irb,ioff,jsec,jlu,jty,jrec); 
   IF mapped_system AND (last_command.command<>'FI') THEN 
     BEGIN
      file_length:=file_dcb.l20_long_id.ext.last_prog_rec;
  
      {Calculate minimum partition required by the program.}
  
      min_prog_size:=file_length DIV recds_per_k; 
  
      {Round up if needed.} 
  
      IF (file_length MOD recds_per_k) <> 0 THEN
        min_prog_size:=min_prog_size+1; 
    END 
    ELSE {Last command was 'FI' or system is unmapped.} 
      BEGIN 
  
        {Use the length returned by locf.}
  
        file_length:=jsec DIV 2;
  
      END;
    {Initialize the directory entry.} 
    WITH directory.files DO 
      BEGIN 
  
        name:=file_name.file_name;
        rec_to_ts(cur_prom_file_rec,cur_track,cur_sector);
        starting_track:=cur_track;
        starting_sector:=cur_sector;
        record_length:=jrec;
  
        IF namr_buffer.param2.int=0 THEN
          {No security code was given, so insert an arbitrary 
           positive code to lessen the chance of successful FMP 
           writes to the prom.} 
          namr_buffer.param2.int:=1010; 
  
        security_code:=namr_buffer.param2.int;
        file_size_times_2:=file_length*2; 
  
        {Put original lu in open flag 1 if and only if the last command 
         was RP.  This allows distinguishing the duplicate file 
         error from a RP,file,newname command.} 
  
        IF last_command.command='RP' THEN 
          open_flags[1]:=jlu; 
      END;
  
    {See if there is a duplicate file with this same name.} 
  
    IF fl_conflict(directory,conflicting_entry) THEN
      BEGIN 
  
        IF (last_command.command<>'RP') OR ((last_command.command='RP') 
         AND (directory.files.open_flags[1]<>conflicting_entry.files. 
                                                              open_flags[1])) 
       THEN {A duplicate file entry occurred.}
         BEGIN
           error(duplicate_file); 
           close(file_dcb); 
           goto 99; 
         END
       ELSE {Assume the command is an rp,file,newname case, 
             and a previous RP,file must have occurred successfuly
             since the file entry conflict was detected.
             The actual RP will be handled in rp_error_check.}
         done_with_rp:=true;
     END; 
  
    {Make sure there is room to store the file on the prom.}
  
    IF ((cur_prom_file_rec+file_length-1)>last_prom_file_rec) 
       AND NOT done_with_rp THEN
      BEGIN 
  
        {Storing the file would overlay the directory track.} 
        error(overflow);
        close(file_dcb);
        goto 99;
      END;
  
    {No errors were deteced.  Return check_file_for_errors true.} 
    check_file_for_errors:=true;
 99:
  END; {check_file_for_errors}
  
{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. This routine is only called if the original system 
 is not mapped.}
{     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.
      name:                  The name of the system image file. 
      curr_rec:              The record number which the current contents 
                             of ibuff correspond to.
      skel_ids:              The long id segment from 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 name:string6; VAR curr_rec:integer;
                   VAR skel_ids:long_id_l10; 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_bph,                {High base page address of the current 
                              id being checked out.}
    curr_high,               {High main address of the current id being 
                              checked out.} 
    i,                       {Counts the number of id segments from 
                              the system image which have been scanned.}
    new_bph,                 {High base page address from the skeleton id.} 
    new_high:integer;        {High main address from the skeleton id.}
  BEGIN 
  
  
    IF skel_ids.id.number_of_segments>0 THEN
      BEGIN 
        {Program to be checked is segmented.} 
  
        new_high:=skel_ids.ext.high_seg_addr_plus1-1; 
        new_bph:=skel_ids.ext.high_base_page_addr_plus1-1;
      END 
    ELSE
      BEGIN 
  
        {Current program is unsegmented.} 
  
        new_high:=skel_ids.id.high_main_addr_plus1-1; 
        new_bph:=skel_ids.id.high_base_page_addr_plus1-1; 
      END;
    free_addr:=0; 
    i:=0; 
    first_free_found:=false;
    temp_rt_con:=false; 
  
    {Scan until a conflict occurs.} 
    WHILE (I<id_num) AND (NOT temp_rt_con) DO 
      BEGIN 
  
        i:=i+1; 
        getidseg(start_addr,idcb,idcb.buff,name,curr_rec,curr_ids); 
        IF (curr_ids.ints[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;
        {Is program relocated for the realtime partition?}
  
        IF curr_ids.l10.low_main_addr>=fwbg THEN
          real_time:=false
        ELSE
          real_time:=true;
        IF real_time AND (curr_ids.l10.number_of_segments>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; 
          END 
        ELSE IF real_time THEN
          BEGIN 
  
            {Current idseg from system image is an unsegmented real time.}
  
            curr_high:=curr_ids.l10.high_main_addr_plus1-1; 
            curr_bph:=curr_ids.l10.high_base_page_addr_plus1-1; 
          END;
        {Check for conflict due to same name already RP'd.} 
        IF (curr_ids.l10.name=skel_ids.id.name) 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 (((skel_ids.id.low_main_addr<=curr_high) AND 
                 (skel_ids.id.low_main_addr>=curr_ids.l10.low_main_addr)) 
                                        OR
          ((new_high<=curr_high) AND (new_high>=curr_ids.l10.low_main_addr))) 
                THEN temp_rt_con:=true; 
              IF (((skel_ids.id.low_base_page_addr<=curr_bph) AND 
          (skel_ids.id.low_base_page_addr>=curr_ids.l10.low_base_page_addr))
                                      OR
       ((new_bph<=curr_bph) AND (new_bph>=curr_ids.l10.low_base_page_addr)))
                THEN temp_rt_con:=true; 
            END;
      END;
    rt_conflict:=temp_rt_con; 
  END;  {rt_conflict} 
  
{name_conflict is analogous to rt_conflict for the mapped system
 case.  It only checks for errors due to previous rp of same file name.}
{Calling paramaters are identical in meaning to rt_conflict.} 
FUNCTION name_conflict(start_addr:integer; VAR idcb:dcb;
                       VAR name:string6; VAR curr_rec:integer;
                       VAR skel_ids:long_id_l20; VAR free_addr:integer):
                                                               boolean; 
  VAR 
  free_id_found,        {True when a free id was found. Ids are 
                         always defined sequentially by generator, BUILD, 
                         and PFORM.}
  temp_name_conflict:boolean; {True when a name conflict occurred.} 
  
  curr_ids:idseg;       {Contains the id beind scanned.}
  
  i:integer;            {Counter for scanning ids.} 
  BEGIN 
  
    {Set up defaults.}
    free_addr:=0; 
    temp_name_conflict:=false;
    i:=0; 
    free_id_found:=false; 
  
    {Scan all defined ids.} 
  
    WHILE (i<id_num) AND NOT (temp_name_conflict OR free_id_found) DO 
      BEGIN 
  
        i:=i+1; 
        getidseg(start_addr,idcb,idcb.buff,name,curr_rec,curr_ids); 
        IF curr_ids.ints[13]=0 THEN 
          BEGIN 
  
            {The id is free.  Return its correct address.}
  
            free_addr:=start_addr;
            free_id_found:=true;
          END 
        ELSE IF curr_ids.l20.name=skel_ids.id.name THEN 
          BEGIN 
  
            {A name conflict occurs.} 
  
            temp_name_conflict:=true; 
  
            {This next assignment is not absolutely necessary,
             but it just makes the routine more analogous to
             rt_conflict.}
  
            free_addr:=-1;
          END;
  
        {Point to next id.} 
        start_addr:=start_addr+idseg_length;
      END;
    name_conflict:=temp_name_conflict;
  END; {name_conflict}
  
  
{rp_error_check makes sure there are no name conflicts
 with previously rped programs.  In the unmapped case, a check
 is also made to insure there are no conflicts with realtime
 programs previously rp'd. The check returns true when no errors
 occur.  When true, cur_id_addr will point to the next free 
 id.} 
FUNCTION rp_error_check:boolean; $direct$ 
  LABEL 99; 
  CONST 
    cant_rp='CAN NOT RP PROGRAM'; 
    no_free_ids='NO FREE ID SEGMENTS';
    previous_rp='PREVIOUS RP OF SAME FILE NAME';
  VAR 
    found_old_id:boolean;   {True when the old id corresponding 
                             to a newname RP has been found.} 
    temp_idseg:idseg;    {Id segment retrieved for the RP,file, 
                          newname handling.}
    i,              {A loop index}
    irec,           {Record length returned by readf} 
    temp_id_addr,   {Temporary id segment address used for
                     handling the RP,file,newname case.}
    track_to_match, {The track of the program on the prom 
                     for a newname RP.} 
    block_to_match:integer; {The block of the program 
                              on the prom for a newname RP.}
  BEGIN 
  
    {Initially assume an error occured.}
  
    rp_error_check:=false;
  
    {The file header was always read by check_file_for_errors,
     when the last command was RP or LK.  Hence file_dcb.buffer 
     contains an in memory id in all cases when this routine is 
     called.} 
  
    {See if the user gave a new name.}
  
    namr(namr_buffer,inline,line_length,istrc); 
  
    IF namr_buffer.types.param1=ascii THEN
      BEGIN 
  
        {The user gave a new name, overlay with old.} 
  
        IF mapped_system THEN 
          file_dcb.l20_long_id.id.name:=namr_buffer.param1.five_char
        ELSE
          file_dcb.l10_long_id.id.name:=namr_buffer.param1.five_char; 
        new_name.five_char:=namr_buffer.param1.five_char; 
      END 
    ELSE IF namr_buffer.types.param1=null THEN
      BEGIN 
  
        {The user did not give a new name, so overlay with
         the file name.}
  
        IF mapped_system THEN 
          file_dcb.l20_long_id.id.name:=file_name.five_char 
        ELSE
          file_dcb.l10_long_id.id.name:=file_name.five_char;
        new_name.five_char:=file_name.five_char;
      END 
    ELSE
      BEGIN 
  
        {The user gave a bad file name type.  Tell him.}
  
        error(bad_type);
        goto 99;
      END;
  
    {Check for conflicts with previously rped programs.  In the 
     unmapped case, boundary checks may have to be made checking
     against real time programs loaded by the generator.  In the
     mapped case (as well as unmapped), name conflicts only are 
     checked.}
  
     IF mapped_system THEN
       BEGIN
  
         {Check for name conflicts.}
  
         IF name_conflict(id_addr,sys_dcb,sys_file,rec_in_sys_dcb,
                          file_dcb.l20_long_id,cur_id_addr) THEN
           BEGIN
             error(previous_rp);
             goto 99; 
           END; 
       END
     ELSE {Unmapped system} 
       BEGIN
  
         {Check for boundary and name conflicts.} 
  
         IF rt_conflict(id_addr,sys_dcb,sys_file,rec_in_sys_dcb,
                       file_dcb.l10_long_id,cur_id_addr) THEN 
           BEGIN
  
             IF cur_id_addr=-1 THEN error(previous_rp)
               ELSE error(cant_rp); 
             goto 99; 
           END; 
       END; 
  
     {Make sure a free id exists.}
     IF cur_id_addr=0 THEN
       BEGIN
  
         {There were no conflicts with real time programs,
          or names, but there are also no ids left.}
  
          error(no_free_ids); 
          goto 99;
        END;
  
     IF done_with_rp THEN 
       BEGIN
  
         {check_file_for_errors concluded that the passed file name 
          had already been rped.  Scan the ids, keying on the 
          starting track,block, and prom lu to make the newname 
          idsegment.} 
  
         {First calculate the track and block number which must 
          be matched when scanning the ids.  The conflicting_entry
          global has the track and sector, but this includes
          the header.}
  
         block_to_match:=ts_to_rec(conflicting_entry.files.starting_track,
                          conflicting_entry.files.starting_sector); 
         recd_to_tb(block_to_match+1,track_to_match,block_to_match);
         temp_id_addr:=id_addr; 
  
         {Read ids until a match occurs.  A match should occur in 
          all cases since done_with_rp is only set true when an 
          open flag lu match is found and the last commasnd was RP. 
          Further, open flag[1] is only set to be the original file 
          lu if the last command was RP.  Together, these checks
          should insure a match will succeed.  The error case is
          for debugging.} 
  
  
         found_old_id:=false; 
         WHILE NOT found_old_id DO
           BEGIN
  
             getidseg(temp_id_addr,sys_dcb,sys_dcb.buff,sys_file, 
                      rec_in_sys_dcb,temp_idseg); 
  
             WITH temp_idseg DO 
               IF mapped_system THEN
                 BEGIN
                   IF  (l20.main_track_number=track_to_match) AND 
                       (l20.main_block_number=block_to_match) AND 
                       (l20.load_lu=prom_lu) THEN found_old_id:=true; 
                 END
               ELSE {unmapped system} 
                 BEGIN
                   IF  (l10.main_track_number=track_to_match) AND 
                       (l10.main_block_number=block_to_match) AND 
                       (l10.load_lu=prom_lu) THEN found_old_id:=true; 
                 END; 
             temp_id_addr:=temp_id_addr+idseg_length; 
  
             {No errors should occur, but just in case...}
  
             IF temp_id_addr>cur_id_addr THEN 
               BEGIN
                 error(cant_rp);
                 goto 99; 
               END; 
           END; 
  
         IF found_old_id THEN 
           BEGIN
             {Put the newname in the old id, and send it to disk.}
  
             IF mapped_system THEN
               temp_idseg.l20.name:=file_dcb.l20_long_id.id.name
             ELSE temp_idseg.l10.name:=file_dcb.l10_long_id.id.name;
  
             {Store the fixed id.}
  
             putidseg(cur_id_addr,sys_dcb,sys_dcb.buff,sys_file,
                                         rec_in_sys_dcb,temp_idseg);
           END; {This condition should always succeed due to
                 previous error checks.}
       END; 
  
     {Getting here means no errors occurred.} 
  
     rp_error_check:=true;
  99: 
  END;
  
  
  
{rec_extent is a function which accepts a low address and 
 a high address plus one, and calculates the number of file 
 records an 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} 
  {last_dte makes a directory track type entry which
  starts with 0 to tell FMGR that this is the end 
  of the the directory track.  Otherwise, a corrupt 
  cartridge error would occur when an entry of -1 
  is encountered.}
  {   directory:      The file directory type entry 
                      which is modified.} 
  PROCEDURE last_dte(VAR directory:directory_entry);
    VAR 
      i:integer;     {A loop index.}
    BEGIN 
      {A 0 in position 1 tells FMGR to stop searching.} 
      directory.ints[1]:=0; 
      FOR i:=2 TO fdir_length DO directory.ints[i]:=-1; 
    END;
  
 {fill_prom makes a file directory entry which will make the PROM 
  disk completely full.  This prevents the creation of files onto 
  PROMS.} 
  
 {    directory:          The file directory entry which fills
                          up the rest of the files.}
  
 PROCEDURE fill_prom(VAR directory:directory_entry);
   VAR
     i:integer;           {A FOR loop index.} 
   BEGIN
     IF cur_prom_file_rec=last_prom_file_rec THEN 
       BEGIN
  
         {The PROM is already completely full, so there is
          no need for the fill file.  The zero in entry 1 will
          indicate the end of the directory track.} 
  
         last_dte(directory); 
  
         {There is now no need to make another file entry starting
          with zero. Setting full_directory true will prevent this.}
  
         full_directory:=true;
       END
       ELSE WITH directory.files DO 
         BEGIN
  
  
           {Put the file name into the directory entry. Note that 
            the name is illegal to FMP.}
  
           name:='.FILL ';
           {Make it type 1 for no particular reason.} 
  
           file_type:=1;
           starting_track:=cur_track; 
           starting_sector:=cur_sector; 
           extent_number:=0;
           file_size_times_2:=((last_prom_file_rec+1)-cur_prom_file_rec)*2; 
           record_length:=0;
  
           {Put an arbitrary positive security code into the field.}
  
           security_code:=1010; 
  
           {Insure that the open flags are zero, even though
            it does not really matter much.}
  
           FOR i:=1 TO 7 DO open_flags[i]:=0; 
         END; 
   END; {fill_prom} 
  
 {complete_directory is called when the NEXT and /E commands are
  typed.  The routine fixes the directory track so the cartridge
  is full, and an end of track indicator is in the PROM file.}
  
 PROCEDURE complete_directory; $direct$ 
   VAR
     post:boolean;      {Tells when to post a buffer to disk.}
     i:integer;         {Index for fixing open flags.}
   BEGIN
  
     {Store the cartridge directory entry.} 
     {Insure the first putfde call goes to disk.} 
  
     rec_in_prom_dcb:=0;
  
     {Need not specify to post since putfde is designed to
      allow convenient sequential puts, which will occur when 
      fixing open flags.} 
     putfde(cart_dir,1,prom_dcb,prom_dcb.buff,prom_file,rec_in_prom_dcb,
                                                             false);
  
     {Completing the directory involves three seperate concerns.
      The PROM disk must look full to FMP, the directory
      track must have a logical (0 in first file entry) or
      physical (all file entries used) end, and the original
      file LUs stored in the first open flag for the RP,file,newname
      handling must be zeroed.  First, fix up the open flags.}
  
     post:=false;  {Posting is automatic at record boundaries.} 
     FOR i:=2 TO cur_fde_num DO 
       BEGIN
  
         {Reuse the cart_dir as a temporary entry.} 
  
         getfde(cart_dir,i,prom_dcb,prom_dcb.buff,prom_file,
                                                  rec_in_prom_dcb); 
  
         cart_dir.files.open_flags[1]:=0; 
  
         IF i=cur_fde_num THEN post:=true;
         putfde(cart_dir,i,prom_dcb,prom_dcb.buff,prom_file,
                                        rec_in_prom_dcb,post);
       END; 
     IF make_fill_file AND NOT full_directory THEN
       BEGIN
  
         {When the directory is full, there is no need
          to make a fill file even though there may be a few
          spare records on the next to the last track.  FMP 
          can not use these since the directory is full, so 
          the small hole does not matter.}
  
         {Re-use cart_dir to make the fill file.} 
  
         fill_prom(cart_dir); 
  
         {Store the fill directory.}
  
         putfde(cart_dir,cur_fde_num,prom_dcb,prom_dcb.buff,prom_file,
                                                  rec_in_prom_dcb,true);
  
         {Is the directory track full at this time?}
  
         IF (cur_fde_num MOD fdir_entries_per_track)=0 THEN 
           full_directory:=true;
       END; 
  
     {If the directory track isn't filled by the previous call, 
      and if the PROM isn't completely full, then mark the end
      of the directory track.}
  
     IF NOT full_directory THEN 
       BEGIN
         last_dte(cart_dir);
         cur_fde_num:=cur_fde_num+1;
         putfde(cart_dir,cur_fde_num,prom_dcb,prom_dcb.buff,prom_file,
                                              rec_in_prom_dcb,true);
       END; 
  END;{complete_directory}
  
{fix_long_ids corrects the header (long id segment) to reflect the
 programs new position on the PROM 'disk', rather than its current
 position on the real disk. It then stores the idsegment into 
 the system image (i.e. does the RP) and writes the corrected type
 6 file header into the PROM image file (in case short ids must 
 be fixed up and stored to the PROM file). The routine returns
 true unless errors are detected.}
  
 FUNCTION fix_long_ids:boolean; $direct$
   LABEL 99;
   CONST
     offset_overflow='ID SEGMENT TRACK OFFSET OVERFLOW';
   VAR
     block,                {A block number returned by recd_to_tb.} 
     bp_tr_off,            {Offset from main where base page starts.} 
     i,                    {A loop index.}
     num_bp_recs,          {Number of records required by base
                            page.}
     num_main_recs,        {Number of records required by main program.}
     track:integer;        {Actual track where base page begins.} 
   BEGIN
  
     {Initially assume no errors occur.}
  
     fix_long_ids:=true;
     {Since the ID structure changed substantially between l10 and l20, 
      the cases are handled almost entirely seperately.}
     {Although the type 6 header was read by check_file_for_errors, 
      its header on disk may have been changed by the relink routine. 
      Hence, re-read the file header in this case.} 
  
     IF mapped_system AND must_relink THEN
       BEGIN
  
         {Note that the old name will be in the name field here.
          This should not pose a problem.}
         readf(file_dcb,ierr,file_dcb.buff,recd_len,irec,1);
         IF ierr<0 THEN 
           BEGIN
             fmp_error(ierr,file_name); 
             fix_long_ids:=false; 
             goto 99; 
           END; 
  
         {Fix the name field if needed.}
  
         file_dcb.id.l20.name:=new_name.five_char;
       END; 
  
     IF mapped_system THEN WITH file_dcb.id.l20 DO
       BEGIN
  
         {RPing is fairly easy in this case.  The type 6
          file structure and ID format only requires that 
          the starting track and sector of the program be 
          updated to reflect the position of the file on the PROM 
          disk.}
  
         {The actual ID segment record values can not be
          substituted for integers in subroutine calls when 
          the field is packed because of range checking.
          Hence the below call and asignement sequence.}
         recd_to_tb(cur_prom_file_rec+1,track,block); 
         main_track_number:=track;
         main_block_number:=block;
         load_lu:=prom_lu;
         terminal_lu:=1;
  
         {Fix the checksum in case the file is offed, and then
          rped using IDRPL.}
  
         file_dcb.buff[36]:=0;
         FOR i:=1 TO 35 DO
           file_dcb.buff[36]:=file_dcb.buff[i]+file_dcb.buff[36]; 
         {The id is now correct.} 
       END ELSE {The system is not mapped, this is harder to fix} 
       WITH file_dcb.id.l10 DO
         BEGIN
  
           {Find out how many records the main and base page extends.}
  
           num_main_recs:=rec_extent(low_main_addr,high_main_addr_plus1); 
           num_bp_recs:=rec_extent(low_base_page_addr,
                                   high_base_page_addr_plus1);
  
           {Save the high main and base page addresses (plus1)
            globally for use by fix_short_ids.} 
  
           hi_mainp1:=high_main_addr_plus1; 
           hi_bpp1:=high_base_page_addr_plus1;
  
           first_seg_rec:=cur_prom_file_rec+1;
  
           {Calculate the track and block number of the main program
            and store the result in the id.}
  
           recd_to_tb(first_seg_rec,track,block); 
           main_track_number:=track;
           main_block_number:=block;
  
           {Save a global copy of the main_track_number for possible
            use by fix_short_ids.}
  
           main_track:=main_track_number; 
  
           {Update the first segment record pointer.} 
  
           first_seg_rec:=first_seg_rec+num_main_recs;
  
           {Calculate base page starting track and block
            and store part of the result in the ID.}
           recd_to_tb(first_seg_rec,track,block); 
           base_page_block_number:=block; 
  
           {Calculate base page track offset from main track.}
  
           bp_tr_off:=track-main_track_number;
  
           {Check for overflow of field error.} 
  
           IF bp_tr_off>63 THEN 
             BEGIN
  
               {Overflow of field error.} 
               {Range checking would catch this error,
                but I try to prevent any PASCAL generated 
                errors, and give more specific, friendlier errors.} 
  
               error(offset_overflow);
               goto 99; 
             END; 
  
          {Define the base page track offset in the id now.}
          base_page_track_offset:=bp_tr_off;
  
          {Update first_seg_rec pointer to point to the first segment.
           This information is required by fix_short_ids.}
  
          first_seg_rec:=first_seg_rec+num_bp_recs; 
  
          load_lu:=prom_lu; 
  
          terminal_lu:=1; 
  
          {Calculate new checksum for id segment.}
  
          file_dcb.buff[32]:=0; 
          FOR i:=1 TO 31 DO 
            file_dcb.buff[32]:=file_dcb.buff[32]+file_dcb.buff[i];
        END; {l10 id case.} 
  
      {In both cases, the id is stored in the system, and the 
       header is moved to the file.}
  
      IF last_command.command='RP' THEN 
        putidseg(cur_id_addr,sys_dcb,sys_dcb.buff,
                           sys_file,rec_in_sys_dcb,file_dcb.id);
  
      {Since the fixed header is now in memory, we might as 
       well store it to the PROM image file at this time, rather
       than duplicate the effort.}
  
      writf(prom_dcb,ierr,file_dcb.buff,recd_len,cur_prom_file_rec);
      IF ierr<0 THEN
        BEGIN 
          fmp_error(ierr,prom_file);
          fix_long_ids:=false;
          goto 99;
        END;
  
     {Make sure the current prom file record pointer is correct.} 
     cur_file_rec:=2; 
     cur_prom_file_rec:=cur_prom_file_rec+1;
  
  99: 
  END;{fix_longids} 
  
 {fix_short_ids fixes any and all short id segments which did specify 
  segment locations on the old disk, and will now specify their location
  on the PROM 'disk'. This is only necessary for the unmapped case
  since the mapped short id segments are block offsets, not track 
  and sector offsets.}
  
FUNCTION fix_short_ids:boolean;$direct$ 
  LABEL 99; 
  CONST 
    offset_overflow='ID SEGMENT TRACK OFFSET OVERFLOW'; 
  VAR 
    block,                  {Block number returned by recd_to_tb.}
    bp_tr_off,              {Track offset of base page from track 
                             of the starting track of the segment main.}
    i,                      {Counter for scanning short ids.} 
    index,                  {Indexes through the current dcb buffer to
                             access short id segments as array elements.} 
    j,                      {Indexes through a short id to calculate the
                             new checksum of the fixed id.} 
    num_bp_recs,            {Number of records spanned by the base page 
                             links of the current id being fixed.}
    num_main_recs,          {Number of records spanned by the main segment
                             described by the current id being fixed.}
    track:integer;          {An actual track (not offset) returned by 
                             recd_to_tb}
  BEGIN 
  
    {Initially assume no errors occur here.}
  
    fix_short_ids:=true;
  
     {It is mandatory to call fix_long_ids before calling fix_short_ids 
      because the routine assumes the header has already been stored
      in the PROM image, and assumes that several global variables
      defined by fix_long_ids (first_seg_rec,hi_mainp1,hi_bpp1) have
      been properly defined.  This also insures (unnecessarily since
      IDRPL fixes an in memory id) that the header for a program stored 
      on PROM via LK correctly reflects its position on the prom.}
  
     IF cur_file_rec<2 THEN {fix_long_ids was not called, so do it} 
       BEGIN
         IF NOT fix_long_ids THEN goto 99;
       END; 
  
     {I can now assume fix_long_ids has been called in all cases.}
  
     i:=0;
  
     {Initialize index to force a readf on the first pass.} 
     index:=short_ids_per_rec+1;
     WHILE (i<num_segments) DO
       BEGIN {%%%}
         i:=i+1;
  
         IF index>short_ids_per_rec THEN
           BEGIN
  
             {Get the next record containing the short ids.}
  
             readf(file_dcb,ierr,file_dcb.buff,recd_len,irec, 
                   cur_file_rec); 
             IF ierr<0 THEN 
               BEGIN
                 fmp_error(ierr,file_name); 
                 fix_short_ids:=false;
  
                 {Act as if any previous record transfers did 
                  not happen.}
  
                 cur_prom_file_rec:=first_prom_file_rec;
                 goto 99; 
               END; 
  
             {Update the current file record counter
              and re-initialize the array index indicator.} 
  
             cur_file_rec:=cur_file_rec+1;
             index:=1;
           END; 
  
         WITH file_dcb.l10_short_ids[index] DO
           BEGIN {%%} 
             {Calculate number of records the main part of the segment uses.} 
             {hi_mainp1 was set by fix_long_ids.} 
             {Note that hi_mainp1 is the lowest address of the segment.}
  
             num_main_recs:=rec_extent(hi_mainp1,high_seg_addr_plus1);
  
             {Calculate the number of disk records the base page
              requires for this segment.} 
             {hi_bpp1 was set by fix_long ids.} 
  
             num_bp_recs:=rec_extent(hi_bpp1,high_base_page_addr_plus1);
  
             {Calculate track and block of the start of the image.} 
  
             recd_to_tb(first_seg_rec,track,block); 
             segment_block_number:=block; 
  
             {This field should never overflow since the main starts right
              after the last segments base page.  In other words, if
              this field overflows, so will the base page track offset
              field (detected below).  PASCAL range checking should also
              catch this.}
  
             main_track_offset:=track-main_track; 
  
            {Update the record pointer to indicate the start of the base
             page record.}
  
            first_seg_rec:=first_seg_rec+num_main_recs; 
  
            {Calculate the track and block of the base page image,
             storing the resultant block number in the short id.} 
  
            recd_to_tb(first_seg_rec,track,block);
            base_page_block_number:=block;
  
            {Update first_seg_rec to point to the first record of the next
             segment.}
  
            first_seg_rec:=first_seg_rec+num_bp_recs; 
  
            {Compute the base page track offset, check for overflow.} 
  
            bp_tr_off:=(track-(main_track+main_track_offset));
  
            {Check for overflow of this field.} 
  
            IF bp_tr_off>63 THEN
              BEGIN 
  
                error(offset_overflow); 
  
                {Make the current prom file record pointer act as 
                 if no transfer occurred.}
  
                cur_prom_file_rec:=first_prom_file_rec; 
                fix_short_ids:=false; 
                goto 99;
              END;
  
            {Put the valid base page offset in the id.} 
  
            base_page_track_offset:=bp_tr_off;
           {Put the new checksum at word 8 of the short id segment.}
  
           short_id_checksum:=0;
  
           FOR j:=1 TO short_idseg_length-1 DO
             short_id_checksum:=short_id_checksum+ints[j];
  
           {Update the array index for write check.}
  
           index:=index+1;
           {Write out the record if the last segment has been fixed 
            or if at a record boundary.}
  
           IF (i=num_segments) OR (index>short_ids_per_rec) THEN
             BEGIN
               writf(prom_dcb,ierr,file_dcb.buff,recd_len,cur_prom_file_rec); 
               IF ierr<0 THEN 
                 BEGIN
                   fmp_error(ierr,file_name); 
                   fix_short_ids:=false;
                   cur_prom_file_rec:=first_prom_file_rec;
                   goto 99; 
                 END; 
  
               {Point to next availiable PROM file record.} 
               cur_prom_file_rec:=cur_prom_file_rec+1;
             END; 
           END; {%%}
       END; {%%%} 
99: 
  END; {fix_short_ids}
  
{warning is called to output a message when a warning is detected.} 
PROCEDURE warning(message:input_line);
  CONST 
    star_warning='*WARNING - '; 
  BEGIN 
  
    {The message string may be truncated to 60 characters for 
     the same reason as in routine error.}
  
    writeln(ofile,star_warning,message:60); 
    IF echo_prompt THEN writeln(ifile,star_warning,message:60); 
  END;
{store_file is a procedure which stores the file onto the PROM
 image file. No errors (save obscure disk errors) should occur
 due to the previous call to check_file_for_errors.  The routine
 updates the globals cur_prom_file_rec, and it closes the 
 prom file before exiting.  The routine also stores the directory and 
 updates next directory entry counter, and it allocates a new 
 directory track if necessary.} 
PROCEDURE store_file(VAR source_dcb:dcb;
                     first_record,last_record:integer); 
  LABEL 99; 
  CONST 
    dir_out_of_room='DIRECTORY OUT OF ROOM';
  VAR 
    i,                      {Counts the record for readf,writf.}
    sector,                 {Dummy param required by rec_to_ts.}
    track:integer;          {Track number returned by rec_to_ts.} 
    source_name:string6;    {Name of source file retrieved from its 
                             directory entry.}
  BEGIN 
  
    source_name.file_name:=directory.files.name;
    {Transfer the file.}
  
    FOR i:=first_record TO last_record DO 
      BEGIN 
  
        readf(source_dcb,ierr,source_dcb.buff,recd_len,irec,i); 
        IF ierr<0 THEN
          BEGIN 
            fmp_error(ierr,source_name);
            cur_prom_file_rec:=first_prom_file_rec; 
            goto 99;
          END;
        writf(prom_dcb,ierr,source_dcb.buff,recd_len,cur_prom_file_rec);
        IF ierr<0 THEN
          BEGIN 
            fmp_error(ierr,prom_file);
            cur_prom_file_rec:=first_prom_file_rec; 
            goto 99;
          END;
  
        {Update the prom file record counter.}
  
        cur_prom_file_rec:=cur_prom_file_rec+1; 
      END;
  
    {Store the directory entry unless there is no directory.} 
    IF no_directory THEN goto 99; 
  
    putfde(directory,cur_fde_num,prom_dcb,prom_dcb.buff,prom_file,
                                          rec_in_prom_dcb,true);
  
    {Do we need to allocate a new directory track?} 
  
    IF (cur_fde_num MOD fdir_entries_per_track)=0 THEN
      {The next directory entry will not fit on the current track.} 
      BEGIN 
  
        {Try to allocate a new track.}
  
        last_prom_file_rec:=last_prom_file_rec-recs_per_track;
  
        IF last_prom_file_rec<cur_prom_file_rec THEN
          BEGIN 
  
            {No new directory track can be allocated.}
  
            full_directory:=true; 
  
            {Warn user of the situation.} 
            warning(dir_out_of_room); 
  
            {Can't allocate, so repair last_prom_file_rec.} 
  
            last_prom_file_rec:=last_prom_file_rec+recs_per_track;
          END 
        ELSE
          BEGIN 
  
            {A track is availiable, so allocate it and update 
             the cartridge directory entry.}
  
            rec_to_ts(last_prom_file_rec+1,track,sector); 
            cart_dir.cartridge.low_directory_track:=track;
  
            {Update the negative number of directory tracks.} 
  
            cart_dir.cartridge.neg_number_directory_tracks:=
              cart_dir.cartridge.neg_number_directory_tracks-1; 
          END;
  
      END;
    {Point to next free file directory entry.}
    cur_fde_num:=cur_fde_num+1; 
99: close(source_dcb);
  END;  {store_file}
  
{bu_process handles the bump command. It is paramaterless, and
 operates on the global cur_prom_file_rec to create the hole on 
 the PROM disk, and the global file_length to store the size of 
 the hole created. The cur_track and cur_sector pointers are
 initialized at the start of each call to this routine.}
FUNCTION bu_process:boolean; $direct$ 
  CONST 
    overflow='OVERFLOW OF MEMORY';
    recds_per_2k=16;
  BEGIN 
  
    {Assume no errors initially.} 
  
    bu_process:=true; 
  
   {Initialize the current track and sector pointers.}
  
   rec_to_ts(cur_prom_file_rec,cur_track,cur_sector); 
    IF (((cur_prom_file_rec-1) MOD recds_per_2k)<>0) THEN 
      {Not at a 2k boundaray, so calculate the hole size.}
      file_length:=(recds_per_2k+1)-(cur_prom_file_rec MOD recds_per_2k)
    ELSE {At a 2K boundary, so bump 2k.}
      file_length:=recds_per_2k;
  
    {Update the prom record pointer after an error check.}
  
    IF (cur_prom_file_rec+file_length-1)>last_prom_file_rec THEN
      BEGIN 
  
        {Bump would go into the directory track, so disallow
         the bump.  The user can trivially create a hole of 
         the remaining undefined space by ending or formatting
         a next PROM.}
  
        warning(overflow);
        bu_process:=false;
      END 
    ELSE {Do the bump.} 
      BEGIN 
        cur_prom_file_rec:=cur_prom_file_rec+file_length; 
  
        {Define the file name as blanks for the call to prom_description.}
  
        file_name.file_name:='      ';
      END;
  END; {bu_process} 
  
{prom_description outputs information about the location of 
 the last file stored onto the PROM.
   last_file:               The file name stored onto the PROM. 
   file_length:             The number of records of the file.} 
PROCEDURE prom_description(VAR last_file:string6; VAR file_length:integer); 
  VAR 
    prom_num,               {The prom number where the file storage began.} 
    rem_blocks:integer;     {Undefined blocks remaining on the PROM.} 
  BEGIN 
  
    {Determine the prom number on which the file storage began.}
  
    prom_num:=((cur_track*recs_per_track*recd_len+cur_sector*64)
               DIV 2048) +1;
  
    {Determine the number of remaining blocks.} 
  
    rem_blocks:=(last_prom_file_rec+1)-cur_prom_file_rec; 
  
    {Output the description.} 
  
    writeln(ofile,last_file.file_name,space2,last_command.file_name,
            file_length:8,prom_num:8,cur_track:8,cur_sector:8,rem_blocks);
  
    IF echo_prompt THEN 
      writeln(ifile,last_file.file_name,space2,last_command.file_name,
             file_length:8,prom_num:8,cur_track:8,cur_sector:8,rem_blocks); 
     {Update track and sector pointers in case a BU command is the last 
      command typed.} 
  
     rec_to_ts(cur_prom_file_rec,cur_track,cur_sector); 
  END; {prom_description} 
  
{Relink check is a function which finds out if a relink is necessary
 (mapped case) or the program was rp'd for the current system (unmapped 
 case).  The actual routine which does the relink is in a different 
 segment since it makes use of a large symbol table contained there.
 The routine is true if no errors occur, and the global must_relink 
 is set true if a relink is required for the mapped case.}
  
FUNCTION relink_check:boolean; $direct$ 
  LABEL 99; 
  CONST 
    not_loaded_for_system='PROGRAM NOT SET UP FOR THIS SYSTEM'; 
  BEGIN 
  
    {Initialize default returns.} 
  
    relink_check:=true; 
  
  
    {The file header is in memory from check_file_for_errors.}
    IF mapped_system THEN 
      WITH file_dcb.l20_long_id DO
        BEGIN 
  
          IF (ext.system_checksum<>sys_id_csw) OR 
             ((id.system_common) AND (ext.system_common_checksum<>
              sys_com_csw)) THEN must_relink:=true
            ELSE must_relink:=false;
  
        END 
    ELSE {The system is unmapped} 
      WITH file_dcb.l10_long_id DO
        BEGIN 
  
          IF ext.system_checksum<>sys_id_csw THEN 
            BEGIN 
  
              {Program not loaded for this system. Give error.} 
  
              error(not_loaded_for_system); 
              relink_check:=false;
              goto 99;
            END;
  
          {The segmented boolean only matters in the unmapped case.}
          IF id.number_of_segments>0 THEN 
            BEGIN 
              segmented:=true;
              num_segments:=id.number_of_segments;
            END 
            ELSE segmented:=false;
        END;
 99:
  END;.{relink_check}