$pascal '92070-16288 REV.2001  800514'$ 
$heap 0$
PROGRAM PFORM;
{ 
*NAME:   PFORM
*SOURCE: 92070-18288
*RELOC:  92070-16288
*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.        *
****************************************************************} 
  
{PFORM is a utility for the RTE-L which configures a memory image 
 file which can be burned onto a PROM card.  This allows a user to
 boot his system from PROM, as well as run programs off PROM, thereby 
 achieving a useful memory only system.}
{Read in global constants, types, and variables.} 
  
 $include 'PFGBL'$
  
{External procedure definitions. Calls to FMP.} 
  
PROCEDURE readf(VAR idcb:dcb; VAR ierr:integer; VAR ibuff:buffer; 
                ilen:integer;  VAR len,num:integer);external; 
PROCEDURE writf(VAR idcb:dcb; VAR ierr:integer; VAR ibuff:buffer; 
          ilen,rec_num:integer);external; 
  
{Calls to external assembly language routines}
  
{FUNCTION andi is an external assembly language routine which 
 performs a logical and bit by bit with two integers. The 
 assembly source file is named &ANDI, its relocatable is %ANDI.}
FUNCTION andi(I1,I2:integer):integer;external;
  
{FUNCTION ori is an assembly routine which performs a bit by bit
 logical or of two (single word) integers. Its relocatable file name
 is %ORI.}
FUNCTION ori(I1,I2:integer):integer;external; 
  
{split_namr is an interface to the relocatable routine namr. The first
 integer parsed is always returned in security, and name is always an 
 ASCII file name or null. The interface is written in assembly language,
 with a source name of &PARSE, and a relocatable name of %PARSE.} 
{     iline:          The string containing namrs to be parsed. 
      len:            The actual length of the namr string. 
      name:           The returned file name if one was specified,
                      null otherwise. 
      security:       The security code if one was specified. If the
                      namr type was 1 (just an integer, i.e. an lu) 
                      then the integer is returned in this parameter. 
      cartridge:      The cartridge number if one was specified, zero 
                      if not. 
      start_char:     The character number in iline where the parse is
                      to begin.  This is updated by the routine namr
                      in order to allow repeated calls to split_namr
                      in case iline contains more than 1 namr string. 
      namr_type:      The type of the namr string returned by the 
                      routine namr. 0 means no string was parsed, 1 
                      means the string was an integer,3 means it
                      was an ASCII file name.  See the namr documentation 
                      (in the relocatable routine reference manual) 
                      for further information.} 
  
PROCEDURE split_namr(VAR iline:input_line;VAR len:integer;
                     VAR name:fname; VAR security,cartridge,start_char, 
                     namr_type:integer);external; 
  
{The remaining external procecures are in the segments.}
{See the segment source listings for documentation on the calling 
 and return sequences.} 
  
{PFS3 contains rt_conflict,getids,putids,getshort_ids,putshort_ids, 
 cleanup_process,fi_pr_rp_process,get_file_info,com_line_get,complete_directory,
 and is in memory during the entire stage 2 of PFORM.}
{PFS3 also contains calc_checksum,rec_to_ts,rec_extent,put_fde, 
 part3_init,fl_conflict,nam_in_fde,fix_long_ids,and fix_short_ids.} 
  
PROCEDURE part3_init;external;
FUNCTION fl_conflict(VAR name:fname; VAR idcb:dcb; VAR ibuff:buffer;
                      ffde_rec:integer):boolean; external;
FUNCTION rt_conflict(start_addr:integer; VAR idcb:dcb; VAR ibuff:buffer;
                 VAR name:fname; VAR curr_rec:integer; VAR skel_ids:
                 lo_idseg; VAR free_addr:integer):boolean;external; 
PROCEDURE rec_to_ts(rec:integer; VAR track,sector:integer);external;
PROCEDURE putfde(entry_num:integer; VAR idcb:dcb; VAR ibuff:buffer; 
               VAR name:fname; start_rec:integer; VAR fde:
               file_directory);external;
