$pascal '92070-1X290 REV.2001  800603'$ 
$heap 0$
$segment$ 
PROGRAM PFS2; 
{ 
*NAME:   PFS2 
*SOURCE: 92070-18290
*RELOC:  92070-16290
*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.        *
****************************************************************
} 
{Two procedures use this string.} 
$include 'PFGBL'$ 
  
{External procedure definitions. Calls to FMP.} 
  
PROCEDURE open(VAR idcb:dcb; VAR ierr:integer; VAR name:fname;
               iopin,isecu,icr:integer);external; 
PROCEDURE purge(VAR idcb:dcb; VAR ierr:integer; VAR name:fname; 
               VAR isecu,icr:integer);external; 
PROCEDURE close(VAR idcb:dcb);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:integer);
                                                        external; 
PROCEDURE ecrea(VAR idcb:dcb; VAR ierr:integer; VAR name:fname; 
                VAR isz:isize_type; itype,isecu,icr:integer);external;
PROCEDURE crets(VAR idcb:dcb; VAR ierr,num:integer; VAR name:fname; 
                VAR isz:isize_type; itype,isecu,icr:integer);external;
  
PROCEDURE exec(ecode,place_holder:integer);external;
{Non FMP externals contained in the main program are next.} 
PROCEDURE split_namr(VAR iline:input_line; VAR len:integer; 
                     VAR name:fname; VAR security,cartride,start_char,
                     namr_type:integer);external; 
PROCEDURE readline(VAR inline:input_line;VAR len:integer);external; 
FUNCTION andi(i1,i2:integer):integer;external;
PROCEDURE writline(VAR buff:input_line);external; 
  
FUNCTION getword(address:integer; VAR idcb:dcb; VAR ibuff:buffer; 
               VAR name:fname; VAR curr_rec:integer):integer;external;
  
{fmp_error is called whenever FMP returns an error code in ierr.} 
  
PROCEDURE fmp_error(ierr:integer;VAR file_name:fname);external; 
  
  
  
{handle_error handles certain forms of PASCAL errors, such as 
 a <cr> from a terminal causing a program abortion.}
  
PROCEDURE handle_error (err_type: error_type; 
             err_number, err_line: integer; VAR err_file: input_line; 
             err_flen:integer); 
 CONST
  error15='PFORM ABORTED';
  error19='*ERROR - PASCAL RUNTIME SYSTEM CODE # '; 
  error20='*ERROR - SEGMENT LOAD FAILURE IN ';
  error21='*ERROR - PASCAL IO SYSTEM CODE # ';
 VAR
   error_file:fname;      {The name of the file in error.}
   ises,                  {Dummy param for loglu call.} 
   i:integer; 
 BEGIN
  
   {The file name is not always good. Try to detect 
    this case and prevent garbage from being displayd.} 
  
   IF err_flen=0 THEN error_file:='      '
     ELSE 
       FOR i:= 1 TO 6 DO error_file[i]:=err_file[i];
  
   {Convert the file name from the internal representation
    (ifile or ofile) to its external name the user sees.} 
  
   IF error_file='IFILE ' THEN error_file:=input_file 
     ELSE IF error_file='OFILE ' THEN error_file:=output_file;
  
  {The error might be related to ifile or ofile.  In this 
   case, the attempt to write the error message could in
   turn result in another call to handle_error, which would 
   then yield an infinite loop of errors.  These next 
   few lines do a pretty good job of preventing this
   problem, but the result is that these errors will only 
   show up on the scheduling terminal.} 
  
  {Do a rewrite to the terminal.  All these errors will 
   go there only.}
  
  rewrite(ofile,login_lu);
  echo_write:=false;
   CASE err_type OF 
  
     fmp: 
       fmp_error(err_number,error_file);
     seg: 
       BEGIN
  
         {Output segment load error.} 
  
         writeln(ofile,error20,error_file); 
       END; 
     io:
  
       BEGIN
  
         {These errors have their own code.}
         {Output the general case error message.} 
         writeln(ofile,error21,err_number:3); 
       END; 
     run: 
  
       BEGIN
  
         {Runtime errors also  have their own code.}
         writeln(ofile,error19,err_number:3); 
       END; 
     END; {Case Statement.} 
  
   {Abort the program with exec call. 
    First give the abortion message.} 
  
   writeln(ofile,error15);
  
   {Cleanup stray files.} 
  
   IF created THEN
     purge(out_dcb,ierr,outfile,out_secu,out_crn);
   IF made_scratch THEN 
     purge(sys_dcb,ierr,system,sys_secu,sys_crn); 
  
   exec(6,0); 
  
 END; {handle_error}
  
