?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Object Code Management : Correction Generation' ??
MODULE ocm$generate_object_correction;

{ PURPOSE:
{ The procedures in this module create a correction for an object
{ library when given an old version of an object library a new version of the
{ same object library.
{
{ DESIGN:
{  This module is compiled to RAF$LIBRARY.
{
{  NOTES:
{
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rae$error_messages
*copyc llt$module_dictionary
*copyc oce$metapatch_generator_errors
*copyc oct$breaklist
*copyc oct$corrector
*copyc oct$fill_sequence
*copyc oct$metapatch_header
*copyc oct$module_directory
*copyc oct$move_items
*copyc oct$predictor_header
*copyc rat$subproduct_info_types
?? POP ??
*copyc i#current_sequence_position
*copyc amp$get_segment_pointer
*copyc fsp$close_file
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc mmp$set_access_selections
*copyc ocp$apply_corrector
*copyc ocp$build_corrector
*copyc ocp$build_first_intermediate_ol
*copyc ocp$build_second_inter_ol
*copyc ocp$checksum
*copyc ocp$construct_breaklist
*copyc ocp$generate_ol_predictor
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc pmp$get_unique_name
*copyc rap$open_file
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$generate_object_correction' ??
*copy och$generate_metapatch

  PROCEDURE [XDCL] ocp$generate_object_correction
    (    old_file_name: fst$file_reference;
         new_file_name: fst$file_reference;
         calculate_checksums: boolean;
         old_file_checksum: rat$checksum;
         new_file_checksum: rat$checksum;
     VAR metapatch: ^SEQ ( * );
     VAR size: oct$corrector_size;
     VAR status: ost$status);

    VAR
      corrector_seg: amt$segment_pointer,
      first_intermediate_ol: amt$segment_pointer,
      i: llt$module_index,
      length_of_new_breaklist: oct$breaklist_length,
      length_of_old_breaklist: oct$breaklist_length,
      local_status: ost$status,
      metapatch_header: ^oct$metapatch_header,
      module_directory: ^oct$module_directory,
      move_items: ^oct$move_items,
      new_break_seg: amt$segment_pointer,
      new_breaklist: ^oct$breaklist,
      new_breaks: ^SEQ ( * ),
      new_fid: amt$file_identifier,
      new_file_opened: boolean,
      new_ol: amt$segment_pointer,
      number_of_move_items: oct$breaklist_index,
      old_break_seg: amt$segment_pointer,
      old_breaklist: ^oct$breaklist,
      old_breaks: ^SEQ ( * ),
      old_fid: amt$file_identifier,
      old_file_opened: boolean,
      old_ol: amt$segment_pointer,
      original_object_library: boolean,
      predictor: amt$segment_pointer,
      result: amt$segment_pointer,
      result_checksum: integer,
      result_seq_p: ^SEQ ( * ),
      result_size: integer,
      scratch_segment: amt$segment_pointer,
      second_intermediate_ol: amt$segment_pointer;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs
{   within the block structure.
{
{ DESIGN:
{   If the file has been opened, it will be closed before the
{   the procedure returns.
{
{ NOTES:
{
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF old_file_opened THEN
        fsp$close_file (old_fid, ignore_status);
        old_file_opened := FALSE;
      IFEND;

      IF new_file_opened THEN
        fsp$close_file (new_fid, ignore_status);
        new_file_opened := FALSE;
      IFEND;

      IF result.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (result, local_status);
        IF status.normal AND (NOT local_status.normal) THEN
          status := local_status;
        IFEND;
      IFEND;

      IF predictor.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (predictor, ignore_status);
      IFEND;

      IF first_intermediate_ol.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (first_intermediate_ol, ignore_status);
      IFEND;

      IF old_break_seg.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (old_break_seg, ignore_status);
      IFEND;

      IF new_break_seg.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (new_break_seg, ignore_status);
      IFEND;

      IF second_intermediate_ol.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (second_intermediate_ol, ignore_status);
      IFEND;

      IF scratch_segment.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (scratch_segment, ignore_status);
      IFEND;

      IF corrector_seg.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (corrector_seg, ignore_status);
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    new_file_opened := FALSE;
    old_file_opened := FALSE;
    result.sequence_pointer := NIL;
    predictor.sequence_pointer := NIL;
    first_intermediate_ol.sequence_pointer := NIL;
    old_break_seg.sequence_pointer := NIL;
    new_break_seg.sequence_pointer := NIL;
    scratch_segment.sequence_pointer := NIL;
    second_intermediate_ol.sequence_pointer := NIL;
    corrector_seg.sequence_pointer := NIL;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      rap$open_file (^old_file_name, amc$segment, fsc$read, FALSE, NIL, old_fid, old_file_opened, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      rap$open_file (^new_file_name, amc$segment, fsc$read, FALSE, NIL, new_fid, new_file_opened, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      amp$get_segment_pointer (old_fid, amc$sequence_pointer, old_ol, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      amp$get_segment_pointer (new_fid, amc$sequence_pointer, new_ol, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, predictor, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      ocp$generate_ol_predictor (old_file_name, new_file_name, old_ol, new_ol, predictor, module_directory,
            status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, first_intermediate_ol, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      ocp$build_first_intermediate_ol (predictor.sequence_pointer, old_ol.sequence_pointer,
            first_intermediate_ol.sequence_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, old_break_seg, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      old_breaks := old_break_seg.sequence_pointer;
      original_object_library := TRUE;

      ocp$construct_breaklist (old_ol.sequence_pointer, module_directory, original_object_library,
            first_intermediate_ol.sequence_pointer, old_breaklist, old_breaks, length_of_old_breaklist,
            status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, new_break_seg, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      new_breaks := new_break_seg.sequence_pointer;
      original_object_library := FALSE;

      ocp$construct_breaklist (new_ol.sequence_pointer, module_directory, original_object_library,
            first_intermediate_ol.sequence_pointer, new_breaklist, new_breaks, length_of_new_breaklist,
            status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, second_intermediate_ol, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, scratch_segment, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      RESET scratch_segment.sequence_pointer;

      ocp$build_second_inter_ol (first_intermediate_ol.sequence_pointer, new_breaklist,
            length_of_new_breaklist, old_breaklist, length_of_old_breaklist,
            second_intermediate_ol.sequence_pointer, scratch_segment.sequence_pointer, move_items,
            number_of_move_items);

      FOR i := 1 TO UPPERBOUND (module_directory^) DO
        IF module_directory^ [i].section_number_change_list <> NIL THEN
          FREE module_directory^ [i].section_number_change_list;
        IFEND;
      FOREND;
      FREE module_directory;

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, corrector_seg, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      ocp$build_corrector (old_breaklist, new_breaklist, second_intermediate_ol.sequence_pointer,
            new_ol.sequence_pointer, length_of_old_breaklist, length_of_new_breaklist,
            corrector_seg.sequence_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      construct_metapatch (predictor, move_items, number_of_move_items, corrector_seg.sequence_pointer,
            metapatch, size);

      RESET metapatch;
      NEXT metapatch_header IN metapatch;

      IF calculate_checksums THEN
        metapatch_header^.old_checksum := ocp$checksum (old_ol.sequence_pointer);
        metapatch_header^.new_checksum := ocp$checksum (new_ol.sequence_pointer);
      ELSE
        metapatch_header^.old_checksum := old_file_checksum;
        metapatch_header^.new_checksum := new_file_checksum;
      IFEND;

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, result, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      ocp$apply_corrector (corrector_seg.sequence_pointer, second_intermediate_ol.sequence_pointer,
            result.sequence_pointer);

      result_size := i#current_sequence_position (result.sequence_pointer);

      RESET result.sequence_pointer;
      NEXT result_seq_p: [[REP result_size OF cell]] IN result.sequence_pointer;

      result_checksum := ocp$checksum (result_seq_p);
      IF result_checksum <> metapatch_header^.new_checksum THEN
        osp$set_status_abnormal (occ$status_id, oce$bad_metapatch_generated, '', status);
        EXIT /main/;
      IFEND;

    END /main/;

    IF old_file_opened THEN
      fsp$close_file (old_fid, local_status);
      old_file_opened := FALSE;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF new_file_opened THEN
      fsp$close_file (new_fid, local_status);
      new_file_opened := FALSE;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF result.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (result, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF predictor.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (predictor, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF first_intermediate_ol.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (first_intermediate_ol, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF old_break_seg.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (old_break_seg, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF new_break_seg.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (new_break_seg, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF second_intermediate_ol.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (second_intermediate_ol, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF scratch_segment.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (scratch_segment, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF corrector_seg.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (corrector_seg, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND ocp$generate_object_correction;

?? OLDTITLE ??
?? NEWTITLE := 'construct_metapatch', EJECT ??
*copy och$construct_metapatch

  PROCEDURE construct_metapatch
    (    p_predictor: amt$segment_pointer,
         move_items: ^oct$move_items;
         number_of_move_items: oct$breaklist_index;
         p_corrector: ^SEQ ( * );
     VAR metapatch: ^SEQ ( * );
     VAR length: oct$corrector_size);

    VAR
      corrector: ^SEQ ( * ),
      corrector_header: ^oct$corrector_header,
      corrector_seq: ^SEQ ( * ),
      meta_corrector: ^SEQ ( * ),
      meta_move_items: ^oct$move_items,
      meta_predictor: ^oct$predictor,
      metapatch_header: ^oct$metapatch_header,
      predictor: amt$segment_pointer,
      predictor_header: ^oct$predictor_header,
      predictor_seq: ^oct$predictor,
      predictor_size: oct$predictor_size;

    predictor := p_predictor;
    corrector := p_corrector;

    RESET metapatch;
    NEXT metapatch_header IN metapatch;
    metapatch_header^.size_of_metapatch := #SIZE (metapatch_header^);

    RESET predictor.sequence_pointer;
    NEXT predictor_header IN predictor.sequence_pointer;
    predictor_size := predictor_header^.size_predictor;

    RESET predictor.sequence_pointer;

    IF predictor_size > 0 THEN
      NEXT predictor_seq: [[REP predictor_size OF cell]] IN predictor.sequence_pointer;
      NEXT meta_predictor: [[REP predictor_size OF cell]] IN metapatch;
      meta_predictor^ := predictor_seq^;
      metapatch_header^.size_of_metapatch := metapatch_header^.size_of_metapatch + predictor_size;
      metapatch_header^.predictor := #REL (meta_predictor, metapatch^);
      metapatch_header^.predictor_size := predictor_size;
    ELSE
      metapatch_header^.predictor_size := 0;
    IFEND;

    IF number_of_move_items > 0 THEN
      NEXT meta_move_items: [1 .. number_of_move_items] IN metapatch;
      meta_move_items^ := move_items^;
      metapatch_header^.size_of_metapatch := metapatch_header^.size_of_metapatch + #SIZE (meta_move_items^);
      metapatch_header^.move_items := #REL (meta_move_items, metapatch^);
      metapatch_header^.number_of_move_items := number_of_move_items;
    ELSE
      metapatch_header^.number_of_move_items := 0;
    IFEND;

    RESET corrector;
    NEXT corrector_header IN corrector;

    RESET corrector;
    IF corrector_header^.number_of_correctors > 0 THEN
      NEXT corrector_seq: [[REP corrector_header^.size OF cell]] IN corrector;
      NEXT meta_corrector: [[REP corrector_header^.size OF cell]] IN metapatch;
      meta_corrector^ := corrector_seq^;
      metapatch_header^.size_of_metapatch := metapatch_header^.size_of_metapatch + corrector_header^.size;
      metapatch_header^.corrector := #REL (meta_corrector, metapatch^);
      metapatch_header^.corrector_size := corrector_header^.size;
    ELSE
      metapatch_header^.corrector_size := 0;
    IFEND;

    length := metapatch_header^.size_of_metapatch;
  PROCEND construct_metapatch;

MODEND ocm$generate_object_correction;