PROCEDURE nam_in_fde(VAR name:fname; VAR fde:file_directory);external;
PROCEDURE fix_long_ids;external;
PROCEDURE fix_short_ids;external; 
PROCEDURE cleanup_process;external; 
PROCEDURE fi_pr_rp_process;external;
PROCEDURE get_file_info;external; 
PROCEDURE com_line_get;external;
PROCEDURE complete_directory;external;
  
{PFS2 contains snap_process,lu_process,outfile_process, sys_process,
instuct_printout,crn_init_process and handle error, 
which use other routines contained in PFS2.}
  
PROCEDURE lu_process;external;
PROCEDURE snap_process;external;
PROCEDURE outfile_process;external; 
PROCEDURE sys_process;external; 
PROCEDURE handle_error(err_type: error_type; {Set of error cases} 
             err_number,err_line:  integer; VAR err_file: input_line; 
             err_flen:integer);external;
PROCEDURE crn_init_process;external;
PROCEDURE instruct_printout;external; 
{PFS1 contains header_printout, def_labls, and file_init.}
PROCEDURE header_printout;external; 
PROCEDURE file_init;external; 
PROCEDURE def_labls(VAR num_lb:integer; VAR labl:labl_array);external;
  
  
{This procedure handles the segment loads.} 
{@SGLD is a PASCAL library routine.}
  
PROCEDURE segload $ALIAS '@SGLD'$ (segment:fname);external; 
  
{fmp_error is called whenever FMP returns an error code in ierr.} 
{     ierr:        FMP error code, passed by value, 
       file_name:  Name of file which had an associated error.} 
  
PROCEDURE fmp_error(ierr:integer;VAR file_name:fname);
  BEGIN 
    io_error:=true; 
    writeln(ofile,'*ERROR - FMGR',ierr:5,'  ON FILE: ',file_name);
    IF echo_write THEN writeln(ifile,'*ERROR - FMGR',ierr:5,'  ON FILE: ',
                                                            file_name); 
  END; {fmp_err}
  
{pascl_errors catches all pascal runtime system generated errors. 
 It is in a segment since the actual error handling routine (handle_error)
 aborts the program.} 
  
PROCEDURE pascl_error $ALIAS '@PREP'$ (err_type: error_type;
             err_number,err_line: integer; VAR err_file:input_line; 
             err_flen:integer); 
  BEGIN 
  
    {Overlay any other segment.  This is the last segload.} 
  
    IF seg_num<>2 THEN segload('PFS2 ');
  
    {Call actual error handler.}
    handle_error(err_type,err_number,err_line,err_file,err_flen); 
  END;{pascl_error} 
  
{cnvrt_addr accepts an integer address and returns the record 
 number (recnum) and its offset (starting at 1 for address 0) 
 assuming the file concerned is a memory image, with no header.}
{    addr:     integer address, passed by value,
     recnum:   integer record numeer associated with address, returned, 
               so passed by name, 
     offset:   integer offset within the record associated with 
               the address, returned, so passed by name.     }
  
PROCEDURE cnvrt_addr(addr:integer; VAR recnum,offset:integer);
  BEGIN 
    recnum:=(addr DIV recd_len)+1;
    offset:=(addr MOD recd_len)+1;
  END; {cnvrt_addr} 
  
{getword is a function which is passed an address, and some parameters
 about the memory image file (no header),and returns the value stored 
 at the passed address. The parameter curr_rec is used to prevent needless
 disk reads (when the current buffer contains the needed word).}
{     address:    Address of word to be retrieved, passed by value, 
      idcb:       dcb of the memory image file the word is in, passed 
                  by name to achieve efficient parameter passing, 
      ibuff:      buffer associated with the above dcb. Type 1
                  file access bypasses the idcb. Passed by name 
                  for efficiency, 
      name:       file name where information exists. Used to pass
                  fmp_error the name when errors occur. Passed
                  by name,
      curr_rec:   The current record number which had the information 
                  currently in ibuff, used to prevent needless disk reads.
                  Passed by name since it may be modified.} 
  
