?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Program Control - Program Conditions' ??
MODULE pmm$condition_stack_processor;


{   PURPOSE:
{     The purpose of this module is to isolate the knowledge of stacks
{     with respect to conditions, system flags, and signals.

{   DESIGN:
{     The procedures contained in this module are designed to execute
{     with traps enabled.  The module has an execute bracket of 2, 13.

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc mmt$page_map_offsets
*copyc osd$code_base_pointer
*copyc osd$conditions
*copyc osd$registers
*copyc osd$virtual_address
*copyc oss$job_paged_literal
*copyc ost$name
*copyc ost$stack_frame_save_area
*copyc ost$virtual_machine_identifier
*copyc pme$condition_exceptions
*copyc pmt$condition
*copyc pmt$condition_handler
*copyc pmt$condition_information
*copyc pmt$established_handler
*copyc pmt$established_handler_internl
*copyc pmt$minimum_save_area
?? POP ??
*copyc clp$validate_name
*copyc i#disable_traps
*copyc i#enable_traps
*copyc i#restore_traps
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc pmp$call_ring_crossing_proc
*copyc pmp$apd_call_to_users_procedure
*copyc pmp$continue_to_cause
*copyc pmp$purge_instruction_stack
*copyc pmp$ring_crossing_proc_return
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    maximum_descriptors = 100;

*copyc pmt$internal_condition

  TYPE
    comparable_pointer = 0 .. 0ffffffffffff(16);

?? EJECT ??

  TYPE
    p_address = packed record
      filler: 0 .. 0fffff(16),
      seg_offset: 0 .. 0fffffffffff(16),
    recend,

    pva = packed record
      ring: 0 .. 0f(16),
      seg: 0 .. 0fff(16),
      offset_sign: 0 .. 1,
      offset: 0 .. 7fffffff(16),
    recend,

    pointer_to_procedure = record
      case dummy: 0 .. 1 of
      = 0 =
        procedure_pointer: ^procedure,
      = 1 =
        cbp: ^p_address,
      casend,
    recend;

  VAR
    apd_call_to_users_procedure: [STATIC, READ, oss$job_paged_literal] pointer_to_procedure :=
          [0, ^pmp$apd_call_to_users_procedure];

?? OLDTITLE ??
?? NEWTITLE := 'condition selectors', EJECT ??

  VAR

{The following condition selectors are named for the detection of software errors which are
{reflected as hardware conditions. However, included in the selectors,
{implicitly via combination, is the hardware detected uncorrected error which is dealt with
{distinctly by the respective condition handler.

    handler_stack_error: [STATIC, READ, oss$job_paged_literal] pmt$condition :=
          [pmc$condition_combination, $pmt$condition_combination
          [pmc$system_conditions, mmc$segment_access_condition]],
    stack_error: [STATIC, READ, oss$job_paged_literal] pmt$condition :=
          [pmc$condition_combination, $pmt$condition_combination
          [pmc$system_conditions, mmc$segment_access_condition]];

  VAR
    unselectable_system_conditions: [STATIC, READ, oss$job_paged_literal] pmt$system_conditions :=
          $pmt$system_conditions [pmc$ua_unselectable, pmc$sw_unselectable, pmc$xr_unselectable,
          pmc$xi_unselectable, pmc$pf_unselectable, pmc$sc_unselectable, pmc$sit_unselectable,
          pmc$sel_unselectable, pmc$tx_unselectable, pmc$ff_unselectable, pmc$pit_unselectable,
          pmc$cff_unselectable, pmc$kypt_unselectable, pmc$debug_unselectable];

  VAR
    handler_inactive: [STATIC, READ, oss$job_paged_literal] pmt$condition_handler_active :=
          [$pmt$system_conditions [], [0, NIL]];

  VAR
    initialize_os_stack_frame_word: [STATIC, READ, oss$job_paged_literal] pmt$os_stack_frame_word :=
          [NIL, FALSE, FALSE, FALSE, FALSE, 0];

  VAR
    maskable_system_conditions: [STATIC, READ, oss$job_paged_literal] pmt$system_conditions :=
          $pmt$system_conditions [pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
          pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite, pmc$arithmetic_significance,
          pmc$invalid_bdp_data];


?? OLDTITLE ??
?? NEWTITLE := 'find_handler_in_stack_frame', EJECT ??


  PROCEDURE find_handler_in_stack_frame
    (    condition: pmt$internal_condition;
         current_sa: ^pmt$minimum_save_area;
         handler_stack: ^pmt$established_handler;
     VAR established_handler: ^pmt$established_handler;
     VAR status: ost$status);

    VAR
      number_descriptors_scanned: integer,
      established_handler_stack: ^pmt$established_handler,
      condition_segment: ost$segment,
      established_segment: ost$segment;

    established_handler := NIL;
    IF (handler_stack <> NIL) AND current_sa^.frame_descriptor.on_condition_flag THEN
      established_handler_stack := handler_stack;
      number_descriptors_scanned := 1;
      WHILE (established_handler = NIL) AND (established_handler_stack <> NIL) AND status.normal DO
        validate_descriptor_address (current_sa, established_handler_stack, status);
        IF established_handler_stack^.established AND status.normal THEN
          IF (established_handler_stack^.established_conditions.selector = pmc$all_conditions) THEN
            established_handler := established_handler_stack;
          ELSEIF (established_handler_stack^.established_conditions.selector = pmc$condition_combination) THEN
            IF (condition.class IN established_handler_stack^.established_conditions.combination) THEN
              established_handler := established_handler_stack;
            IFEND;
          ELSEIF (established_handler_stack^.established_conditions.selector = condition.class) THEN
            CASE condition.class OF
            = pmc$system_conditions =
              IF (condition.system IN established_handler_stack^.established_conditions.system_conditions)
                    THEN
                established_handler := established_handler_stack;
              IFEND;
            = pmc$block_exit_processing =
              IF ((established_handler_stack^.established_conditions.reason * condition.reason) <>
                    $pmt$block_exit_reason []) THEN
                established_handler := established_handler_stack;
              IFEND;
            = jmc$job_resource_condition =
              IF (condition.job_resource = established_handler_stack^.established_conditions.
                    job_resource_condition) THEN
                established_handler := established_handler_stack;
              IFEND;
            = mmc$segment_access_condition =
              condition_segment := #SEGMENT (condition.segment_access.segment);
              established_segment := #SEGMENT (established_handler_stack^.established_conditions.
                    segment_access_condition.segment);
              IF (condition_segment = established_segment) AND
                    (condition.segment_access.identifier = established_handler_stack^.established_conditions.
                    segment_access_condition.identifier) THEN
                established_handler := established_handler_stack;
              IFEND;
            = ifc$interactive_condition =
              IF (condition.interactive = established_handler_stack^.established_conditions.
                    interactive_condition) THEN
                established_handler := established_handler_stack;
              IFEND;
            = pmc$pit_condition =
              established_handler := established_handler_stack;
            = pmc$user_defined_condition =
              IF (condition.user_defined = established_handler_stack^.established_conditions.
                    user_condition_name) THEN
                established_handler := established_handler_stack;
              IFEND;
            ELSE
              osp$set_status_condition (pme$invalid_condition_selector, status);
            CASEND;
          IFEND;
        IFEND;
        IF (established_handler = NIL) AND status.normal THEN
          IF (established_handler_stack^.est_handler_stack <> NIL) THEN
            number_descriptors_scanned := number_descriptors_scanned + 1;
            IF number_descriptors_scanned > maximum_descriptors THEN
              osp$set_status_condition (pme$handler_stack_error, status);
            IFEND;
          IFEND;
          established_handler_stack := established_handler_stack^.est_handler_stack;
        IFEND;
      WHILEND;
    IFEND;
  PROCEND find_handler_in_stack_frame;
?? OLDTITLE ??
?? NEWTITLE := 'handler_stack', EJECT ??

  FUNCTION [INLINE] handler_stack
    (    save_area: ^pmt$minimum_save_area): ^pmt$established_handler;

    IF (save_area <> NIL) AND (save_area^.frame_descriptor.on_condition_flag) THEN
      handler_stack := save_area^.a1_current_stack_frame^.established_handler;
    ELSE
      handler_stack := NIL;
    IFEND;

  FUNCEND handler_stack;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$build_ring_crossing_frame', EJECT ??
*copyc pmh$build_ring_crossing_frame

  PROCEDURE [XDCL] pmp$build_ring_crossing_frame
    (    ring_crossing_sfsa: ^ost$stack_frame_save_area);

    VAR
      converter: record
        case 0 .. 1 of
        = 0 =
          procedure_pointer: ^procedure,
        = 1 =
          code_base_pointer: ^ost$external_code_base_pointer,
        casend,
      recend;

    VAR
      new_stack_frame_address: ^cell,
      new_stack_frame_save_area: ^ost$stack_frame_save_area,
      previous_save_area: ^ost$stack_frame_save_area,
      ring_crossing_procedure_pva: ^cell,
      ring_crossing_return_pva: ^cell,
      traps: 0 .. 3;

    converter.procedure_pointer := ^pmp$call_ring_crossing_proc;
    ring_crossing_procedure_pva := converter.code_base_pointer^.code_pva;

    converter.procedure_pointer := ^pmp$ring_crossing_proc_return;
    ring_crossing_return_pva := converter.code_base_pointer^.code_pva;

{  If a ring crossing procedure frame has already been inserted for this stack then do nothing.

    i#disable_traps (traps);
    IF (#SEGMENT (ring_crossing_sfsa^.minimum_save_area.a2_previous_save_area) =
          #SEGMENT (ring_crossing_sfsa^.minimum_save_area.a1_current_stack_frame)) THEN

{  A trap has occurred after tmp$find_ring_crossing_frame found the crossing frame but before it was returned
{  and so there is already a ring crossing frame in the stack

      i#restore_traps (traps);
      RETURN;

    ELSEIF (ring_crossing_sfsa^.minimum_save_area.p_register.pva.seg =
          #SEGMENT (ring_crossing_procedure_pva)) AND ((ring_crossing_sfsa^.minimum_save_area.p_register.pva.
          offset >= #OFFSET (ring_crossing_procedure_pva)) AND
          (ring_crossing_sfsa^.minimum_save_area.p_register.pva.offset <= #OFFSET (ring_crossing_return_pva)))
          THEN
      i#restore_traps (traps);
      RETURN;
    IFEND;

{  Put the new stack frame in the area reserved for it at the beginning of the stack.
    new_stack_frame_address := #ADDRESS (#RING (ring_crossing_sfsa^.minimum_save_area.a1_current_stack_frame),
          #SEGMENT (ring_crossing_sfsa^.minimum_save_area.a1_current_stack_frame),
          (#OFFSET (ring_crossing_sfsa^.minimum_save_area.a1_current_stack_frame) -
          mmc$ring_crossing_offset));
    new_stack_frame_save_area := new_stack_frame_address;
    new_stack_frame_save_area^.minimum_save_area.p_register.undefined1 := 0;
    previous_save_area := #PREVIOUS_SAVE_AREA ();

    new_stack_frame_save_area^.minimum_save_area.p_register.global_key :=
          previous_save_area^.minimum_save_area.p_register.global_key;
    new_stack_frame_save_area^.minimum_save_area.p_register.undefined2 := 0;
    new_stack_frame_save_area^.minimum_save_area.p_register.local_key :=
          previous_save_area^.minimum_save_area.p_register.local_key;
    new_stack_frame_save_area^.minimum_save_area.p_register.pva.ring := #RING (ring_crossing_sfsa);
    new_stack_frame_save_area^.minimum_save_area.p_register.pva.seg := #SEGMENT (ring_crossing_procedure_pva);
    new_stack_frame_save_area^.minimum_save_area.p_register.pva.offset :=
          #OFFSET (ring_crossing_procedure_pva);
    new_stack_frame_save_area^.minimum_save_area.vmid := converter.code_base_pointer^.vmid;
    new_stack_frame_save_area^.minimum_save_area.undefined := 0;
    new_stack_frame_save_area^.minimum_save_area.a0_dynamic_space_pointer := new_stack_frame_save_area;
    new_stack_frame_save_area^.minimum_save_area.frame_descriptor.critical_frame_flag := FALSE;
    new_stack_frame_save_area^.minimum_save_area.frame_descriptor.on_condition_flag := FALSE;
    new_stack_frame_save_area^.minimum_save_area.frame_descriptor.undefined := 0;
    new_stack_frame_save_area^.minimum_save_area.frame_descriptor.x_starting := 1;
    new_stack_frame_save_area^.minimum_save_area.frame_descriptor.a_terminating := 3;
    new_stack_frame_save_area^.minimum_save_area.frame_descriptor.x_terminating := 0;
    new_stack_frame_save_area^.minimum_save_area.a1_current_stack_frame := new_stack_frame_save_area;
    new_stack_frame_save_area^.minimum_save_area.user_mask := previous_save_area^.minimum_save_area.user_mask;
    new_stack_frame_save_area^.minimum_save_area.a2_previous_save_area :=
          ring_crossing_sfsa^.minimum_save_area.a2_previous_save_area;
    new_stack_frame_save_area^.a3 := converter.code_base_pointer^.binding_pva;

{ Put the address of the new stack frame save area into the previous save area field in the ring crossing
{ frame.  When the owner of the ring crossing frame returns, pmp$call_ring_crossing_proc will execute.

    ring_crossing_sfsa^.minimum_save_area.a2_previous_save_area := new_stack_frame_save_area;
    pmp$purge_instruction_stack;
    i#restore_traps (traps);

  PROCEND pmp$build_ring_crossing_frame;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$disestablish_cond_handler', EJECT ??
*copyc pmh$disestablish_cond_handler

  PROCEDURE [XDCL, #GATE] pmp$disestablish_cond_handler
    (    conditions: pmt$condition;
     VAR status: ost$status);


    VAR
      traps: 0 .. 3;

?? NEWTITLE := 'dispose_of_handler_stack_error', EJECT ??

    PROCEDURE dispose_of_handler_stack_error
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR c_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF (condition.selector <> pmc$system_conditions) OR ((condition.selector = pmc$system_conditions) AND
            NOT (pmc$detected_uncorrected_err IN condition.system_conditions)) THEN
        osp$set_status_condition (pme$handler_stack_error, status);
        i#restore_traps (traps);
        EXIT pmp$disestablish_cond_handler;
      ELSE
        osp$set_status_from_condition (pmc$program_management_id, condition, save_area, c_status,
              ignore_status);
      IFEND;

    PROCEND dispose_of_handler_stack_error;
?? OLDTITLE ??
?? NEWTITLE := 'disestablish_handler_in_frame', EJECT ??

    PROCEDURE disestablish_handler_in_frame
      (    conditions: pmt$condition;
           current_save_area: ^pmt$minimum_save_area;
       VAR disestablished: boolean;
       VAR local_status: ost$status);

      VAR
        number_descriptors_scanned: integer,
        handler_stack: ^pmt$established_handler;

?? NEWTITLE := 'should_cff_be_cleared', EJECT ??

      PROCEDURE should_cff_be_cleared
        (VAR critical_frame: boolean;
         VAR block_exit_frame: boolean);

        VAR
          executing_ring: ost$ring,
          descriptors_scanned: integer,
          handler: ^pmt$established_handler,
          status: ost$status;

        descriptors_scanned := number_descriptors_scanned;
        handler := handler_stack^.est_handler_stack;

        block_exit_frame := FALSE;

        WHILE ((handler <> NIL) AND status.normal) DO
          validate_descriptor_address (current_save_area, handler, status);
          IF status.normal THEN

{ The critical frame flag should remain set if there is a condition handler in the handler stack
{ whose condition selector includes pmc$block_exit_processing.

            IF handler^.established AND ((handler^.established_conditions.selector =
                  pmc$block_exit_processing) OR (handler^.established_conditions.selector =
                  pmc$all_conditions) OR ((handler^.established_conditions.selector =
                  pmc$condition_combination) AND (pmc$block_exit_processing IN
                  handler^.established_conditions.combination))) THEN
              critical_frame := TRUE;
              block_exit_frame := TRUE;
              RETURN;
            ELSE
              IF (handler^.est_handler_stack <> NIL) THEN
                IF descriptors_scanned >= maximum_descriptors THEN
                  critical_frame := TRUE;
                  RETURN;
                ELSE
                  descriptors_scanned := descriptors_scanned + 1;
                IFEND;
              IFEND;
              handler := handler^.est_handler_stack;
            IFEND;
          ELSE
            critical_frame := TRUE;
            RETURN;
          IFEND;
        WHILEND;

{ If this frame is a terminate inhibit, DEBUG or ADA critical frame then the
{ critical frame flag should not be cleared.

        critical_frame := current_save_area^.a1_current_stack_frame^.debug_cff_frame OR
              current_save_area^.a1_current_stack_frame^.terminate_inhibit_frame OR
              (current_save_area^.a1_current_stack_frame^.ada_critical_frame AND
              (current_save_area^.a1_current_stack_frame^.ada_critical_frame_count <> 0));

      PROCEND should_cff_be_cleared;
?? OLDTITLE, EJECT ??

      VAR
        block_exit_frame: boolean,
        critical_frame: boolean,
        handler_stack_pva: ^pva;

{DISESTABLISHED = FALSE and LOCAL_STATUS.NORMAL = TRUE on entry

      handler_stack_pva := #LOC (current_save_area^.a1_current_stack_frame^);

{ It is assumed that the handler stack pointer must be NIL or be a valid pointer in the
{ stack if the on condition flag (OCF) is set.

      IF ((handler_stack_pva^.ring = 0f(16)) AND ((handler_stack_pva^.seg = 0fff(16)) AND
            ((handler_stack_pva^.offset_sign = 1) AND (handler_stack_pva^.offset = 0)))) OR
            NOT current_save_area^.frame_descriptor.on_condition_flag THEN
        RETURN;
      IFEND;

      handler_stack := current_save_area^.a1_current_stack_frame^.established_handler;
      number_descriptors_scanned := 1;
      block_exit_frame := FALSE;
      REPEAT
        validate_descriptor_address (current_save_area, handler_stack, local_status);
        IF NOT local_status.normal THEN
          RETURN;
        IFEND;
        IF handler_stack^.established AND (conditions.selector =
              handler_stack^.established_conditions.selector) THEN
          CASE conditions.selector OF
          = pmc$all_conditions =
            disestablished := TRUE;
            block_exit_frame := TRUE;
          = pmc$system_conditions =
            disestablished := (conditions.system_conditions =
                  handler_stack^.established_conditions.system_conditions);
          = pmc$block_exit_processing =
            IF (conditions.reason = handler_stack^.established_conditions.reason) THEN
              disestablished := TRUE;
              block_exit_frame := TRUE;
            IFEND;
          = jmc$job_resource_condition =
            disestablished := (conditions.job_resource_condition =
                  handler_stack^.established_conditions.job_resource_condition);
          = mmc$segment_access_condition =
            disestablished := (conditions.segment_access_condition =
                  handler_stack^.established_conditions.segment_access_condition);
          = ifc$interactive_condition =
            disestablished := (conditions.interactive_condition =
                  handler_stack^.established_conditions.interactive_condition);
          = pmc$pit_condition =
            disestablished := TRUE;
          = pmc$user_defined_condition =
            disestablished := (conditions.user_condition_name =
                  handler_stack^.established_conditions.user_condition_name);
          = pmc$condition_combination =
            IF (conditions.combination = handler_stack^.established_conditions.combination) THEN
              disestablished := TRUE;
              block_exit_frame := pmc$block_exit_processing IN
                    handler_stack^.established_conditions.combination;
            IFEND;
          CASEND;

          IF disestablished THEN
            handler_stack^.established := FALSE;
            IF block_exit_frame THEN
              should_cff_be_cleared (critical_frame, block_exit_frame);
              current_save_area^.frame_descriptor.critical_frame_flag := critical_frame;
              current_save_area^.a1_current_stack_frame^.block_exit_frame := block_exit_frame;
            IFEND;
            RETURN;
          IFEND;

        IFEND;

        IF number_descriptors_scanned >= maximum_descriptors THEN
          osp$set_status_condition (pme$handler_stack_error, local_status);
          RETURN;
        IFEND;
        number_descriptors_scanned := number_descriptors_scanned + 1;
        handler_stack := handler_stack^.est_handler_stack;
      UNTIL handler_stack = NIL;

    PROCEND disestablish_handler_in_frame;
?? OLDTITLE, EJECT ??

    VAR
      condition_name: ost$name,
      current_save_area: ^pmt$minimum_save_area,
      descriptor: pmt$established_handler,
      disestablish_condition: pmt$condition,
      disestablish_status: ost$status,
      disestablished: boolean,
      disestablishing_save_area: ^pmt$minimum_save_area,
      p: ^p_address,
      sfsa: ^ost$stack_frame_save_area,
      stack_segment_ring: ost$ring,
      valid_name: boolean;

    i#enable_traps (traps);

  /disestablish_a_handler/
    BEGIN
      IF ((conditions.selector < LOWERVALUE (pmt$condition_selector)) OR
            (conditions.selector > UPPERVALUE (pmt$condition_selector))) THEN
        osp$set_status_condition (pme$invalid_condition_selector, status);
        EXIT /disestablish_a_handler/;
      IFEND;

      disestablish_status.normal := TRUE;
      pmp$establish_condition_handler (handler_stack_error, ^dispose_of_handler_stack_error, ^descriptor,
            disestablish_status);
      disestablishing_save_area := #PREVIOUS_SAVE_AREA ();
      disestablished := FALSE;

      IF (conditions.selector = pmc$all_conditions) OR (conditions.selector = pmc$block_exit_processing) OR
            ((conditions.selector = pmc$condition_combination) AND
            (pmc$block_exit_processing IN conditions.combination)) THEN
        p := #LOC (disestablishing_save_area^);
        IF (p^.seg_offset = apd_call_to_users_procedure.cbp^.seg_offset) THEN
          pmp$validate_previous_save_area (#LOC (disestablishing_save_area^), disestablish_status);
          IF disestablish_status.normal THEN
            disestablishing_save_area := disestablishing_save_area^.a2_previous_save_area;
          ELSE
            status := disestablish_status;
            EXIT /disestablish_a_handler/;
          IFEND;
        IFEND;
        disestablish_handler_in_frame (conditions, disestablishing_save_area, disestablished,
              disestablish_status);

      ELSE
        disestablish_condition := conditions;
        IF (conditions.selector = pmc$user_defined_condition) THEN
          clp$validate_name (conditions.user_condition_name, condition_name, valid_name);
          IF valid_name THEN
            disestablish_condition.user_condition_name := condition_name;
          ELSE
            osp$set_status_condition (pme$incorrect_condition_name, status);
            EXIT /disestablish_a_handler/;
          IFEND;
        IFEND;
        stack_segment_ring := disestablishing_save_area^.p_register.pva.ring;
        current_save_area := disestablishing_save_area;
        REPEAT
          disestablish_handler_in_frame (disestablish_condition, current_save_area, disestablished,
                disestablish_status);
          IF NOT disestablished AND disestablish_status.normal THEN
            sfsa := #LOC (current_save_area^);
            pmp$validate_previous_save_area (sfsa, disestablish_status);
            current_save_area := current_save_area^.a2_previous_save_area;
          IFEND;
        UNTIL (NOT disestablish_status.normal OR disestablished OR (current_save_area = NIL) OR
              (current_save_area^.p_register.pva.ring <> stack_segment_ring));

      IFEND;

      IF disestablished THEN
        status.normal := TRUE;
      ELSEIF disestablish_status.normal THEN
        osp$set_status_condition (pme$no_established_handler, status);
      ELSE
        status := disestablish_status;
      IFEND;
    END /disestablish_a_handler/;

    i#restore_traps (traps);

  PROCEND pmp$disestablish_cond_handler;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$enable_system_conditions', EJECT ??
*copy pmh$enable_system_conditions

  PROCEDURE [XDCL, #GATE] pmp$enable_system_conditions
    (    conditions: pmt$system_conditions;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pmp$push_task_debug_mode
*copyc pmp$pop_task_debug_mode
?? POP ??

?? NEWTITLE := 'handle_pending_conditions', EJECT ??

{ The purpose of the following two procedures is to clear any pending system
{ conditions which are being enabled.

    PROCEDURE handle_pending_conditions
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      status.normal := TRUE;

    PROCEND handle_pending_conditions;
?? OLDTITLE ??
?? NEWTITLE := 'cause_pending_conditions', EJECT ??

    PROCEDURE cause_pending_conditions
      (    enable: ost$user_conditions);

      VAR
        sfsa: ^ost$stack_frame_save_area;

      sfsa := #PREVIOUS_SAVE_AREA ();

{ Setting the user mask in the caller's sfsa will cause any pending system conditions to arise when the
{ user mask is loaded from the sfsa on the return from this procedure.

      sfsa^.minimum_save_area.user_mask := (sfsa^.minimum_save_area.user_mask + enable);

    PROCEND cause_pending_conditions;
?? OLDTITLE, EJECT ??

    VAR
      enable: ost$user_conditions,
      enable_bit: ost$user_condition,
      requestor_sfsa: ^ost$stack_frame_save_area,
      system_condition: pmt$system_condition,
      user_enable: pmt$system_conditions,
      conditions_to_clear: pmt$condition,
      clear_descriptor: pmt$established_handler,
      ignore_status: ost$status;

    status.normal := TRUE;

    IF (conditions <> $pmt$system_conditions []) THEN
      IF ((conditions - maskable_system_conditions) = $pmt$system_conditions []) THEN
        enable := $ost$user_conditions [];
        enable_bit := osc$divide_fault;
        system_condition := pmc$divide_fault;
        user_enable := conditions;

        WHILE (user_enable <> $pmt$system_conditions []) DO
          IF (system_condition IN user_enable) THEN
            enable := enable + $ost$user_conditions [enable_bit];
            user_enable := (user_enable - $pmt$system_conditions [system_condition]);
          IFEND;

          IF (system_condition < pmc$invalid_bdp_data) THEN
            system_condition := SUCC (system_condition);
            enable_bit := SUCC (enable_bit);
          IFEND;
        WHILEND;

        requestor_sfsa := #PREVIOUS_SAVE_AREA ();
        requestor_sfsa^.minimum_save_area.user_mask := (requestor_sfsa^.minimum_save_area.user_mask + enable);
        conditions_to_clear.selector := pmc$system_conditions;
        conditions_to_clear.system_conditions := conditions;

        pmp$establish_condition_handler (conditions_to_clear, ^handle_pending_conditions, ^clear_descriptor,
              ignore_status);

        pmp$push_task_debug_mode (pmc$debug_mode_off, ignore_status);
        cause_pending_conditions (enable);
        pmp$pop_task_debug_mode (ignore_status);
      ELSE
        osp$set_status_condition (pme$unselectable_condition, status);
      IFEND;
    IFEND;

  PROCEND pmp$enable_system_conditions;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$establish_condition_handler', EJECT ??
*copy pmh$establish_condition_handler

{   WARNING: if this procedure must be modified the equivalent modifications must be made to
{            PMP$ESTABLISH_CH_IN_BLOCK.

  PROCEDURE [XDCL, #GATE] pmp$establish_condition_handler
    (    conditions: pmt$condition;
         condition_handler: pmt$condition_handler;
         establish_descriptor {input, output} : ^pmt$established_handler;
     VAR status: ost$status);

    VAR
      apd_stack_frame: boolean,
      condition_name: ost$name,
      csf: ^ost$pva,
      current_stack_frame: ^comparable_pointer,
      descriptor_address: ^comparable_pointer,
      dynamic_space_pointer: ^comparable_pointer,
      establish_status: ^ost$status,
      establishing_save_area: ^pmt$minimum_save_area,
      executing_stack: ^cell,
      handler_stack: ^pva,
      p: ^p_address,
      valid_name: boolean;

    status.normal := TRUE;
    IF ((conditions.selector < LOWERVALUE (pmt$condition_selector)) OR
          (conditions.selector > UPPERVALUE (pmt$condition_selector))) THEN
      osp$set_status_condition (pme$invalid_condition_selector, status);
      RETURN;
    IFEND;

    establishing_save_area := #PREVIOUS_SAVE_AREA ();

    REPEAT

{ validate current stack frame (a1) pointer

      csf := #LOC (establishing_save_area^.a1_current_stack_frame);

      IF ((csf^.ring <> #RING (^executing_stack)) OR (csf^.seg <> #SEGMENT (^executing_stack)) OR
            (establishing_save_area^.a0_dynamic_space_pointer.offset < (csf^.offset + 8))) THEN
        osp$set_status_condition (pme$inconsistent_stack, status);
        RETURN;
      IFEND;

{ validate descriptor address

      descriptor_address := #LOC (establish_descriptor);
      current_stack_frame := #LOC (establishing_save_area^.a1_current_stack_frame);
      dynamic_space_pointer := #LOC (establishing_save_area^.a0_dynamic_space_pointer);

      IF (descriptor_address^ < (current_stack_frame^ +8)) OR
            ((descriptor_address^ + #SIZE (pmt$established_handler)) >= dynamic_space_pointer^) THEN

        p := #LOC (establishing_save_area^);
        IF (p^.seg_offset <> apd_call_to_users_procedure.cbp^.seg_offset) THEN
          osp$set_status_condition (pme$descriptor_address_error, status);
          RETURN;
        IFEND;

        PUSH establish_status;
        pmp$validate_previous_save_area (#LOC (establishing_save_area^), establish_status^);
        IF NOT establish_status^.normal THEN
          status := establish_status^;
          RETURN;
        IFEND;

        apd_stack_frame := TRUE;
        establishing_save_area := establishing_save_area^.a2_previous_save_area;
      ELSE
        apd_stack_frame := FALSE;
      IFEND;
    UNTIL NOT apd_stack_frame;

    establish_descriptor^.established_conditions := conditions;

    IF (conditions.selector = pmc$system_conditions) AND ((conditions.system_conditions *
          unselectable_system_conditions) <> $pmt$system_conditions []) THEN
      osp$set_status_condition (pme$unselectable_condition, status);
      RETURN;
    IFEND;


    IF (conditions.selector = pmc$user_defined_condition) THEN
      clp$validate_name (conditions.user_condition_name, condition_name, valid_name);
      IF NOT valid_name THEN
        osp$set_status_condition (pme$incorrect_condition_name, status);
        RETURN;
      IFEND;

      establish_descriptor^.established_conditions.user_condition_name := condition_name;
    IFEND;


    establish_descriptor^.handler_active := handler_inactive;
    establish_descriptor^.handler := condition_handler;
    establish_descriptor^.established := TRUE;


    IF NOT (establishing_save_area^.frame_descriptor.on_condition_flag) THEN
      establish_descriptor^.est_handler_stack := NIL;

{ Initialize the OS stack frame word.

      establishing_save_area^.a1_current_stack_frame^ := initialize_os_stack_frame_word;

    ELSE

{ validate current top of handler stack

      handler_stack := #LOC (establishing_save_area^.a1_current_stack_frame^);

{ It is assumed that the handler stack pointer must be NIL or be a valid pointer in the
{ stack if the on condition flag (OCF) is set.

      IF NOT ((handler_stack^.ring = 0f(16)) AND ((handler_stack^.seg = 0fff(16)) AND
            ((handler_stack^.offset_sign = 1) AND (handler_stack^.offset = 0)))) THEN
        IF (handler_stack^.ring <> #RING (^executing_stack)) OR
              ((handler_stack^.seg = #SEGMENT (^executing_stack)) AND
              (establishing_save_area^.a0_dynamic_space_pointer.offset <
              (handler_stack^.offset + #SIZE (pmt$established_handler)))) THEN
          osp$set_status_condition (pme$handler_stack_error, status);
          RETURN;
        IFEND;
      IFEND;

      establish_descriptor^.est_handler_stack := establishing_save_area^.a1_current_stack_frame^.
            established_handler;
    IFEND;

    establishing_save_area^.a1_current_stack_frame^.established_handler := establish_descriptor;

    IF (conditions.selector = pmc$block_exit_processing) OR
          (conditions.selector = pmc$all_conditions) OR ((conditions.selector = pmc$condition_combination) AND
          (pmc$block_exit_processing IN conditions.combination)) THEN
      establishing_save_area^.frame_descriptor.critical_frame_flag := TRUE;
      establishing_save_area^.a1_current_stack_frame^.block_exit_frame := TRUE;
    IFEND;

    establishing_save_area^.frame_descriptor.on_condition_flag := TRUE;

  PROCEND pmp$establish_condition_handler;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$establish_ch_in_block', EJECT ??
*copy pmh$establish_ch_in_block

{   WARNING: if this procedure must be modified the equivalent modifications must be made to
{            PMP$ESTABLISH_CONDITION_HANDLER

  PROCEDURE [XDCL, #GATE] pmp$establish_ch_in_block
    (    conditions: pmt$condition;
         condition_handler: pmt$condition_handler;
         block: ^ost$stack_frame_save_area;
         establish_descriptor {input, output} : ^pmt$established_handler;
     VAR status: ost$status);

    VAR
      apd_stack_frame: boolean,
      condition_name: ost$name,
      csf: ^ost$pva,
      current_stack_frame: ^comparable_pointer,
      descriptor_address: ^comparable_pointer,
      establish_status: ^ost$status,
      establishing_save_area: ^pmt$minimum_save_area,
      handler_stack: ^pva,
      p: ^p_address,
      valid_name: boolean;

    status.normal := TRUE;

    IF ((conditions.selector < LOWERVALUE (pmt$condition_selector)) OR
          (conditions.selector > UPPERVALUE (pmt$condition_selector))) THEN
      osp$set_status_condition (pme$invalid_condition_selector, status);
      RETURN;
    IFEND;

    establishing_save_area := #LOC (block^);

    REPEAT

{ validate block's stack frame (a1) pointer

      csf := #LOC (establishing_save_area^.a1_current_stack_frame);

      IF ((csf^.ring <> #RING (block)) OR (csf^.seg <> #SEGMENT (block)) OR
            (establishing_save_area^.a0_dynamic_space_pointer.offset < (csf^.offset + 8))) THEN
        osp$set_status_condition (pme$inconsistent_stack, status);
        RETURN;
      IFEND;

{ validate descriptor address

      descriptor_address := #LOC (establish_descriptor);
      current_stack_frame := #LOC (establishing_save_area^.a1_current_stack_frame);

      IF (descriptor_address^ < (current_stack_frame^ +8)) THEN

        p := #LOC (establishing_save_area^);
        IF (p^.seg_offset <> apd_call_to_users_procedure.cbp^.seg_offset) THEN
          osp$set_status_condition (pme$descriptor_address_error, status);
          RETURN;
        IFEND;

        PUSH establish_status;
        pmp$validate_previous_save_area (#LOC (establishing_save_area^), establish_status^);
        IF NOT establish_status^.normal THEN
          status := establish_status^;
          RETURN;
        IFEND;

        apd_stack_frame := TRUE;
        establishing_save_area := establishing_save_area^.a2_previous_save_area;
      ELSE
        apd_stack_frame := FALSE;
      IFEND;
    UNTIL NOT apd_stack_frame;

    establish_descriptor^.established_conditions := conditions;

    IF (conditions.selector = pmc$system_conditions) AND ((conditions.system_conditions *
          unselectable_system_conditions) <> $pmt$system_conditions []) THEN
      osp$set_status_condition (pme$unselectable_condition, status);
      RETURN;
    IFEND;


    IF (conditions.selector = pmc$user_defined_condition) THEN
      clp$validate_name (conditions.user_condition_name, condition_name, valid_name);
      IF NOT valid_name THEN
        osp$set_status_condition (pme$incorrect_condition_name, status);
        RETURN;
      IFEND;

      establish_descriptor^.established_conditions.user_condition_name := condition_name;
    IFEND;


    establish_descriptor^.handler_active := handler_inactive;
    establish_descriptor^.handler := condition_handler;
    establish_descriptor^.established := TRUE;

    IF NOT (establishing_save_area^.frame_descriptor.on_condition_flag) THEN
      establish_descriptor^.est_handler_stack := NIL;

{ Initialize the OS stack frame word.

      establishing_save_area^.a1_current_stack_frame^ := initialize_os_stack_frame_word;

    ELSE

      handler_stack := #LOC (establishing_save_area^.a1_current_stack_frame^);

{ It is assumed that the handler stack pointer must be NIL or be a valid pointer in the
{ stack if the on condition flag (OCF) is set.

      IF NOT ((handler_stack^.ring = 0f(16)) AND ((handler_stack^.seg = 0fff(16)) AND
            ((handler_stack^.offset_sign = 1) AND (handler_stack^.offset = 0)))) THEN
        IF (handler_stack^.ring <> #RING (block)) OR ((handler_stack^.seg = #SEGMENT (block)) AND
              (establishing_save_area^.a0_dynamic_space_pointer.offset <
              (handler_stack^.offset + #SIZE (pmt$established_handler)))) THEN
          osp$set_status_condition (pme$handler_stack_error, status);
          RETURN;
        IFEND;
      IFEND;

      establish_descriptor^.est_handler_stack := establishing_save_area^.a1_current_stack_frame^.
            established_handler;
    IFEND;

    establishing_save_area^.a1_current_stack_frame^.established_handler := establish_descriptor;

    IF (conditions.selector = pmc$block_exit_processing) OR
          (conditions.selector = pmc$all_conditions) OR ((conditions.selector = pmc$condition_combination) AND
          (pmc$block_exit_processing IN conditions.combination)) THEN
      establishing_save_area^.frame_descriptor.critical_frame_flag := TRUE;
      establishing_save_area^.a1_current_stack_frame^.block_exit_frame := TRUE;
    IFEND;

    establishing_save_area^.frame_descriptor.on_condition_flag := TRUE;

  PROCEND pmp$establish_ch_in_block;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$establish_ch_outside_block', EJECT ??
*copy pmh$establish_ch_outside_block

{   WARNING: if this procedure must be modified the equivalent modifications must be made to
{            PMP$ESTABLISH_CH_IN_BLOCK.

  PROCEDURE [XDCL, #GATE] pmp$establish_ch_outside_block
    (    conditions: pmt$condition;
         condition_handler: pmt$condition_handler;
         block: ^ost$stack_frame_save_area;
         establish_descriptor {input, output} : ^pmt$established_handler;
     VAR status: ost$status);

    VAR
      condition_name: ost$name,
      csf: ^ost$pva,
      current_stack_frame: ^comparable_pointer,
      descriptor_address: ^comparable_pointer,
      dynamic_space_pointer: ^comparable_pointer,
      descriptor_internal_p: ^pmt$established_handler_internl,
      establish_status: ^ost$status,
      establishing_save_area: ^pmt$minimum_save_area,
      executing_stack: ^cell,
      handler_stack: ^pva,
      p: ^p_address,
      valid_name: boolean;

    status.normal := TRUE;

    IF ((conditions.selector < LOWERVALUE (pmt$condition_selector)) OR
          (conditions.selector > UPPERVALUE (pmt$condition_selector))) THEN
      osp$set_status_condition (pme$invalid_condition_selector, status);
      RETURN;
    IFEND;

{ Skip the apd stack frame if present.

    establishing_save_area := #LOC (block^);

    p := #LOC (establishing_save_area^);
    IF (p^.seg_offset = apd_call_to_users_procedure.cbp^.seg_offset) THEN

      PUSH establish_status;
      pmp$validate_previous_save_area (#LOC (establishing_save_area^), establish_status^);
      IF NOT establish_status^.normal THEN
        status := establish_status^;
        RETURN;
      IFEND;

      establishing_save_area := establishing_save_area^.a2_previous_save_area;
    IFEND;

{ Validate that the descriptor is either not in the stack or in the stack before
{ the current stack frame.

    IF #SEGMENT (^executing_stack) = #SEGMENT (establish_descriptor) THEN

{ Validate current stack frame (a1) pointer.

      csf := #LOC (establishing_save_area^.a1_current_stack_frame);
      IF ((csf^.ring <> #RING (^executing_stack)) OR (csf^.seg <> #SEGMENT (^executing_stack)) OR
            (establishing_save_area^.a0_dynamic_space_pointer.offset < (csf^.offset + 8))) THEN
        osp$set_status_condition (pme$inconsistent_stack, status);
        RETURN;
      IFEND;

{ validate descriptor address

      descriptor_address := #LOC (establish_descriptor);
      dynamic_space_pointer := #LOC (establishing_save_area^.a0_dynamic_space_pointer);

      IF (descriptor_address^ + #SIZE (pmt$established_handler)) >= dynamic_space_pointer^ THEN
        osp$set_status_condition (pme$descriptor_address_error, status);
        RETURN;
      IFEND;
    IFEND;

    establish_descriptor^.established_conditions := conditions;

{ Verify the selected system conditions.

    IF (conditions.selector = pmc$system_conditions) AND ((conditions.system_conditions *
          unselectable_system_conditions) <> $pmt$system_conditions []) THEN
      osp$set_status_condition (pme$unselectable_condition, status);
      RETURN;
    IFEND;

{ Verify the user condition name.

    IF (conditions.selector = pmc$user_defined_condition) THEN
      clp$validate_name (conditions.user_condition_name, condition_name, valid_name);
      IF NOT valid_name THEN
        osp$set_status_condition (pme$incorrect_condition_name, status);
        RETURN;
      IFEND;

      establish_descriptor^.established_conditions.user_condition_name := condition_name;
    IFEND;

{ Add the descriptor to the callers condition stack.

    establish_descriptor^.handler_active := handler_inactive;
    establish_descriptor^.handler := condition_handler;
    establish_descriptor^.established := TRUE;
    descriptor_internal_p := #LOC (establish_descriptor^);
    descriptor_internal_p^.established_outside_block :=
           #SEGMENT (^executing_stack) <> #SEGMENT (establish_descriptor);

    IF NOT (establishing_save_area^.frame_descriptor.on_condition_flag) THEN
      establish_descriptor^.est_handler_stack := NIL;

{ Initialize the OS stack frame word.

      establishing_save_area^.a1_current_stack_frame^ := initialize_os_stack_frame_word;

    ELSE

{ validate current top of handler stack

      handler_stack := #LOC (establishing_save_area^.a1_current_stack_frame^);

{ It is assumed that the handler stack pointer must be NIL or be a valid pointer in the
{ stack if the on condition flag (OCF) is set.

      IF NOT ((handler_stack^.ring = 0f(16)) AND ((handler_stack^.seg = 0fff(16)) AND
            ((handler_stack^.offset_sign = 1) AND (handler_stack^.offset = 0)))) THEN
        IF (handler_stack^.ring <> #RING (^executing_stack)) OR
              ((handler_stack^.seg = #SEGMENT (^executing_stack)) AND
              (establishing_save_area^.a0_dynamic_space_pointer.offset <
              (handler_stack^.offset + #SIZE (pmt$established_handler)))) THEN
          osp$set_status_condition (pme$handler_stack_error, status);
          RETURN;
        IFEND;
      IFEND;

      establish_descriptor^.est_handler_stack := establishing_save_area^.a1_current_stack_frame^.
            established_handler;
    IFEND;

    establishing_save_area^.a1_current_stack_frame^.established_handler := establish_descriptor;

    IF (conditions.selector = pmc$block_exit_processing) OR
          (conditions.selector = pmc$all_conditions) OR ((conditions.selector = pmc$condition_combination) AND
          (pmc$block_exit_processing IN conditions.combination)) THEN
      establishing_save_area^.frame_descriptor.critical_frame_flag := TRUE;
      establishing_save_area^.a1_current_stack_frame^.block_exit_frame := TRUE;
    IFEND;

    establishing_save_area^.frame_descriptor.on_condition_flag := TRUE;

  PROCEND pmp$establish_ch_outside_block;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$find_handler_in_stack', EJECT ??

{   PURPOSE:
{     This procedure finds the most recently established handler for the
{     condition in the stack segment defined by save_area.

  PROCEDURE [XDCL] pmp$find_handler_in_stack
    (    condition: pmt$internal_condition;
         save_area: ^ost$stack_frame_save_area;
     VAR established_handler: ^pmt$established_handler;
     VAR handler_save_area: ^ost$stack_frame_save_area;
     VAR find_status: ost$status);

?? NEWTITLE := 'dispose_of_handler_stack_error', EJECT ??

    PROCEDURE dispose_of_handler_stack_error
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      VAR
        ignore_status: ost$status;

      IF (condition.selector <> pmc$system_conditions) OR ((condition.selector = pmc$system_conditions) AND
            NOT (pmc$detected_uncorrected_err IN condition.system_conditions)) THEN
        osp$set_status_condition (pme$handler_stack_error, find_status);
        EXIT pmp$find_handler_in_stack;
      ELSE
        osp$set_status_from_condition (pmc$program_management_id, condition, save_area, status,
              ignore_status);
      IFEND;
    PROCEND dispose_of_handler_stack_error;
?? OLDTITLE, EJECT ??


    VAR
      descriptor: pmt$established_handler,
      sfsa: ^ost$stack_frame_save_area,
      established_handler_stack: ^pmt$established_handler,
      current_sa: ^pmt$minimum_save_area,
      stack_segment_ring: ost$ring;


    find_status.normal := TRUE;

    pmp$establish_condition_handler (handler_stack_error, ^dispose_of_handler_stack_error, ^descriptor,
          find_status);

    current_sa := #LOC (save_area^);
    established_handler_stack := handler_stack (current_sa);
    stack_segment_ring := #RING (current_sa);
    established_handler := NIL;

    WHILE (established_handler = NIL) AND (current_sa <> NIL) AND (#RING (current_sa) =
          stack_segment_ring) AND find_status.normal DO

      find_handler_in_stack_frame (condition, current_sa, established_handler_stack, established_handler,
            find_status);
      IF find_status.normal THEN
        IF (established_handler = NIL) THEN
          sfsa := #LOC (current_sa^);

          pmp$validate_previous_save_area (sfsa, find_status);
          IF find_status.normal THEN
            current_sa := current_sa^.a2_previous_save_area;
            established_handler_stack := handler_stack (current_sa);
          IFEND;
        ELSE
          handler_save_area := #LOC (current_sa^);
        IFEND;
      IFEND;
    WHILEND;


  PROCEND pmp$find_handler_in_stack;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$find_next_handler_in_stack', EJECT ??

{   PURPOSE:
{     This procedure finds the next most recently established handler for the
{     condition in the stack segment defined by save_area.

  PROCEDURE [XDCL] pmp$find_next_handler_in_stack
    (    condition: pmt$internal_condition;
         save_area: ^ost$stack_frame_save_area;
         current_handler: ^pmt$established_handler;
     VAR established_handler: ^pmt$established_handler;
     VAR handler_save_area: ^ost$stack_frame_save_area;
     VAR find_status: ost$status);

    VAR
      starting_sa: ^ost$stack_frame_save_area,
      stack_segment_ring: ost$ring;

    find_status.normal := TRUE;
    IF (current_handler <> NIL) THEN
      handler_save_area := save_area;
      pmp$find_next_handler_in_frame (condition, save_area, current_handler, established_handler,
            find_status);
      IF find_status.normal THEN
        IF (established_handler = NIL) THEN
          pmp$validate_previous_save_area (save_area, find_status);
          IF find_status.normal THEN
            stack_segment_ring := #RING (save_area);
            IF (save_area^.minimum_save_area.a2_previous_save_area <> NIL) AND
                  (#RING (save_area^.minimum_save_area.a2_previous_save_area) = stack_segment_ring) THEN
              starting_sa := save_area^.minimum_save_area.a2_previous_save_area;
              pmp$find_handler_in_stack (condition, starting_sa, established_handler, handler_save_area,
                    find_status);
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    ELSE
      pmp$find_handler_in_stack (condition, save_area, established_handler, handler_save_area, find_status);
    IFEND;


  PROCEND pmp$find_next_handler_in_stack;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$find_handler_in_stack_frame', EJECT ??

{   PURPOSE:
{     This procedure finds the most recently established handler for the
{     condition in the stack frame defined by save_area.

  PROCEDURE [XDCL] pmp$find_handler_in_stack_frame
    (    condition: pmt$internal_condition;
         save_area: ^ost$stack_frame_save_area;
     VAR established_handler: ^pmt$established_handler;
     VAR handler_save_area: ^ost$stack_frame_save_area;
     VAR find_status: ost$status);

?? NEWTITLE := 'dispose_of_handler_stack_error', EJECT ??

    PROCEDURE dispose_of_handler_stack_error
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      VAR
        ignore_status: ost$status;

      IF (condition.selector <> pmc$system_conditions) OR ((condition.selector = pmc$system_conditions) AND
            NOT (pmc$detected_uncorrected_err IN condition.system_conditions)) THEN
        osp$set_status_condition (pme$handler_stack_error, find_status);
        EXIT pmp$find_handler_in_stack_frame;
      ELSE
        osp$set_status_from_condition (pmc$program_management_id, condition, save_area, status,
              ignore_status);
      IFEND;
    PROCEND dispose_of_handler_stack_error;
?? OLDTITLE, EJECT ??

    VAR
      descriptor: pmt$established_handler,
      current_sa: ^pmt$minimum_save_area,
      established_handler_stack: ^pmt$established_handler,
      ignore_status: ost$status;

    find_status.normal := TRUE;

    pmp$establish_condition_handler (handler_stack_error, ^dispose_of_handler_stack_error, ^descriptor,
          ignore_status);

    handler_save_area := save_area;
    current_sa := #LOC (save_area^);
    established_handler_stack := handler_stack (current_sa);

    find_handler_in_stack_frame (condition, current_sa, established_handler_stack, established_handler,
          find_status);


  PROCEND pmp$find_handler_in_stack_frame;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$find_next_handler_in_frame', EJECT ??

{   PURPOSE:
{     This procedure finds the next most recently established handler for the
{     condition in the stack frame defined by save_area.

  PROCEDURE [XDCL] pmp$find_next_handler_in_frame
    (    condition: pmt$internal_condition;
         save_area: ^ost$stack_frame_save_area;
         current_handler: ^pmt$established_handler;
     VAR established_handler: ^pmt$established_handler;
     VAR find_status: ost$status);

?? NEWTITLE := 'dispose_of_handler_stack_error', EJECT ??

    PROCEDURE dispose_of_handler_stack_error
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      VAR
        ignore_status: ost$status;

      IF (condition.selector <> pmc$system_conditions) OR ((condition.selector = pmc$system_conditions) AND
            NOT (pmc$detected_uncorrected_err IN condition.system_conditions)) THEN
        osp$set_status_condition (pme$handler_stack_error, find_status);
        EXIT pmp$find_next_handler_in_frame;
      ELSE
        osp$set_status_from_condition (pmc$program_management_id, condition, save_area, status,
              ignore_status);
      IFEND;
    PROCEND dispose_of_handler_stack_error;
?? OLDTITLE, EJECT ??

    VAR
      descriptor: pmt$established_handler,
      current_sa: ^pmt$minimum_save_area,
      established_handler_stack: ^pmt$established_handler,
      ignore_status: ost$status;


    find_status.normal := TRUE;

    pmp$establish_condition_handler (handler_stack_error, ^dispose_of_handler_stack_error, ^descriptor,
          ignore_status);
    current_sa := #LOC (save_area^);
    established_handler_stack := current_handler^.est_handler_stack;

    find_handler_in_stack_frame (condition, current_sa, established_handler_stack, established_handler,
          find_status);


  PROCEND pmp$find_next_handler_in_frame;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$inhibit_system_conditions', EJECT ??
*copy pmh$inhibit_system_conditions

  PROCEDURE [XDCL, #GATE] pmp$inhibit_system_conditions
    (    conditions: pmt$system_conditions;
     VAR status: ost$status);


    VAR
      inhibit: ost$user_conditions,
      inhibit_bit: ost$user_condition,
      requestor_sfsa: ^ost$stack_frame_save_area,
      system_condition: pmt$system_condition,
      user_inhibit: pmt$system_conditions;

    status.normal := TRUE;

    IF (conditions <> $pmt$system_conditions []) THEN
      IF ((conditions - maskable_system_conditions) = $pmt$system_conditions []) THEN
        inhibit := $ost$user_conditions [];
        inhibit_bit := osc$divide_fault;
        system_condition := pmc$divide_fault;
        user_inhibit := conditions;

        WHILE (user_inhibit <> $pmt$system_conditions []) DO
          IF (system_condition IN user_inhibit) THEN
            inhibit := inhibit + $ost$user_conditions [inhibit_bit];
            user_inhibit := (user_inhibit - $pmt$system_conditions [system_condition]);
          IFEND;

          IF (system_condition < pmc$invalid_bdp_data) THEN
            system_condition := SUCC (system_condition);
            inhibit_bit := SUCC (inhibit_bit);
          IFEND;
        WHILEND;

        requestor_sfsa := #PREVIOUS_SAVE_AREA ();
        requestor_sfsa^.minimum_save_area.user_mask := (requestor_sfsa^.minimum_save_area.user_mask -
              inhibit);
      ELSE
        osp$set_status_condition (pme$unselectable_condition, status);
      IFEND;
    IFEND;

  PROCEND pmp$inhibit_system_conditions;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$is_there_a_handler_in_stack', EJECT ??

{   PURPOSE:
{     This procedure returns if an established handler has been found
{     on the stack segment defined by save_area.  If not the last frame
{     on the stack is returned.

  PROCEDURE [XDCL] pmp$is_there_a_handler_in_stack
    (    condition: pmt$internal_condition;
         save_area: ^ost$stack_frame_save_area;
     VAR established_handler: ^pmt$established_handler;
     VAR handler_save_area: ^ost$stack_frame_save_area;
     VAR find_status: ost$status);

?? NEWTITLE := 'dispose_of_handler_stack_error', EJECT ??

    PROCEDURE dispose_of_handler_stack_error
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      VAR
        ignore_status: ost$status;

      IF (condition.selector <> pmc$system_conditions) OR ((condition.selector = pmc$system_conditions) AND
            NOT (pmc$detected_uncorrected_err IN condition.system_conditions)) THEN
        osp$set_status_condition (pme$handler_stack_error, find_status);
        EXIT pmp$is_there_a_handler_in_stack;
      ELSE
        osp$set_status_from_condition (pmc$program_management_id, condition, save_area, status,
              ignore_status);
      IFEND;
    PROCEND dispose_of_handler_stack_error;
?? OLDTITLE, EJECT ??


    VAR
      descriptor: pmt$established_handler,
      sfsa: ^ost$stack_frame_save_area,
      established_handler_stack: ^pmt$established_handler,
      current_sa: ^pmt$minimum_save_area,
      stack_segment_ring: ost$ring;


    find_status.normal := TRUE;

    pmp$establish_condition_handler (handler_stack_error, ^dispose_of_handler_stack_error, ^descriptor,
          find_status);

    current_sa := #LOC (save_area^);
    established_handler_stack := handler_stack (current_sa);
    stack_segment_ring := #RING (current_sa);
    established_handler := NIL;

    WHILE (established_handler = NIL) AND (#RING (current_sa) = stack_segment_ring) AND find_status.normal DO

      find_handler_in_stack_frame (condition, current_sa, established_handler_stack, established_handler,
            find_status);
      IF find_status.normal THEN
        IF (established_handler = NIL) THEN
          IF (current_sa^.a2_previous_save_area <> NIL) AND (#RING (current_sa^.a2_previous_save_area) =
                stack_segment_ring) THEN

            sfsa := #LOC (current_sa^);
            pmp$validate_previous_save_area (sfsa, find_status);
            IF find_status.normal THEN
              current_sa := current_sa^.a2_previous_save_area;
              established_handler_stack := handler_stack (current_sa);
            IFEND;
          ELSE
            handler_save_area := #LOC (current_sa^);
            RETURN;
          IFEND;
        ELSE
          handler_save_area := #LOC (current_sa^);
        IFEND;
      IFEND;
    WHILEND;


  PROCEND pmp$is_there_a_handler_in_stack;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$validate_previous_save_area', EJECT ??
*copy pmh$validate_previous_save_area

  PROCEDURE [XDCL, #GATE] pmp$validate_previous_save_area
    (    current_save_area: ^ost$stack_frame_save_area;
     VAR status: ost$status);

    VAR
      traps: 0 .. 3;

?? NEWTITLE := 'dispose_of_stack_error', EJECT ??

    PROCEDURE dispose_of_stack_error
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF (condition.selector <> pmc$system_conditions) OR ((condition.selector = pmc$system_conditions) AND
            NOT (pmc$detected_uncorrected_err IN condition.system_conditions)) THEN
        osp$set_status_condition (pme$inconsistent_stack, status);
        i#restore_traps (traps);
        EXIT pmp$validate_previous_save_area;
      ELSE
        osp$set_status_from_condition (pmc$program_management_id, condition, save_area, condition_status,
              ignore_status);
      IFEND;

    PROCEND dispose_of_stack_error;
?? OLDTITLE, EJECT ??


    VAR
      psa: ^ost$stack_frame_save_area, {previous_save_area}
      current_psa: ^cell,
      descriptor: pmt$established_handler,
      ignore_status: ost$status;


    i#enable_traps (traps);
    status.normal := TRUE;

    pmp$establish_condition_handler (stack_error, ^dispose_of_stack_error, ^descriptor, ignore_status);

    IF (current_save_area^.minimum_save_area.a2_previous_save_area <> NIL) THEN
      psa := current_save_area^.minimum_save_area.a2_previous_save_area;
      current_psa := current_save_area^.minimum_save_area.a2_previous_save_area;
      IF (((psa^.minimum_save_area.a2_previous_save_area = NIL) OR
            ((#OFFSET (psa^.minimum_save_area.a2_previous_save_area) >= 0) AND
            ((#OFFSET (psa^.minimum_save_area.a2_previous_save_area) MOD 8) = 0))) AND
            (current_psa = psa^.minimum_save_area.a0_dynamic_space_pointer) AND
            (psa^.minimum_save_area.frame_descriptor.a_terminating > 1)) THEN
        status.normal := TRUE;
      ELSE
        osp$set_status_condition (pme$inconsistent_stack, status);
      IFEND;
    IFEND;

    i#restore_traps (traps);

  PROCEND pmp$validate_previous_save_area;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] tmp$find_ring_crossing_frame', EJECT ??
*copy tmh$find_ring_crossing_frame

  PROCEDURE [XDCL] tmp$find_ring_crossing_frame
    (    starting_frame: ^ost$stack_frame_save_area;
     VAR frame: ^ost$stack_frame_save_area;
     VAR status: ost$status);

?? NEWTITLE := 'dispose_of_stack_error', EJECT ??

    PROCEDURE dispose_of_stack_error
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        ignore_status: ost$status;

      CASE condition.selector OF
      = pmc$system_conditions =
        IF NOT (pmc$detected_uncorrected_err IN condition.system_conditions) THEN
          osp$set_status_condition (pme$inconsistent_stack, status);
          EXIT tmp$find_ring_crossing_frame;
        ELSE
          osp$set_status_from_condition (pmc$program_management_id, condition, save_area, condition_status,
                ignore_status);
        IFEND;
      = mmc$segment_access_condition =
        osp$set_status_condition (pme$inconsistent_stack, status);
        EXIT tmp$find_ring_crossing_frame;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, ignore_status);
        condition_status.normal := TRUE;
      CASEND;
    PROCEND dispose_of_stack_error;
?? OLDTITLE, EJECT ??

    VAR
      stack_segment_ring: ost$ring,
      psa: ^ost$stack_frame_save_area, {previous_save_area}
      current_psa: ^cell;

    status.normal := TRUE;
    osp$establish_condition_handler (^dispose_of_stack_error, FALSE);


    IF (starting_frame = NIL) THEN
      frame := #PREVIOUS_SAVE_AREA ();
    ELSE
      frame := starting_frame;
    IFEND;

    stack_segment_ring := #RING (frame);
    WHILE (frame^.minimum_save_area.a2_previous_save_area <> NIL) AND
          (#RING (frame^.minimum_save_area.a2_previous_save_area) = stack_segment_ring) AND status.normal DO
      psa := frame^.minimum_save_area.a2_previous_save_area;
      current_psa := frame^.minimum_save_area.a2_previous_save_area;
      IF (((psa^.minimum_save_area.a2_previous_save_area = NIL) OR
            ((#OFFSET (psa^.minimum_save_area.a2_previous_save_area) >= 0) AND
            ((#OFFSET (psa^.minimum_save_area.a2_previous_save_area) MOD 8) = 0))) AND
            (current_psa = psa^.minimum_save_area.a0_dynamic_space_pointer) AND
            (psa^.minimum_save_area.frame_descriptor.a_terminating > 1)) THEN
        frame := frame^.minimum_save_area.a2_previous_save_area;
      ELSE
        osp$set_status_condition (pme$inconsistent_stack, status);
      IFEND;
    WHILEND;

  PROCEND tmp$find_ring_crossing_frame;
?? OLDTITLE ??
?? NEWTITLE := 'validate_descriptor_address', EJECT ??

  PROCEDURE validate_descriptor_address
    (    save_area: ^pmt$minimum_save_area;
         descriptor: ^pmt$established_handler;
     VAR status: ost$status);


    VAR
      current_stack_frame: ^comparable_pointer,
      descriptor_address: ^comparable_pointer,
      descriptor_internal_p: ^pmt$established_handler_internl,
      dynamic_space_pointer: ^comparable_pointer;


    descriptor_address := #LOC (descriptor);
    descriptor_internal_p := #LOC (descriptor^);
    current_stack_frame := #LOC (save_area^.a1_current_stack_frame);
    dynamic_space_pointer := #LOC (save_area^.a0_dynamic_space_pointer);

    IF (descriptor_address^ >= (current_stack_frame^ +8)) AND
          ((descriptor_address^ + #SIZE (pmt$established_handler)) < dynamic_space_pointer^) THEN
      status.normal := TRUE;
    ELSEIF NOT descriptor_internal_p^.established_outside_block THEN
      osp$set_status_condition (pme$descriptor_address_error, status);
    IFEND;

  PROCEND validate_descriptor_address;
?? OLDTITLE ??
MODEND pmm$condition_stack_processor;
