$pascal '92071-1X293 REV.2041  800611'$ 
$heap 0$
$segment$ 
PROGRAM PFS5; 
{ 
* 
*NAME:    PFS5
*SOURCE:  92071-18293 
*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.        *
****************************************************************
} 
  
{PFS5 is loaded into memory when a relink operation must take place.
 It performs the relink (using a large buffer local to the segment),
 and handles all associated errors.}
 {Read in the global constants, variables and types.} 
$include '&PFGBL'$
  
{Declare FMP routines.} 
  
PROCEDURE close(file_dcb:dcb);external; 
{Non FMP externals contained in the main program are next.} 
  
PROCEDURE error(message:input_line);external; 
PROCEDURE fmp_error(VAR ierr:integer; VAR name:string6);external; 
  
{The relink routine returns errors in the a and b registers.} 
PROCEDURE abreg(VAR a,b:integer);external;
  
  
{The remaining procedures are written in assembly language, 
 and should be relocated with this segment.}
  
  
{Loader library routine for relinking type 6 files.}
PROCEDURE rlink (VAR snapshot,prog:dcb; VAR symbols:table_addr; 
                                  bufflen:integer);external;
  
{RLINK wants a pointer to the symbol table buffer, but I want to
 pass it a static array local to rp_process.  Since PASCAL pointers 
 point to types (not variables), and are only initialized by the
 heap management routine ,new, I need a routine to initialize a 
 pointer to point to a static variable.  POINT does this, and will
 work as a general case routine when typed to most any pointer and
 variable.} 
  
PROCEDURE pointer_init $ALIAS 'POINT'$ (VAR pointer:table_addr; 
                                        VAR variable:symbuff);external; 
  
{The remaining procedures are local to this segment,except perform_relink.} 
  
{warning is called to output a message when a warning is detected.} 
PROCEDURE warning(message:input_line);$direct$
  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;
  
{Procedure undef_handler is called by the relink routine
 (RLINK) when undefined symbols were encountered.  The
 relink still took place.}
{    start_addr:        Starting address of the fixup table.
     top_addr:          Last address in the fixup table.} 
PROCEDURE undef_handler $ALIAS 'UNRER'$ (VAR start_addr:table_addr; 
                                           top_addr:integer); 
  CONST 
    undefined_exts='UNDEFINED EXTERNAL REFERENCES'; 
  TYPE
  
    {symbol_entry is a type used for accessing each symbol
     table entry.  It reflects the structure of the table.} 
  
    symbol_entry= 
       RECORD 
         fixup_table:^integer;
         value:integer; 
         length:integer;
         symbol:varl_labl;
       END; 
  
  
     {entry_addr is a pointer to a symbol entry.} 
  
     entry_addr=
        RECORD
          CASE boolean OF 
            true: 
              (addr:^symbol_entry); 
            false:
              (int:integer) 
         END; 
  VAR 
    entry:entry_addr;       {A pointer used for accessing 
                             each table entry.} 
  BEGIN 
  
    {Output the warning message.} 
  
    warning(undefined_exts);
  
    {Assign local pointer to point to start of table.}
  
    entry.int:=start_addr.int;
  
    {Scan through the table, outputting undefined symbols.} 
  
    WHILE entry.int<top_addr DO 
      BEGIN 
        IF entry.addr^.value=-1 THEN
          BEGIN 
  
            {Symbol is undefined. Output it.} 
  
  
            writeln(ofile,entry.addr^.symbol.chars:(entry.addr^.length*2)); 
            IF echo_prompt THEN 
              writeln(ifile,entry.addr^.symbol.chars:(entry.addr^.length*2)); 
          END;
  
        {In any case, point to the next symbol table entry.}
  
        entry.int:=entry.int+entry.addr^.length+3;
      END;
  END; {undef_handler}
  
  
{perform_relink is the function which calls the loader library
 rlink routine.  It also handles the error returns.}
{The function is true if no errors occured, false otherwise.
 The program file is closed upon errors.} 
FUNCTION perform_relink:boolean; $direct$ 
  CONST 
    bad_file='CORRUPTED PROGRAM FILE';
    incorrect_type='INCORRECT FILE TYPE'; 
    ill_snap_error='ILLEGAL SNAPSHOT';
    change_in_common='SYSTEM COMMON CHANGED'; 
    overflow_of_symbols='OVERFLOW OF SYMBOL TABLE USED FOR RELINKING';
    can_not_relink='CAN NOT RELINK PROGRAM';
    rpl_checksum_change='RPL CHECKSUM DOES NOT MATCH';
  VAR 
     a,b:integer;              {Returned from abreg}
     symbols:symbuff;          {Buffer used by relink routine.} 
     symbols_addr:table_addr;  {Pointer to symbol table buffer
                                required by RLINK.} 
  BEGIN 
  
    {Initialize a pointer to point to the symbol
     table buffer.} 
  
    pointer_init(symbols_addr,symbols); 
  
  
    {Assume no errors.} 
  
    perform_relink:=true; 
  
    {The program must be relinked.  Call a loader 
     library routine to do this.} 
  
    rlink(snap_dcb,file_dcb,symbols_addr,symbuff_length); 
  
    {Errors returned in a and b registers.} 
  
    abreg(a,b); 
  
    {Handle errors.}
  
    IF b<>0 THEN {There were errors.} 
      BEGIN {*} 
  
        perform_relink:=false;
        CASE b OF 
          1: fmp_error(a,file_name);
          2: fmp_error(a,snap_file);
          3:  CASE a OF 
                -5: error(overflow_of_symbols); 
                 3: error(ill_snap_error);
               14: error(change_in_common); 
               16: warning(rpl_checksum_change);
               13: error(bad_file); 
             OTHERWISE
               {Will flow here in a=7 case which
                was already dealt with by undef_handler.} 
             END; 
          4:  CASE a OF 
                7:  {undef_handler was called, but also 
                     report an RPL checksum change warning.}
                    warning(rpl_checksum_change); 
               END; {Case a OF} 
        END; {CASE b OF}
  
        {Tell user he can't relink for the previously 
         output reason.}
        IF (a<>16) AND (a<>7) THEN
          BEGIN 
            error(can_not_relink);
            close(file_dcb);
          END 
        ELSE {Not an actual RP error, just a
                 relink warning.} 
             perform_relink:=true;
      END; {*}
  END;.{perform_relink,PFS5}
                                                                                                          