FUNCTION getword(address:integer;VAR idcb:dcb; VAR ibuff:buffer;
                 VAR name:fname;VAR curr_rec:integer):integer;
  VAR 
  
    {integer type declarations.}
    ierr,                    {FMP error code identifier.} 
    len,                     {Number of characters actually read by a readf.} 
    offset,                  {Buffer offset of the desired word in the record.} 
    recd:integer;            {Record number which contains the desired word.} 
  
  BEGIN 
    cnvrt_addr(address,recd,offset);
    IF recd<>curr_rec THEN
      BEGIN 
  
        {Its a miss. Get the correct record.} 
  
        readf(idcb,ierr,ibuff,recd_len,len,recd); 
        IF ierr<0 THEN fmp_error(ierr,name) 
          ELSE curr_rec:=recd;
      END;
    IF ierr>=0 THEN getword:=ibuff[offset]; 
  END; {getword}
  
{putword stores the word at the passed address into the appropriate 
 memory image file (no header). The word is actually stored onto the
 disk when the boolean ship is true, or when a record boundary is reached.} 
{     word:       Integer to be stored at the specified address, passed 
                  by value, 
      address:    Integer address where word is to be stored, passed by 
                  value,
      idcb:       dcb of the memory image file the word is in,passed
                  by name,
      ibuff:      buffer associated with the above dcb. 
      name:       File name where the information is to be stored. Used 
                  to pass fmp_error the name when errors occur. Passed
                  by name,
      curr_rec:   The current record number which had the information 
                  currently in ibuff, used to prevent needless disk reads.
      ship:       A boolean passed by value, when true, ibuff is written
                  to the disk, when false, ibuff is only written to the 
                  disk if the offset is a record boundary.} 
  
