$pascal '92071-1X291 REV.2041  800811'$ 
$heap 0$
$segment$ 
PROGRAM PFS3; 
{ 
* 
*NAME:    PFS3
*SOURCE:  92071-18291 
*RELOC:   92071-16291 
*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.        *
****************************************************************
} 
  
{PFS3 contains the routines which modify the last RP command, as well 
 as a few other commands which I expect to be used infrequently.
 This segment should only have to be loaded occasionally, and often never.
 Each  routine in PFS3 which is externaled in the main program
 could readily be moved to some other segment if desired.}
 {Read in the global constants, variables and types.} 
$include '&PFGBL'$
  
{Declaration of FMP routines.}
  
PROCEDURE purge(VAR idcb:dcb; VAR ierr:integer; VAR name:string6; 
                VAR isecu,icrn:integer);external; 
PROCEDURE fmp_close $ALIAS 'CLOSE'$(VAR idcb:dcb);external; 
PROCEDURE readf(VAR idcb:dcb; VAR ierr:integer; VAR ibuff:buffer; 
                ilen:integer;  VAR len,num:integer);external; 
PROCEDURE writf(VAR idcb:dcb; VAR ierr:integer; VAR ibuff:buffer; 
          ilen,rec_num:integer);external; 
  
{This is an exec abort call, used when handle_error is trapped.}
PROCEDURE exec(ecode,place_holder:integer);external;
  
{PFORM calls prtn to return the exit path to the calling program.}
PROCEDURE prtn(prams:prtn_prams);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; 
  
{handle_error handles certain forms of PASCAL errors, such as 
 a <cr> from a terminal causing a program abortion.}
{This routine is used, rather than the standard run time error
 package for two reasons.  First of all, it is smaller and
 is in a segment.  Second, this routine makes errors look like
 normal PFORM error messages, rather than PASCAL errors.} 
{   err_type:         Describes the class of the error message. 
    err_number:       Some classes of errors have an associated 
                      number, passed in this paramater. 
    err_line:         Some classes of errors occur at a specific
                      source line, and its number is passed here. 
    err_file:         Some errors pass the PASCAL file name identifier
                      as a paramater (i.e. fmp). Note that this 
                      paramater contains the internal (i.e. variable
                      name) representation of the file name, not
                      its actual external representation (i.e. namr). 
    err_flen:         Number of significant characters in the string
                      err_file.}