{readint calls a readline to get an integer from the ifile device,
 and echoes the readln if necessary.} 
{     int:   The integer read, and returned, so called by name.}
  
PROCEDURE readint(VAR int:integer); 
   VAR
     inline:input_line;       {The input line starting with an integer.}
     name:fname;              {A dummy file name used in namr routine.} 
     icr,istrc:integer;       {Parameters used by split_namr. 
                               icr::=returned cartridge number in namr string 
                               istrc::=starting character number of inline }
     len:integer;             {Length of integer string, returned by readline.} 
     namr_type:integer;       {Type of namr string parsed, returned by namr.
                               It should be 1.} 
  BEGIN 
    readline(inline,len); 
    IF NOT (abort_or_pform_ended) THEN
      BEGIN 
        istrc:=1; 
        split_namr(inline,len,name,int,icr,istrc,namr_type);
  
        {Return zero for int if a non integer was parsed.}
  
        IF namr_type<>1 THEN int:=0;
      END;
  END; {readint}
{read_sys entry gets one system entry from the SNAP file,converts 
 types, and gets the size of the label field for the next entry.} 
{     file_name:            The name of the snapshot file, passed 
                            by name for efficiency. 
      idcb:                 The dcb of the snapshot file, passed by 
                            name for efficiency.
      ibuff:                The buffer associated with the snapshot 
                            dcb, passed by name for efficiency. 
      current_label:        The label found in the snapshot entry 
                            just read, passed by name since it is 
                            returned to search_se.
      curr_address:         The address found in the snapshot entry 
                            just read, passed by name since it is 
                            returned to search_se.} 
  
PROCEDURE read_sys_entry(VAR file_name:fname;VAR idcb:dcb;
                         VAR ibuff:buffer;VAR current_labl:varl_labl; 
                         VAR curr_address:integer); 
  VAR 
    i,                         {Loop counter.}
    num_words,                 {Number of words in current record.} 
    record_size:integer;       {Maximum snapshot record size expected.} 
  BEGIN 
  
    {Compute maximum record size expected.} 
  
    record_size:=max_words+3; 
  
    {Get a record.} 
  
    readf(idcb,ierr,ibuff,record_size,len,0); 
  
    {Get the length of the label field in words.} 
  
    num_words:=ibuff[1];
    IF ierr<0 THEN fmp_error(ierr,file_name) ELSE 
      BEGIN 
  
        {Get the current label in the snapshot record.} 
  
        FOR i:=1 TO num_words DO
          BEGIN 
  
            {Convert integers to character type.} 
            current_labl[i*2-1]:=chr(ibuff[i+1] DIV 256); 
            current_labl[i*2]:=chr(andi(ibuff[i+1],255)); 
          END;
  
        {Get the actual record size.} 
  
        record_size:=num_words+3; 
  
        {Get the actual current address the label referrs to.}
  
        curr_address:=ibuff[record_size]; 
      END;
  END;{read_sys_entry}
  
{search_se recieves an array of labels and returns an array of addresses.}
{An address entry of 0 means that the label was not found.} 
{     name:                  The name of the snapshot file, passed by 
                             name for efficiency. 
      idcb:                  The dcb of the shapshot file.
      ibuff:                 The buffer of the dcb associated with the
                             snapshot file. 
      address:               The array of addresses returned by the 
                             routine. 
      labls:                 The array of labels passed to the routine. 
      num_labls:             The number of labels in the label array
                             labls. 
      num_entries:           The actual number of label entries in the
                             snapshot file. } 
  