PROCEDURE putword(word,address:integer; VAR idcb:dcb; VAR ibuff:buffer; 
                  VAR name:fname; VAR curr_rec:integer; ship:boolean);
  VAR 
    {integer type declarations.}
    ierr,                         {FMP error code returned here.} 
    len,                          {Actual number of characters read 
                                   by a readf call.}
    offset,                       {Buffer offset of word to store.} 
    recd:integer;                 {Record number associated with address.}
  
  BEGIN 
    cnvrt_addr(address,recd,offset);
    IF recd<>curr_rec THEN
      BEGIN 
  
        {Its a miss. Get the correct record.} 
  
        readf(idcb,ierr,ibuff,recd_len,len,recd); 
        IF ierr<0 THEN fmp_error(ierr,name) 
          ELSE curr_rec:=recd;
      END;
    IF ierr>=0 THEN 
      BEGIN 
        ibuff[offset]:=word;
        IF ship OR (offset=recd_len) THEN 
          BEGIN 
            writf(idcb,ierr,ibuff,recd_len,recd); 
            IF ierr<0 THEN fmp_error(ierr,name);
          END;
      END;
  END; {putword}
  
  
 {readline gets a line from the ifile device or file, returns 
  the length of the line of text, and echoes the line to terminal or
  other lu if needed. It always causes a line feed to occure at the 
  output files (for readability.)}
 {     buff:     The buffer of the input line to be read. Passed
                 by name since the buffer is returned to the caller.
       len:      The integer number of characters actually read.
                Passed by name since it is returned.} 
  
   PROCEDURE readline(VAR buff:input_line; VAR len:integer);
     VAR
       {char type declaration.} 
       character:char;             {Used to read a character. PASCAL reads
                                    can not be done with packed data types.}
  
       i:integer;                  {Used as a counter.} 
  
     BEGIN
       len:=0;
       character:=' ';
  
  
       {Every prompt loop uses readline.  So set repeat_prompt
        false here to save time and code.}
  
       repeat_prompt:=false;
  
       {Resetting ifile in interactive cases allows recover from
        the single <cr> case, as well as the echoing feature using
        only 2 file dcb's (rather than 3).} 
  
       IF interactive THEN
         reset(ifile);
  
       {read first character, set eoln(ifile) false unless its a <cr>.} 
       {A <cr> here sets eof(ifile) true but not eoln(ifile).}
       {Suck up any stray spaces as well.}
       WHILE (character=' ') AND NOT eof(ifile) DO read(ifile,character); 
  
       IF eof(ifile) AND NOT interactive THEN pform_ended:=true 
       ELSE IF eof(ifile) AND interactive THEN
         BEGIN
           repeat_prompt:=true; 
           rewrite(ifile);
           writeln(ifile);
           IF echo_write THEN writeln(ofile); 
  
           {In this next case, (i.e. RU,PFORM,1,FILE) 
            the <cr> typed to the terminal won't be 
            automatically echoed to the file, so
            we really need two writeln calls.}
           IF NOT terminal_outfile THEN writeln(ofile); 
         END
       ELSE 
         BEGIN
           WHILE (len<line_length) AND (NOT (eoln(ifile)
                 OR eof(ifile))) DO 
             BEGIN
               len:=len+1;
               buff[len]:=character;
               read(ifile,character); 
               IF eoln(ifile) THEN
                 BEGIN
                   {Last character read. Get it in the buffer.} 
                   len:=len+1;
                   IF len<=line_length THEN 
                     buff[len]:=character;
                 END; 
             END; 
  
  
           {Must rewrite here to allow writes after reads.} 
  
           IF interactive THEN rewrite(ifile);
  
           {Echo the line to various devices if necessary.} 
  
           IF echo_read THEN writeln(ofile,buff:len); 
  
           {Send a blank line to output files.} 
           writeln(ofile);
           IF echo_write THEN writeln(ifile); 
           {Did the user type /A (abort) or /E (end PFORM)?}
           IF (len<=2) AND (buff[1]='/') AND (buff[2]='A') THEN 
             abort:=true; 
           IF (len<=2) AND (((buff[1]='/') AND (buff[2]='E')) OR
                            ((buff[1]='E') AND (buff[2]='X'))) THEN 
              pform_ended:=true;
         END; 
       abort_or_pform_ended:=abort OR pform_ended;
     END; {readline}
  
{writline writes certain strings to the files.} 
{     inline:    The input line to be written. Passed by name for 
                 sake of efficiency.} 
PROCEDURE writline(VAR inline:input_line);
  BEGIN 
    writeln(ofile,inline);
    IF echo_write THEN writeln(ifile,inline); 
  END; {writline} 
  {The main program now begins.}
  
  BEGIN 
    segload('PFS1  ');
    seg_num:=1; 
  
    first_pform:=true;
  
    {Define the PASCAL file variables IFILE and OFILE, depending
     upon the run string.}
  
    file_init;
  
    {Output the header information.}
    header_printout;
  
    {Define the labels from the snapshot file which are to be found.} 
  
    def_labls(num_labls,labls); 
  
    segload('PFS2  ');
    seg_num:=2; 
  
    repeat_prompt:=true;
    WHILE repeat_prompt DO
      sys_process;
  
    repeat_prompt:=true;
  
    {Snap prompt handling is next.} 
  
    WHILE repeat_prompt AND NOT (abort_or_pform_ended) DO 
      snap_process; 
  
    {The main program loops here until aborted or ended}
  
    WHILE NOT (abort_or_pform_ended) DO 
      BEGIN {*****} 
        init_complete:=false; 
        first_boot:=false;
  
        {Segment 3 may be in memory, so load segment 2.}
  
        IF seg_num<>2 THEN
          BEGIN 
            segload('PFS2  ');
            seg_num:=2; 
          END;
  
      {Prompt for lu and outfile, process those strings.} 
  
      lu_process; 
  
      {Prompt for and process cartridge initialization information.}
  
      crn_init_process; 
  
      abort_or_pform_ended:=abort OR pform_ended; 
  
      {If interactive first pass, output instructions for part3.} 
  
      IF (interactive AND first_pform AND NOT (abort_or_pform_ended)) THEN
        BEGIN 
          first_pform:=false; 
          instruct_printout;
        END;
  
      {Now in part 3 of the PFORM process.} 
  
      IF NOT (abort_or_pform_ended) THEN
        BEGIN {****}
          full_directory:=false;
          make_fill_file:=true; 
  
          {PFS3 contains all of the non-I/0 procedures used during
          the third part of the PFORM process.} 
  
          IF seg_num<>3 THEN
            BEGIN 
              segload('PFS3  ');
              seg_num:=3; 
            END;
  
          {Initialize file directory entries, output messages and 
           headers.}
  
          part3_init; 
          {This loop handles the configuration portion
           (part 3) of PFORM.}
  
          WHILE NOT (next OR abort_or_pform_ended) DO 
            BEGIN {***} 
  
              {Prompt for, and read the command string.}
  
              com_line_get; 
              IF NOT (repeat_prompt OR abort_or_pform_ended) THEN 
                BEGIN {**}
                  istrc:=1; 
                  command:='      ';
  
                  {The split_namr routine is used to seperate commands.}
  
                  split_namr(inline,len,command,isecu,icrn,istrc, 
                                                         namr_type);
  
                  {Commands are significant to 2 characters only, 
                   so define the abbreviated  command.} 
  
                  abrv_cmmd[1]:=command[1]; 
                  abrv_cmmd[2]:=command[2]; 
  
                  IF (abrv_cmmd<>'BU') AND (abrv_cmmd<>'RP') AND
                      (abrv_cmmd<>'FI') AND (abrv_cmmd<>'PR') AND 
                      (abrv_cmmd<>'NE') THEN
                      BEGIN 
  
                        {No recognized command was realized.} 
  
                        com_error:=true;
                        writeln(ofile,error3);
                        IF echo_write THEN writeln(ifile,error3); 
                      END 
  
                  {Otherwise, start processing the seperate cases.} 
  
                  ELSE IF abrv_cmmd='BU' THEN 
                    BEGIN 
                      com_error:=false; 
  
                      {Is the record currently at a 2K boundary?} 
  
                      IF (((cur_ofile_rec-1) MOD recds_per_2k)<>0)
                      THEN
                        BEGIN 
  
                          {Not at 2K boundary.  BUMP counter.}
  
                          temp:=(recds_per_2k+1) -
                                (cur_ofile_rec MOD recds_per_2k); 
                        END 
                          ELSE
                            {Already at 2k boundary. BUMP 2k.}
                            temp:=recds_per_2k; 
  
                      {temp now countains the number of records to
                       BUMP forward.} 
  
                      cur_ofile_rec:=cur_ofile_rec+temp;
                      bump:=true; 
                      rem_blocks:=fde_recnum-cur_ofile_rec; 
                      IF rem_blocks<=0 THEN 
                        BEGIN 
  
                          {We BUMPED past the file directories. 
                           BUMP backwards, and give overflow of 
                           memory warning.} 
  
                          writeln(ofile,error4);
                          IF echo_write THEN writeln(ifile,error4); 
                          cur_ofile_rec:=cur_ofile_rec-temp;
                        END 
                      ELSE
                        BEGIN 
  
                          {Output the track, sector, information.}
  
                          prom_num:=((cur_track*words_per_track+
                                     cur_sector*64) DIV 2048) +1; 
                          writeln(ofile,'        ',command,temp:8,prom_num:8, 
                             cur_track:8,cur_sector:8,rem_blocks);
                          IF echo_write THEN writeln(ifile,'        ',command,
                               temp:8,prom_num:8,cur_track:8,cur_sector:8,
                               rem_blocks); 
                          rec_to_ts(cur_ofile_rec,cur_track,cur_sector);
                        END 
                      END 
                    ELSE IF abrv_cmmd='NE' THEN 
                      BEGIN 
                        next:=true; 
  
                        {Make the file directory entry for
                         the cartridge itself, fill cartridge,
                         mark end of cartridge.}
  
                        IF NOT (first_boot AND no_directory) THEN 
                          complete_directory; 
                      END 
                    ELSE
                      get_file_info;
                  IF NOT (bump OR overflow OR  com_error OR next
                          OR dupl_fname OR (ierr<0)) THEN 
  
  
                     {Process the FI,PR, and RP commands.}
  
                     fi_pr_rp_process;
                END; {**} 
            END;  {***} 
        END; {****} 
   END; {*****} 
 IF seg_num<>3 THEN 
   segload('PFS3  '); 
 cleanup_process; 
  END.  {PFORM}