PROCEDURE handle_error (err_type: error_type; 
             err_number, err_line: integer; VAR err_file: input_line; 
             err_flen:integer); 
 LABEL 99;
 CONST
  runtime='PASCAL RUNTIME #'; 
  at_line=' AT LINE ';
  segl='SEGMENT LOAD FAILURE IN ';
  io_error='PASCAL IO #'; 
 VAR
   error_file:string6;      {The name of the file in error.}
   i:integer; 
 BEGIN
  
   IF err_type=warn THEN goto 99; 
   {The file name is not always good. Try to detect 
    this case and prevent garbage from being displayed.}
  
   IF err_flen=0 THEN error_file.file_name:='      '
     ELSE 
       FOR i:= 1 TO 6 DO error_file.file_name[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.file_name='IFILE ' THEN error_file:=input_file 
     ELSE IF error_file.file_name='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.} 
  
  close(ofile); 
  close(ifile); 
  
  {Do a rewrite to the terminal.  All these errors will 
   go there only.}
  
  rewrite(ofile,login_lu.file_name);
  {No longer can the echo feature be used properly.}
  echo_prompt:=false; 
   CASE err_type OF 
  
     fmp: 
       fmp_error(err_number,error_file);
     seg: 
       BEGIN
  
         {Output segment load error.} 
  
         writeln(ofile,star_error,segl,error_file.file_name); 
       END; 
     io:
  
       BEGIN
  
         {These errors have their own code.}
         {Output the general case error message.} 
         write(ofile,star_error,io_error,err_number:3); 
         writeln(ofile,at_line,err_line:5); 
       END; 
     run: 
  
       BEGIN
  
         {Runtime errors also  have their own code.}
         write(ofile,star_error,runtime,err_number:3);
         writeln(ofile,at_line,err_line:5); 
       END; 
     END; {Case Statement.} 
  
   {Abort the program with exec call. 
    First give the abortion message.} 
  
   writeln(ofile,pform_prompt.five_char,aborted); 
  
   {Cleanup stray files.} 
  
   IF made_sys_file THEN
     purge(sys_dcb,ierr,sys_file,sys_secu,sys_crn); 
  
   IF made_prom_file THEN 
     purge(prom_dcb,ierr,prom_file,prom_secu,prom_crn); 
   {Close the snap.}
  
   fmp_close(snap_dcb); 
  
  
   {Tell scheduling program the abort path was taken.}
  
   prtn('ABORTED   ');
  
   {Exit with an exec call.}
  
   exec(6,0); 
99: 
 END;{handle_error} 
  
{cleanup_files is the last routine called by PFORM.  It closes
 the PFORM system and snap file, and purges the modified system 
 and last PROM image file if the run was aborted (/A).} 
  
PROCEDURE cleanup_files; $direct$ 
  CONST 
    bootable_file='BOOTABLE PROM IMAGE FILE IS: ';
    modified_system='MODIFIED SYSTEM IMAGE FILE IS: ';
    period='.'; 
  BEGIN 
  
   IF pform_ended THEN
     BEGIN
  
       {Set up the prtn return.}
  
       prtn('ENDED     ');
        {Close the modified system file.} 
  
        fmp_close(sys_dcb); 
  
        {Output the messages.}
  
        IF made_sys_file THEN 
          BEGIN 
  
            writeln(ofile,pform_prompt.five_char,cmpleted); 
            IF echo_prompt THEN writeln(ifile,pform_prompt.five_char, 
                                             cmpleted); 
            IF boot THEN
              BEGIN 
               write(ofile,bootable_file);
               IF echo_prompt THEN write(ifile,bootable_file);
             END ELSE 
               BEGIN
  
  
                 {Give the user the name of the new system file.} 
  
                 write(ofile,modified_system);
                 IF echo_prompt THEN write(ifile,modified_system);
               END; 
            writeln(ofile,sys_file.file_name,period); 
            IF echo_prompt THEN writeln(ifile,sys_file.file_name,period); 
          END;
      END 
   ELSE IF abort THEN 
     BEGIN
  
       IF made_sys_file THEN purge(sys_dcb,ierr,sys_file,sys_secu,sys_crn); 
       IF made_prom_file THEN purge(prom_dcb,ierr,prom_file,prom_secu,
                                                            prom_crn);
  
  
       {Set up prtn return.}
  
       prtn('ABORTED   ');
       {Output message.}
       writeln(ofile,pform_prompt.five_char,aborted); 
       IF echo_prompt THEN writeln(ifile,pform_prompt.five_char,aborted); 
     END; 
  
    {Close the all currently open files.} 
  
    fmp_close(snap_dcb);
    close(ifile); 
    close(ofile); 
  END; {cleanup_files}
  
{ss_process changes the system security code to some new value.}
PROCEDURE ss_process; $direct$
  BEGIN 
  
    namr(namr_buffer,inline,line_length,istrc); 
  
  
    WITH namr_buffer DO 
     IF NOT ((types.param1=numeric) OR (types.param1=ascii)) THEN 
       error(bad_type)
       ELSE {Put the new code into the system.} 
         putword(param1.int1,sec_addr,sys_dcb,sys_dcb.buff, 
                 sys_file,rec_in_sys_dcb,true); 
  END; {ss_process} 
  
{st_process defines the startup program, and puts any RMPAR 
 paramaters into its id.  If some other program has previously
 been defined to be the start program, its RMPAR paramaters 
 are cleared.}
PROCEDURE st_process; $direct$
  VAR 
    post:boolean;               {Tells putword to post to disk.}
    i:integer;                  {Loop index for changing rampar params.}
  BEGIN 
  
    IF NOT good_rp  THEN error(bad_command) 
      ELSE
        BEGIN 
  
          {Put the current id address at $BOOT.}
  
          putword(cur_id_addr,start_addr,sys_dcb,sys_dcb.buff,
                  sys_file,rec_in_sys_dcb,true);
  
          post:=false;
          IF start_specified THEN {Zero out previous RMPAR paramaters.} 
            FOR i:=1 TO 5 DO
              BEGIN 
                IF i=5 THEN post:=true; 
                putword(0,last_start_id_addr+i,sys_dcb,sys_dcb.buff,
                        sys_file,rec_in_sys_dcb,post);
              END;
  
          start_specified:=true;
          last_start_id_addr:=cur_id_addr;
  
          {Now fill in the correct, new, RMPAR paramaters.} 
  
          post:=false;
  
          FOR i:=1 TO 5 DO
            BEGIN 
              namr(namr_buffer,inline,line_length,istrc); 
  
              IF i=5 THEN post:=true; 
  
              {Shove in ID regardless of type.} 
  
              putword(namr_buffer.param1.int1,cur_id_addr+i,sys_dcb,
                      sys_dcb.buff,sys_file,rec_in_sys_dcb,post); 
            END;
        END;
  END;  {st_process}
  
{question_process handles the help (??) facility.}
PROCEDURE question_process; $direct$
  CONST 
    msg1= 
' Commands which are valid in the present context are as follows:'; 
    msg2= 
'   SS,newcode          Change the system security code to newcode.'; 
    msg3= 
'   PT                  Display a partition table which describes the'; 
    msg4= 
'                       size, location, and occupant of all partitions.'; 
    msg5= 
'   RP,prog,[newname]   Construct an id segment for the program (using';
    msg6= 
'                       newname if specified), relink the program if';
    msg7= 
'                       necessary, and store the program in the PROM';
    msg8= 
'                       image file.'; 
    msg9= 
'   LK,prog             Relink and fix the short id segments of the'; 
    msg10=
'                       program (type 6) file if necessary, and store'; 
    msg11=
'                       the file onto the PROM image file.  The program'; 
    msg12=
'                       can only be executed if the destination system';
    msg13=
'                       has a program containing IDRPL (i.e. FMGR).'; 
    msg13a= 
'   FI[LE],namr         Store the named file (libraries, data, etc.)';
    msg13b= 
'                       onto the PROM image file.'; 
    msg14=
'   /E                  End the PFORM process.';
    msg15=
'   /A                  Abort the PFORM process.  The output file made';
    msg16=
'                       by PFORM is purged.'; 
    msg17=
'   /C (also NEXT)      Complete the formatting of the current PROM image'; 
    msg18=
'                       file and continue formatting another file.';
    msg19=
'   The remaining commands modify the last stored program (if any).'; 
    msg20=
'   PR[IORITY],n        The program is to be of priority n.'; 
    msg21=
'   SZ,nn               Size of the program including system common (if'; 
    msg22=
'                       used) in K words.  When specified, this overrides'; 
    msg23=
'                       the size as defined to the loader.';
    msg24=
'The following command modifies the last RPed program (if any).'; 
    msg25=
'   ST[ART][,p1]..[,p5] The program is to be the startup program';
    msg26=
'                       with the specified optional RMPAR paramaters.'; 
   PROCEDURE skip_line;  {Mearly skips a line to the files.}
     BEGIN
       writeln(ofile);
       IF echo_prompt THEN writeln(ifile);
     END; 
 BEGIN {question_process} 
  
   {Output the instructions.} 
   writline(msg1);
   writline(msg2);
   writline(msg3);
   writline(msg4);
   writline(msg5);
   writline(msg6);
   writline(msg7);
   writline(msg8);
   writline(msg9);
   writline(msg10); 
   writline(msg11); 
   writline(msg12); 
   writline(msg13); 
   writline(msg13a);
   writline(msg13b);
   writline(msg14); 
   writline(msg15); 
   writline(msg16); 
   writline(msg17); 
   writline(msg18); 
   {Skip a line for cosmetic reasons.}
  
   skip_line; 
  
   writline(msg19); 
   writline(msg20); 
   writline(msg21); 
   writline(msg22); 
   writline(msg23); 
   skip_line; 
   writline(msg24); 
   writline(msg25); 
   writline(msg26); 
 END; {question_process}
  
{pt_process handles the PT command.  It outputs the sizes 
 and occupants (if original system was a BUILD output system) 
 of each partition.}
PROCEDURE pt_process;$direct$ 
  LABEL 99; 
  CONST 
    header= 
'PRTN NUM  LOW PAGE  LENGTH  OCCUPANT'; 
    none='<NONE>';
    unmapped='Unmapped systems have no partition tables.';
    none_defined='No partitions have been defined so far.'; 
   VAR
     cur_mat_addr,            {Address of current MAT being scanned.} 
     id_addr_for_mat,         {The id segment address contained in
                               the current MAT being scanned.}
     length,                  {Length of current partition.}
     low_page,                {Starting page number of current partition.}
     mat_number:integer;      {Current mat number being scanned.} 
     occupant:string6;        {Name of occupant of partition.}
  BEGIN 
  
   IF NOT mapped_system THEN
     BEGIN
       writline(unmapped);
       goto 99; 
     END; 
  
   IF matv_num<=0 THEN
     BEGIN
       writline(none_defined);
       goto 99; 
     END; 
  
   {Output the header.} 
  
    writline(header); 
  
    {Initialize the loop starting values.}
  
    mat_number:=0;
    WHILE (mat_number<matv_num) DO
      BEGIN 
        cur_mat_addr:=mat_addr+mat_length*mat_number; 
        mat_number:=mat_number+1; 
        id_addr_for_mat:=getword(cur_mat_addr,sys_dcb,sys_dcb.buff, 
                                 sys_file,rec_in_sys_dcb);
        length:=getword(cur_mat_addr+1,sys_dcb,sys_dcb.buff,
                              sys_file,rec_in_sys_dcb)+1; 
        low_page:=getword(cur_mat_addr+2,sys_dcb,sys_dcb.buff,
                             sys_file,rec_in_sys_dcb);
        IF (id_addr_for_mat=0) THEN 
          occupant.file_name:=none
          ELSE
            BEGIN 
              {Get the name from the id in the disk file.}
  
               occupant.int1:=getword(id_addr_for_mat+12,sys_dcb, 
                                   sys_dcb.buff,sys_file,rec_in_sys_dcb); 
               occupant.int2:=getword(id_addr_for_mat+13,sys_dcb, 
                                   sys_dcb.buff,sys_file,rec_in_sys_dcb); 
               occupant.int3:=getword(id_addr_for_mat+14,sys_dcb, 
                                   sys_dcb.buff,sys_file,rec_in_sys_dcb); 
               occupant.file_name[6]:=' ';
            END;
  
         {Output information about this partition.} 
  
          writeln(ofile,mat_number:8,low_page:10,length:8,space2, 
                        occupant.file_name);
          IF echo_prompt THEN 
            writeln(ifile,mat_number:8,low_page:10,length:8,space2, 
                        occupant.file_name);
        END;
  99: 
  END; {pt_process} 
{sz_process handles the SZ command.  It sizes the ID in memory, and 
 also changes the size in the program header on the prom image file.} 
  
PROCEDURE sz_process; $direct$
  LABEL 99; 
  CONST 
    too_small='SPECIFIED SIZE IS SMALLER THAN MINIMUM REQUIRED';
    none_big_enough='NO PARTITION LARGE ENOUGH FOR PROGRAM';
  TYPE
    id_word_25= 
      PACKED RECORD 
        CASE boolean OF 
          true:(all_memory:boolean; 
                size_less_1:five_bits;
                high_base_page_addr:ten_bits);
          false:(int:integer) 
         END; 
  VAR 
    old_id_field:id_word_25;  {Previous value of the id field 
                               containing the loaded size.} 
    i,                    {Loop index for repairing the checksum.}
    new_size:integer;     {The specified size.} 
  BEGIN 
  
    {See if the command is valid in this context.}
  
    IF NOT ((good_rp OR good_lk) AND mapped_system) THEN error(bad_command) 
    ELSE
      BEGIN 
  
        {Parse the string to pick up the new size.} 
  
        namr(namr_buffer,inline,line_length,istrc); 
        new_size:=namr_buffer.param1.int1;
  
        {Compensate for common if used.}
  
        IF uses_common THEN new_size:=new_size-sys_common_sz; 
  
        IF namr_buffer.types.param1<>numeric THEN 
          BEGIN 
  
            {An integer was not passed, give bad param type error.} 
  
            error(bad_type);
            goto 99;
          END 
        ELSE IF (new_size>32) OR (new_size<1) THEN
          BEGIN 
  
            {Paramater is out of range.}
  
            error(bad_range); 
            goto 99;
          END 
        ELSE IF (new_size<min_prog_size) THEN 
          BEGIN 
  
            {Size is smaller than minimum required.}
  
            error(too_small); 
            goto 99;
          END 
        ELSE
          BEGIN 
  
            {No errors so far. See if there is a big
             enough partition defined.} 
  
  
            IF (new_size>max_partition_size) THEN 
              BEGIN 
  
                error(none_big_enough); 
                goto 99;
              END 
            ELSE
              BEGIN 
  
                IF rp_true_lk_false THEN
                  BEGIN 
  
                    {The last program related command was rp, so fix
                     the in memory id.} 
  
                    old_id_field.int:=getword(cur_id_addr+24,sys_dcb, 
                                      sys_dcb.buff,sys_file,rec_in_sys_dcb);
                    old_id_field.size_less_1:=new_size-1; 
                    putword(old_id_field.int,cur_id_addr+24,sys_dcb,
                            sys_dcb.buff,sys_file,rec_in_sys_dcb,true); 
  
                    {If done_with_rp is true, there is no type
                     six file header to modify.  Hence exit.} 
  
                    IF done_with_rp THEN goto 99; 
                  END;
                {Fix up the header record of the program to 
                 reflect the changed size.} 
  
                readf(prom_dcb,ierr,prom_dcb.buff,recd_len,irec,
                                                  first_prog_rec);
  
                {No errors should occur here except for 
                 disc errors.}
  
                IF ierr<0 THEN
                  BEGIN 
                    fmp_error(ierr,prom_file);
                    goto 99;
                  END;
  
                prom_dcb.id.l20.size_less_1:=new_size-1;
  
                {Repair the checksum.}
  
                WITH prom_dcb.l20_long_id DO
                  BEGIN 
                    ext.idseg_checksum:=0;
  
                    FOR i:=1 TO 35 DO 
                      ext.idseg_checksum:=ext.idseg_checksum+ints[i]; 
                  END; {With} 
  
                {Put the fixed header back on the prom image.}
  
                writf(prom_dcb,ierr,prom_dcb.buff,irec,first_prog_rec); 
                IF ierr<0 THEN
                  fmp_error(ierr,prom_file);
              END;
          END;
       END; 
   99:
   END; {sz_process}
  
{pr_process changes a programs priority in its header, as well
 as its ID (if stored with RP).}
PROCEDURE pr_process; $direct$
  LABEL 99; 
  VAR 
   i:integer;    {Loop index for repairing the checksum.} 
  BEGIN 
    IF NOT (good_rp OR good_lk) THEN error(bad_command) 
      ELSE
        BEGIN 
  
          {Pick up the new priority.} 
  
          namr(namr_buffer,inline,line_length,istrc); 
  
          IF namr_buffer.types.param1<>numeric THEN 
            error(bad_type) 
          ELSE IF namr_buffer.param1.int1<1 THEN
            error(bad_range)
  
          {Note that the priority field is in the same location of
           the ids for both mapped and unmapped system.}
  
           ELSE IF rp_true_lk_false THEN
             {Last program was stored via RP, so fix its ID.} 
            putword(namr_buffer.param1.int1,cur_id_addr+6,
                        sys_dcb,sys_dcb.buff,sys_file,rec_in_sys_dcb,true); 
  
             {Fix up the in header on the prom.}
  
             readf(prom_dcb,ierr,prom_dcb.buff,recd_len,irec, 
                                              first_prog_rec);
  
             IF ierr<0 THEN 
               BEGIN
                 fmp_error(ierr,prom_file); 
                 goto 99; 
               END; 
  
             prom_dcb.buff[7]:=namr_buffer.param1.int1; 
  
             {Fix the checsums.}
  
             IF mapped_system THEN
               BEGIN
  
                 prom_dcb.buff[32]:=0;
                 FOR i:=1 TO 31 DO
                   prom_dcb.buff[32]:=prom_dcb.buff[i]+prom_dcb.buff[32]; 
               END
             ELSE 
               BEGIN
                 prom_dcb.buff[36]:=0;
                 FOR i:=1 TO 35 DO
                   prom_dcb.buff[36]:=prom_dcb.buff[i]+prom_dcb.buff[36]; 
               END; 
             writf(prom_dcb,ierr,prom_dcb.buff,recd_len,first_prog_rec);
             IF ierr<0 THEN 
               fmp_error(ierr,prom_file); 
        END;
  99: 
  END;.{pr_process,PFS3}