$pascal '92071-16288 REV.2041  800710'$ 
$heap 0$
PROGRAM PFORM;
{ 
*NAME:   PFORM
*SOURCE: 92071-18288
*RELOC:  92071-16288
*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.        *
****************************************************************} 
  
{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.}
  
 {I want this label to only have meaning in the main program.}
 LABEL 99;
  
{Read in global constants, types, and variables. These have meaning 
 to the main, and all segments.}
  
 $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; 
  
{Since the longest segment uses purge, it might as well be in the main.}
PROCEDURE purge(VAR idcb:dcb; VAR ierr:integer; VAR name:string6; 
                VAR isecu,icrn:integer);external; 
  
{Calls to external assembly language routines}
FUNCTION ifbrk:integer;external;
PROCEDURE namr(VAR parse_buffer:namr_parse_buffer; VAR ibuff:input_line;
               length:integer; VAR istrc:integer);external; 
  
  
{The remaining external procedures are in the segments.}
{The procedures handle their own error conditions, closing involved 
 program file upon an unrecoverable error.  The boolean procedures
 return true if no errors occured, and false if errors occured. 
 Non boolean procedures have no unrecoverable error conditions.}
{See the segment source listings for documentation on the calling 
 and return sequences.} 
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 file_init;$direct$ external;
PROCEDURE def_partitions;$direct$ external; 
PROCEDURE cleanup_files;$direct$ external;
PROCEDURE ss_process;$direct$ external; 
PROCEDURE question_process;$direct$ external; 
PROCEDURE sz_process;$direct$ external; 
PROCEDURE st_process;$direct$ external; 
PROCEDURE pt_process; $direct$ external;
PROCEDURE scratch_to_system; $direct$ external; 
PROCEDURE pr_process;$direct$ external; 
FUNCTION fix_short_ids:boolean;$direct$external;
FUNCTION fix_long_id:boolean;$direct$external;
FUNCTION rp_error_check:boolean;$direct$external; 
PROCEDURE complete_directory;$direct$ external; 
FUNCTION check_file_for_errors:boolean;$direct$ external; 
PROCEDURE store_file(VAR source_dcb:dcb;
                   first_record,last_record:integer);external;
FUNCTION relink_check:boolean;$direct$ external;
FUNCTION perform_relink:boolean;$direct$ external;
PROCEDURE prom_description(VAR name:string6; VAR length:integer); 
                                                      external; 
PROCEDURE dir_init_process; $direct$ external;
PROCEDURE lu_process; $direct$ external;
FUNCTION bu_process:boolean; $direct$ external; 
  
{This procedure handles the segment loads.} 
{@SGLD is a PASCAL library routine.}
  
PROCEDURE segload $ALIAS '@SGLD'$ (segment:fname);external; 
  
{segment_load uses segload and information about the segment
 structure contained in set types to ease the segmentation process.}
{  called_routine:          An enumerated type which indicates the
                            subroutine name which is to be called 
                            immediately following segment_load.}
  
PROCEDURE segment_load(called_routine:all_routines); $direct$ 
  BEGIN 
  
    {Changing the various case conditions, and possibly the 
     all_routines type (when adding or deleting routines),
     is all that is required when changing the segmentation 
     structure.}
  
    CASE called_routine OF
      file__init: 
          IF segnum<>1 THEN 
            BEGIN 
              segload('PFS1  ');
              segnum:=1;
             END; 
      lu__process,dir__init__process,def__partitions: 
          IF segnum<>2 THEN 
            BEGIN 
              segload('PFS2  ');
              segnum:=2;
            END;
      cleanup__files,ss__process,question__process,sz__process, 
      st__process,handle__error,pr__process,pt__process:
          IF segnum<>3 THEN 
            BEGIN 
              segload('PFS3  ');
              segnum:=3;
            END;
       check__file__for__errors,rp__error__check,store__file, 
       bu__process,prom__description,relink__check,fix__short__ids, 
       fix__long__id,complete__directory,scratch__to__system: 
           IF segnum<>4 THEN
             BEGIN
               segload('PFS4  '); 
               segnum:=4; 
             END; 
        perform__relink:
           IF segnum<>5 THEN
             BEGIN
               segload('PFS5  '); 
               segnum:=5; 
             END; 
    END; {CASE} 
  END; {segment_load} 
  