PROCEDURE search_se(VAR name:fname;VAR idcb:dcb;VAR ibuff:buffer; 
                  VAR address:address_array;VAR labls:labl_array; 
                  num_labls,num_entries:integer); 
  VAR 
    curr_address,           {The address of the snapshot entry just 
                             read, returned by read_sys_entry.} 
    i,j,                    {Indexes used for counting.}
    num_found:integer;      {A counter which keeps track of the 
                             number of labels found so far.}
    curr_labl:varl_labl;    {The label of the snapshot entry just 
                             read, returned by read_sys_entry.} 
  BEGIN 
  
    {Zero all passed addresses.}
  
    FOR i:=1 TO num_labls DO address[i]:=0; 
    num_found:=0; 
    i:=0; 
  
    {Search the snapshot file until all passed labels have
     been found, or until an FMP error occurs, or until the 
     entire snapshot file has been searched (whichever comes
     first.}
  
    WHILE (i<num_entries) AND (num_found<num_labls) AND 
          (NOT io_error) DO 
      BEGIN 
  
        {Get a record, its label, and address field values.}
  
        read_sys_entry(name,idcb,ibuff,curr_labl,curr_address); 
        i:=i+1; 
        IF (NOT io_error) THEN
          BEGIN 
  
            {Loop through, comparing the current label with all entries 
             of the label array passed.}
  
            FOR j:=1 TO num_labls DO
              IF labls[j]=curr_labl THEN
                BEGIN 
                  address[j]:=curr_address; 
                  num_found:=num_found+1; 
                END;
          END;
      END;
  END;{search_se} 
  
{snap_process is called after the snapshot file namr is known}
  
PROCEDURE snap_process; 
  CONST 
    ilen=12;                   {Length of snapshot header.} 
    {Define snapshot file related error messages.}
    error1='*ERROR - ILLEGAL SNAPSHOT'; 
    error2='*ERROR - SNAP NOT FOR THIS SYSTEM'; 
    prompt2='Snapshot file (namr) ? ';
  VAR 
    snap_corrupt:boolean;      {True when the snapshot file 
                                is deemed corrupt.} 
    snapbuff:buffer;           {The packing buffer for reading
                                the snapshot file.} 
    i,                         {Loop counter.}
    num:integer;               {crets will make a scratch file which
                                uses this number as a part of the name.}
    isz:isize_type;            {Size array for crets.}
  BEGIN 
    temp:=0;
    io_error:=false;
    snap_corrupt:=false;
    IF terminal_outfile THEN prompt(ofile,prompt2)
      ELSE write(ofile,prompt2);
  
    {When echo_write is true, so is interactive, but
     the converse does not always hold.}
  
    IF echo_write THEN prompt(ifile,prompt2); 
    readline(inline,len); 
    IF NOT (repeat_prompt OR abort_or_pform_ended) THEN 
      BEGIN{&&} 
        istrc:=1; 
        split_namr(inline,len,snap,isecu,icrn,istrc,namr_type); 
  
        {Open the snapshot file using shared access.} 
  
        open(prog_dcb,ierr,snap,1,isecu,icrn);
        IF ierr<0 THEN
          BEGIN 
            IF interactive THEN repeat_prompt:=true 
              ELSE abort:=true; 
            fmp_error(ierr,snap); 
          END 
        ELSE
          BEGIN {&} 
  
            {Get the snapshot header.}
  
            readf(prog_dcb,ierr,snapbuff,ilen,len,0); 
  
            IF ierr<0 THEN
              BEGIN 
                fmp_error(ierr,snap); 
                IF interactive THEN repeat_prompt:=true 
                  ELSE abort:=true; 
              END 
            ELSE
              BEGIN{} 
  
               {Get a few words from the header, particularly the 
                number of entries in the snapshot, the first word 
                of background memory address, and the background
                base page starting address.}
  
               num_sys_entries:=snapbuff[1];
               fwbg:=snapbuff[4]; 
               bgbp:=snapbuff[7]; 
  
               {Check the header checksum.} 
  
               temp:=0; 
               FOR i:=1 TO 11 DO
                 temp:=temp +snapbuff[i]; 
               IF temp<>snapbuff[12] THEN 
                 snap_corrupt:=true   {Header checksum does not aggree.}
               ELSE 
                 snap_corrupt:=false; 
               IF NOT snap_corrupt THEN 
                 BEGIN
  
                   {Store the checksum word of the system for which 
                    the snapshot file corresponds to in temp.}
  
                   temp:=snapbuff[11];
  
                   {Find the addresses of the labels in the snapshot.}
  
                   search_se(snap,prog_dcb,snapbuff,address,labls,
                                      num_labls,num_sys_entries); 
                   FOR i:=1 TO num_labls DO 
  
                     {See if any vitally needed labels were not found 
                      in the snapshot file.}
  
                     IF address[i]=0 THEN snap_corrupt:=true; 
                 END; 
               IF snap_corrupt THEN 
                 BEGIN
                   writeln(ofile,error1); 
                   IF echo_write THEN writeln(ifile,error1);
                   IF NOT interactive THEN abort:=true
                     ELSE repeat_prompt:=true;
                 END
               ELSE 
                 BEGIN
  
                   {Get the values contained at the label addresses 
                    returned from the snapshot file. The order of labels
                    here was designed to minimize the number of disk
                    accesses required by getword. At most, two disk 
                    accesses will take place here, one to get the system
                    csw, and one to get the other 4 words (which are
                    generally very close together in the system). Only
                    one disk access will be required in certain cases.} 
  
                   sys_csw:=getword(address[1],sys_dcb,sys_dcb.buff,
                                 system,cur_sys_rec); 
                   id_addr:=getword(address[2],sys_dcb,sys_dcb.buff,
                                   system,cur_sys_rec); 
                   id_num:=getword(address[3],sys_dcb,sys_dcb.buff, 
                                system,cur_sys_rec);
                   lut_num:=getword(address[4],sys_dcb,sys_dcb.buff,
                                system,cur_sys_rec);
                   lut_addr:=getword(address[5],sys_dcb,sys_dcb.buff, 
                                    system,cur_sys_rec);
                   IF sys_csw<>temp THEN
                     BEGIN
  
                       {The snapshot is for a different system than 
                        the one specified.} 
  
                       snap_corrupt:=true;
                       writeln(ofile,error2); 
                       IF echo_write THEN writeln(ifile,error2);
                       IF NOT interactive THEN abort:=true
                         ELSE repeat_prompt:=true;
                     END; 
                 END; 
  
                {Close the snapshot file.}
  
                close(prog_dcb);
              END;{}
          END; {&}
        IF NOT (abort OR snap_corrupt OR io_error) THEN 
          BEGIN 
  
            {Create a scratch system file which will be modified.}
            isz[1]:=256;
            isz[2]:=0;
            made_scratch:=true; 
  
            {Create a scratch file, and keep trying using a different 
             num if an FMP -2 error (duplicate file name).} 
  
            num:=0; 
            ierr:=-2; 
            WHILE ((ierr=-2) OR (ierr=-33)) AND (num<99) DO 
              BEGIN 
                crets(prog_dcb,ierr,num,scratch,isz,1,sys_secu,sys_crn);
                IF ierr=-2 THEN num:=num+1; 
  
                {If not enough room on the cartridge, then ierr 
                 is -33. In this case, try agains setting sys_crn 
                 to 0 if it isn't already. This will place the
                 scratch file on the first cartridge in the users 
                 list which has enough space.}
  
                IF (ierr=-33) AND (sys_crn<>0) THEN 
                  sys_crn:=0
                ELSE IF (ierr=-33) AND (sys_crn=0) THEN 
  
                  {Not enough room on any cartridge, don't
                   retry the crets.}
                     num:=100;
              END;
            IF ierr<0 THEN
              BEGIN 
                fmp_error(ierr,scratch);
                made_scratch:=false;
  
                {No way to recover from this error. All cartridges
                 are full, or all scratch file names are used up.}
  
                abort:=true;
              END 
              ELSE
  
                {Copy the system image into the scratch file.}
                {Since we checked the size of the system image, 
                 and created the scratch file of the same size, 
                 no fmp errors should occur here.}
  
                cur_sys_rec:=0; 
                WHILE (cur_sys_rec<sys_len) AND NOT (repeat_prompt OR abort)
                  DO
                  BEGIN 
                    cur_sys_rec:=cur_sys_rec+1; 
  
                    {Copy a record from file to file.}
  
                    readf(sys_dcb,ierr,sys_dcb.buff,recd_len,len,cur_sys_rec);
                    IF ierr<0 THEN
                      BEGIN 
                        fmp_error(ierr,system); 
                        IF interactive THEN repeat_prompt:=true 
                          ELSE abort:=true; 
                      END 
                      ELSE
                        BEGIN 
  
                          {The PROM boot loader needs a negative word count 
                           of the system length in word 1, but the generator
                           puts a positive word count there. Fix this 
                           problem now unless it was maybe fixed by the 
                           generator, or a previous run of PFORM.}
  
                          IF (cur_sys_rec=1) AND  (sys_dcb.buff[1]>0) THEN
                            sys_dcb.buff[1]:=-sys_dcb.buff[1];
                          writf(prog_dcb,ierr,sys_dcb.buff,recd_len,
                                 cur_sys_rec);
                          IF ierr<0 THEN
                            BEGIN 
                              fmp_error(ierr,scratch);
                              IF interactive THEN repeat_prompt:=true 
                                ELSE abort:=true; 
                             END; 
                        END;
                  END;
  
            {Close the system file.}
  
            close(sys_dcb); 
  
            {Make the scratch file the new system file.}
  
            sys_dcb:=prog_dcb;
            system:=scratch;
          END;
      END; {&&} 
    IF NOT interactive AND io_error THEN abort:=true; 
   abort_or_pform_ended:=abort OR pform_ended;
END; {snap_process} 
  
{outfile_process uses the memory size to find the length of the outfile 
 to be created, creates the file specified by the namr in inline, handles 
 errors, and fills the output file with -1.}
PROCEDURE outfile_process;
CONST 
  {Define outfile related error message.} 
  error0='*ERROR - NOT ENOUGH MEMORY FOR SYSTEM IMAGE'; 
VAR 
  i,                           {A loop index.}
  start_neg_rec:integer;       {The record number from which the
                                filling of the output file with -1
                                begins on.  This number 
                                is 1 if the user isn't booting
                                from the output file, otherwize, it 
                                the first record past the end of
                                the system length.} 
   isz:isize_type;             {File length for ecrea.} 
  BEGIN 
  
    {Calculate the first directory track.}
    first_dir_track:=num_tracks-1;
  
  
    {Calculate the record number corresponding
     to the beginning of the first directory track.}
  
    fde_recnum:=first_dir_track*recs_per_track+1; 
  
    {Save the first file directory record number since
     it is possible for the directory to use more than
     one track.}
  
    first_fde_recnum:=fde_recnum; 
  
    {See if the memory is already full due to a system
     image which would overlay with the directory track.
     In this case, no directory entries or cartridge
     initialization entries are made.}
  
    IF (first_boot AND (sys_len>=first_fde_recnum)) THEN
       no_directory:=true 
      ELSE no_directory:=false; 
  
    {Calculate the length of the output file.}
  
    ofile_len:=num_tracks*recs_per_track; 
  
    {See if there is enough memory in the prom for the system.} 
  
    IF first_boot AND (sys_len>ofile_len) THEN
      BEGIN 
        overflow:=true; 
  
        {Memory size is determined by the driver parameters 
         at generation time.  This error might possibly be recovered
         from by specifying a different lu number, but it may be
         necessary to generate a new system using different prom
         card driver parameters.} 
  
        IF NOT interactive THEN 
          abort:=true 
          ELSE repeat_prompt:=true; 
  
        {Output the NOT ENOUGH MEMORY error.} 
  
        writeln(ofile,error0);
        IF echo_write THEN writeln(ifile,error0); 
      END 
    ELSE
      BEGIN 
  
        {There is plenty of memory, create the output file.}
  
        overflow:=false;
        istrc:=1; 
        split_namr(inline,len,outfile,out_secu,out_crn,istrc, 
                                                      namr_type); 
        isz[1]:=ofile_len;
        isz[2]:=0;
  
        {Create the output file.} 
  
        ecrea(out_dcb,ierr,outfile,isz,1,out_secu,out_crn); 
        IF ierr<0 THEN
          BEGIN 
            fmp_error(ierr,outfile);
            IF NOT interactive THEN pform_ended:=true 
              ELSE repeat_prompt:=true; 
          END 
        ELSE
          BEGIN 
  
            {Fill the  outfile with -1 so garbage is not burned on
             the prom (between programs bumped, and in the directory
             track.}
  
            IF first_boot THEN start_neg_rec:=sys_len+1 
               ELSE start_neg_rec:=1; 
            {First fill the output buffer with -1.} 
            FOR i:=1 TO recd_len DO out_dcb.buff[i]:=-1;
            cur_ofile_rec:=start_neg_rec; 
            WHILE cur_ofile_rec<=ofile_len DO 
              BEGIN 
                writf(out_dcb,ierr,out_dcb.buff,recd_len,cur_ofile_rec);
  
                {obscure disk or fmp errors here don't really matter
                 here since the file needn't be filled with -1.}
                cur_ofile_rec:=cur_ofile_rec+1; 
              END;
            created:=true;
          END;
      END;
    abort_or_pform_ended:=abort OR pform_ended; 
  END;{outfile_process} 
  
{lu_process is a routine which deals with the lu and outfile
 prompt.} 
  
PROCEDURE lu_process; 
CONST 
  {Define the error messages associated with this process.} 
  error11='*ERROR - DUPLICATE PROM LU'; 
  error12='*ERROR - NO DVT FOR SPECIFIED LU'; 
  error13='*ERROR - INTERFACE TYPE FOR LU IS NOT 36B';
  error14='*ERROR - MORE PROM IMAGE FILES THAN BACKPLANE SLOTS';
  error17='*ERROR - BAD DRIVER PARAMETER IN DVT'; 
  prompt3='Boot system off PROM card (YES,NO) ? ';
  prompt4='PROM device logical unit (nn) ? '; 
  prompt5='PROM image file (namr) ? ';
VAR 
  words_on_prom:doubint; {The total number of words on PROM. A
                          doubint in case >32K word PROM cards
                          come along.}
  dvt_addr,              {The DVT address associated with a PROM lu.} 
  i,                     {A loop index.}
  ift_addr,              {The address of the IFT associated with the
                          above DVT.}