$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 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 .} {A 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}