{break_program is a boolean function which calls ifbrk
 to test the break flag.  It returns true if the flag is
 set, false otherwise.  In the true case, abort is also 
 set true to achieve the proper exit.}
FUNCTION break_program:boolean; $direct$
  BEGIN 
    IF ifbrk=0 THEN break_program:=false
    ELSE
      BEGIN 
        break_program:=true;
        abort:=true;
      END;
  END; {break_program}
  
{set_error_path is called by error and fmp_error when input 
 is not interactive.  It uses the global error_path to determine
 the appropriate action.} 
PROCEDURE set_error_path; $direct$
  BEGIN 
  
    CASE error_path OF
      uncon_abort: abort:=true; 
      uncon_end:   pform_ended:=true; 
      OTHERWISE 
    END;
  END; {Set error path.}
  
{fmp_error is called whenever FMP returns an error code in ierr.} 
{     ierr:        FMP error code, passed by value, 
      name:        Name of file which had an associated error.} 
PROCEDURE fmp_error(ierr:integer;VAR name:string6); 
  CONST 
    fmp='FMP '; 
    on_file=' ON FILE: '; 
  BEGIN 
    writeln(ofile,star_error,fmp,ierr:5,on_file,
                    name.file_name);
    IF echo_prompt THEN writeln(ifile,star_error,fmp,ierr:5,on_file,
                              name.file_name);
    {Determine the appropriate non interactive error response.} 
    IF NOT interactive THEN set_error_path; 
  END; {fmp_error}
  
{pascl_errors catches all pascal runtime system generated errors. 
 PFORM handles its own errors so PASCAL generated errors look more
 like normal PFORM error messages, so the error handler is in a 
 segment, and so a smaller error handler is used.  This saves 
 about 1 K word in program length.} 
  
PROCEDURE pascl_error $ALIAS '@PREP'$ (err_type: error_type;
             err_number,err_line: integer; VAR err_file:input_line; 
             err_flen:integer); 
  BEGIN 
  
    {The actual error handler is in a segment.  It gives an 
     error message, and cleans up files as if the abort exit path 
     took place.} 
    segment_load(handle__error);
  
    handle_error(err_type,err_number,err_line,err_file,err_flen); 
  END;{pascl_error} 
  
 {line_read gets a line from the ifile device or file, returns
  the line of text in inline, and echoes the line to terminal or
  other lu if needed. It always causes a line feed to occur at the
  output files (for readability.) The line is also parsed once
  using namr, and stored in namr_buffer.} 
  
PROCEDURE line_read; $direct$ 
  LABEL 99; 
  VAR 
    line_position:integer;   {Character number pending in echo
                              file.}
 BEGIN
  
   {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 entire line, and set eoln(ifile) false unless its a <cr>.} 
   {A <cr> here sets eof(ifile) true but not eoln(ifile).}
  
   IF eof(ifile) THEN 
     BEGIN
  
       {An unexpected eof took place.  Recover in the 
        interactive case, but end in the command file case.}
  
       IF interactive THEN
         BEGIN
  
           rewrite(ifile);
  
           {Skip a line.} 
  
           writeln(ofile);
  
           IF echo_prompt THEN writeln(ifile);
  
           IF NOT terminal_outfile THEN writeln(ofile); 
  
           {Make sure the proper error message will occur.} 
  
           namr_buffer.types.param1:=null;
         END ELSE {Not an interactive run of BUILD.}
           BEGIN
             pform_ended:=true; 
           END; 
       goto 99; 
     END ELSE {No unexpected eof so read the line.} 
       readln(ifile,inline);
  
   {Must rewrite here to allow writes after reads.} 
  
   IF interactive THEN rewrite(ifile);
  
   {Echo the line to various devices if necessary.} 
   {The line_position is to prevent overflowing the 
    present line.  It works exactly in the list output file 
    case, but not when the output file is a terminal. 
    An approximation is made in the terminal output 
    file case (assume all prompts are under 40 characters.} 
  
   IF terminal_outfile THEN line_position:=39 
     ELSE line_position:=linepos(ofile);
   IF echo_read THEN writeln(ofile,inline:(line_length-line_position)); 
  
   {Send a blank line to output files.} 
   writeln(ofile);
   IF echo_prompt THEN writeln(ifile);
  
   {Do the first parse now.}
  
   istrc:=1;
   namr(namr_buffer,inline,line_length,istrc);
   {Did the user type any control string?  If so, set 
    the corresponding global booleans true.}
   IF (namr_buffer.types.param1=ascii) AND
      (namr_buffer.param1.command[1]='/') AND 
      (namr_buffer.param1.file_name[3]=space1) THEN 
     CASE namr_buffer.param1.command[2] OF
  
       'A': abort:=true;
       'C','N': completed_phase:=true;
       'E': pform_ended:=true;
       'R': restart_partitioning:=true; 
     OTHERWISE
     END; 
   slash_control:=abort OR pform_ended OR completed_phase 
                  OR restart_partitioning;
   last_command:=namr_buffer.param1;
99: 
 END; {line_read} 
  
{get_command outputs the PFORM prompt and calls line_read to
 return the user reply.}
PROCEDURE get_command;$direct$
  BEGIN 
  
    {Output the prompt.}
  
    IF terminal_outfile THEN prompt(ofile,pform_prompt.file_name,space1)
      ELSE write(ofile,pform_prompt.file_name,space1);
    IF echo_prompt THEN prompt(ifile,pform_prompt.file_name,space1);
  
    {Get the reply.}
  
    line_read;
  END;{get_command} 
  
{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:string6;VAR curr_rec:integer):integer;
  VAR 
  
    {integer type declarations.}
    ierr,                    {FMP error code identifier.} 
    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,irec,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:string6; VAR curr_rec:integer; ship:boolean);
  VAR 
    {integer type declarations.}
    ierr,                         {FMP error code returned here.} 
    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,irec,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}
  
  
{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_prompt THEN writeln(ifile,inline);
  END; {writline} 
  
{error is the routine which prints out most of the error messages.
   message:                The passed message.} 
PROCEDURE error(message:input_line);
  BEGIN 
  
    {Output the error.  The entire message string is not output to
     prevent possible overflows.  The entire message should be seen,
     however, since all errors have under 63 characters.} 
  
    writeln(ofile,star_error,message:63); 
    IF echo_prompt THEN writeln(ifile,star_error,message:63); 
    IF NOT interactive THEN set_error_path; 
  END; {error}
  
  {The main program now begins.}
  
  BEGIN 
  
    {Load the segment containing the file initialization routine.}
  
    segment_load(file__init); 
  
    {Define the PASCAL file variables IFILE and OFILE, depending
     upon the run string. Prompt for any files not given in run string. 
     Open the files, and check for error conditions concerning the snap and 
     system files.} 
  
    IF NOT break_program THEN file_init;
  
    {Define the partitions. The restart (/R command) returns
     the flow to a different point.}
  
    segment_load(def__partitions);
  
    {The loop is in case a /R is typed while defining partitions.}
  
    restart_partitioning:=true; 
  
    WHILE restart_partitioning AND NOT (abort OR pform_ended OR break_program)
          AND mapped_system DO
        def_partitions; 
  
    {Loop here, formatting new prom image files, until
     aborted or ended.} 
  
    WHILE NOT (abort OR pform_ended OR break_program) DO
      BEGIN {Phase 3.}
  
        segment_load(lu__process);
  
        {Get the new output file namr and PROM lu.  Create the
         file and do a validity check on the lu.  It will recover 
         from errors, or set abort or pform_ended true (depending 
         upon error.} 
  
        IF NOT break_program THEN lu_process; 
  
        {Get information about cartrige initialization, and do
         the initialization. Output the headers for phase 4.} 
  
        segment_load(dir__init__process); 
        IF NOT (break_program OR abort OR pform_ended) THEN 
          dir_init_process; 
  
        {Restart the phase, so set completed_phase false.}
  
        completed_phase:=false; 
  
        IF bootable_current_file AND NOT (abort OR pform_ended) THEN
          BEGIN 
  
            {Move the system file to the prom image file
             and make the directory entry if possible. There is 
             no need to check for errors before moving this since 
             prom_file_process does this for us.  The store_file
             routine is smart enough to not make a directory entry
             should the system image be too large.} 
  
            segment_load(store__file);
            store_file(sys_dcb,1,sys_len);
  
            {The rec_in_sys_dcb counter must always be correct
             to insure the proper functioning of getword and
             putword.}
            {Now, sys_dcb.buff contains the contents of the 
             last system file record.}
  
            rec_in_sys_dcb:=sys_len;
  
            {Output the description about this file.} 
  
            segment_load(prom__description);
            last_command.file_name:='BOOT  '; 
            prom_description(origsystem,sys_len); 
  
            {Purge the scratch system file, and make the system dcb 
             identical to the current prom file dcb.} 
  
            segment_load(scratch__to__system);
            scratch_to_system;
  
          END;
  
        {This begins the phase 4 loop, where a single PROM is configured.}
  
        completed_phase:=false; 
        WHILE NOT (abort OR pform_ended OR completed_phase OR 
                   break_program) DO
          BEGIN {Phase 4.}
  
            {Prompt for and get the user command.}
  
            get_command;
            WITH namr_buffer DO 
            IF types.param1<>ascii THEN 
  
              error(bad_type) 
           ELSE 
            {Handle the command cases.} 
            {The order here reflects expected frequency of the
             commands.} 
  
            IF param1.command='RP' THEN 
              BEGIN 
  
                {Do everything the LK command does, but 
                 also create an ID in the system.  In the 
                 unmapped case, the short ids must be corrected 
                 to reflect their position on the PROM disk.
                 This is not a problem in mapped systems since
                 the format was changed to block relative offsets.} 
  
                 good_rp:=false;
                 segment_load(check__file__for__errors);
  
                 IF check_file_for_errors THEN
                   BEGIN
  
                     segment_load(rp__error__check);
                     IF rp_error_check AND NOT done_with_rp THEN
                       BEGIN
                         segment_load(relink__check); 
  
                         IF relink_check THEN 
                           BEGIN
  
                             IF mapped_system AND must_relink THEN
                               BEGIN
                                 segment_load(perform__relink); 
                                 IF NOT perform_relink THEN goto 99;
                               END; 
  
                             {Fix the long id and put it in the system.}
  
                             segment_load(fix__long__id); 
  
                             IF fix_long_id AND NOT mapped_system AND 
                               segmented THEN 
                               BEGIN
  
                                 {In this case, short ids must be 
                                  fixed  Exit from the flow if an 
                                  error occured in the routine.}
  
                                 segment_load(fix__short__ids); 
                                 IF NOT fix_short_ids THEN goto 99; 
                               END; 
                             segment_load(store__file); 
                             store_file(file_dcb,cur_file_rec,file_length); 
                             segment_load(prom__description); 
                             prom_description(file_name,file_length); 
                           END; 
                       END; 
                     {Flowing to this point insures no rp errors
                      occurred.}
  
                     good_rp:=true; 
                     rp_true_lk_false:=true;
                   END; 
              END 
            ELSE IF (param1.command='FI') THEN
              BEGIN 
                segment_load(check__file__for__errors); 
  
                IF check_file_for_errors THEN 
                  BEGIN 
                    {Getting here tells us that the file will fit 
                     on the prom, and there are no name conflicts 
                     with the file.}
  
                    {Store the file to the PROM image and make
                     a directory entry for the file.} 
  
                    segment_load(store__file);
                    store_file(file_dcb,cur_file_rec,file_length);
  
  
                    {Tell the user where, on PROMs, the file should 
                     exist.}
  
                    segment_load(prom__description);
  
                    prom_description(file_name,file_length);
                  END;
              END 
            ELSE IF param1.command='LK' THEN
              BEGIN 
  
                {Do everything the FI command does, but also
                 relink the program (mapped) or insure it was 
                 relocated for the system (unmapped).}
  
                good_lk:=false; 
                segment_load(check__file__for__errors); 
                IF check_file_for_errors THEN 
                  BEGIN 
  
                    segment_load(relink__check);
  
                    IF relink_check  THEN 
                      BEGIN 
  
                        {Getting here tells us a relink is may be needed
                         for mapped destination systems, or the program 
                         was relocated for the unmapped destination system.}
  
                        IF mapped_system AND must_relink THEN 
                          BEGIN 
  
                             segment_load(perform__relink); 
  
                             IF NOT perform_relink THEN goto 99;
                           END
                         ELSE IF segmented AND NOT mapped_system THEN 
                              {Program was relocated for original,
                               unmapped system, and is segmented.}
                           BEGIN
  
                             {In this case, short ID segments must be 
                              corrected to reflect the segments positions 
                              on the PROM.  The mapped short ID segment 
                              format eliminates this necessity.}
  
                             segment_load(fix__short__ids); 
                             IF NOT fix_short_ids THEN goto 99; 
                           END; 
                        segment_load(store__file);
                        store_file(file_dcb,cur_file_rec,file_length);
  
                        segment_load(prom__description);
                        prom_description(file_name,file_length);
  
                        good_lk:=true;
                        rp_true_lk_false:=false;
                      END;
                  END;
  
              END 
            ELSE IF param1.command='BU' THEN
              BEGIN 
  
                segment_load(bu__process);
                IF bu_process THEN
                  BEGIN 
                    segment_load(prom__description);
                    file_name.file_name:='BUMP  ';
                    prom_description(file_name,file_length);
                  END;
              END 
            ELSE IF (param1.command='NE') OR completed_phase
                    OR pform_ended THEN 
              BEGIN 
  
                {Complete the directory track(s). This includes 
                 putting the directory entry for the cartridge
                 itself in the PROM image, and making a filler file 
                 if the PROM does not look full to FMP.}
  
                 segment_load(complete__directory); 
                 complete_directory;
  
                 {Set completed_phase true in case the command
                  was NEXT.}
  
                 completed_phase:=true; 
  
              END 
            ELSE IF param1.command='PR' THEN
              BEGIN 
                segment_load(pr__process);
                pr_process; 
              END 
            ELSE IF param1.command='SZ' THEN
              BEGIN 
                segment_load(sz__process);
                sz_process; 
              END 
           ELSE IF param1.command='PT' THEN 
             BEGIN
  
               segment_load(pt__process); 
               pt_process;
             END
            ELSE IF param1.command='ST' THEN
              BEGIN 
                segment_load(st__process);
                st_process; 
              END 
            ELSE IF param1.command='SS' THEN
              BEGIN 
                segment_load(ss__process);
                ss_process; 
              END 
            ELSE IF param1.command='??' THEN
              BEGIN 
                segment_load(question__process);
                question_process; 
              END 
            ELSE IF NOT abort THEN
              error(bad_command); 
          99: 
          END; {Phase 4.} 
      END; {Phase 3.} 
  
    {Close files, purge the PFORM image if aborted, and output
     the completion messages.}
  
    segment_load(cleanup__files); 
    cleanup_files;
  
  END. {PFORM}
                                                                                                      