?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Status Record Setting Routines' ??
MODULE osm$set_status_abnormal ALIAS 'osmssa';

{
{ PURPOSE:
{   This module contains routines that provide a convenient means for
{   defining the contents of an ost$status record.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
*IF NOT $true(osv$unix)
?? PUSH (LISTEXT := ON) ??
*copyc mmc$first_transient_segment
*copyc mmd$segment_access_condition
*copyc mme$condition_codes
*copyc osc$processor_defined_registers
*copyc ose$condition_exceptions
*copyc ost$monitor_fault
*copyc ost$stack_frame_save_area
*copyc ost$status
*copyc ost$status_identifier
*copyc pme$broken_task_exceptions
*copyc pme$condition_exceptions
*copyc pme$system_exceptions
*copyc tmt$broken_task_monitor_fault
*copyc tmt$mcr_faults
?? POP ??
*copyc clp$convert_integer_to_rjstring
*ELSE
*copyc clp$trimmed_string_size
*copyc ose$unix_system_error
*copyc osp$set_status_condition
*copyc ost$status
*copyc ost$status_identifier
*copyc ost_c_integer
*IFEND
*copyc clp$convert_integer_to_string
*copyc osp$status_condition_code

?? OLDTITLE ??
?? NEWTITLE := 'osp$set_status_abnormal', EJECT ??
*copyc osh$set_status_abnormal

  PROCEDURE [XDCL, #GATE] osp$set_status_abnormal ALIAS 'ospssa'
    (    identifier: ost$status_identifier;
         condition: ost$status_condition_code;
         text: string ( * <= osc$max_string_size);
     VAR status: ost$status);

    status.normal := FALSE;
    status.condition := osp$status_condition_code (identifier, condition);

    status.text.size := 0;
    IF STRLENGTH (text) > 0 THEN
      osp$append_status_parameter (osc$status_parameter_delimiter, text, status);
    IFEND;

  PROCEND osp$set_status_abnormal;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE, XDCL, #GATE] osp$append_status_parameter', EJECT ??
*copy osh$append_status_parameter

  PROCEDURE [INLINE, XDCL, #GATE] osp$append_status_parameter ALIAS 'ospasp'
    (    delimiter: char;
         text: string ( * <= osc$max_string_size);
     VAR status {input, output} : ost$status);

    CONST
      space_constant = ' ';

    VAR
      space: char,
      status_text_size: ost$string_size,
      text_size: ost$string_size;

    IF status.normal THEN
      RETURN;
    IFEND;

    status_text_size := status.text.size;
    IF status_text_size >= osc$max_string_size THEN
      RETURN;
    IFEND;
    text_size := STRLENGTH (text);

{ By assigning the value space to a char the CYBIL compiler will place this value in a register.
{ In addition, code motion will move the register load out of the loop.  This should significantly,
{ improve the "stripping" of trailing characters.

    space := space_constant;
    WHILE (text_size > 0) AND (text (text_size) = space) DO
      text_size := text_size - 1;
    WHILEND;
    status_text_size := status_text_size + 1;
    status.text.value (status_text_size) := delimiter;
    IF text_size > osc$max_string_size - status_text_size THEN
      text_size := osc$max_string_size - status_text_size;
    IFEND;
    status.text.value (status_text_size + 1, text_size) := text (1, text_size);
    status.text.size := status_text_size + text_size;


  PROCEND osp$append_status_parameter;
?? OLDTITLE ??
?? NEWTITLE := 'osp$append_status_integer', EJECT ??
*copyc osh$append_status_integer

  PROCEDURE [XDCL, #GATE] osp$append_status_integer ALIAS 'ospasi'
    (    delimiter: char;
         int: integer;
         radix: 2 .. 16;
         include_radix_specifier: boolean;
     VAR status {input, output} : ost$status);

    VAR
      ignore_status: ost$status,
      text: ost$string;


    clp$convert_integer_to_string (int, radix, include_radix_specifier, text, ignore_status);
    osp$append_status_parameter (delimiter, text.value (1, text.size), status);

  PROCEND osp$append_status_integer;
?? OLDTITLE ??
*IF $true(osv$unix)
?? NEWTITLE := '[XDCL, #GATE] osp$set_status_from_errno', EJECT ??
*copyc osh$set_status_from_errno

  PROCEDURE [XDCL, #GATE] osp$set_status_from_errno
    (    system_call: string ( * <= osc$max_string_size);
         stat: ost_c_integer;
         syserrlist_message: string ( * <= osc$max_string_size);
     VAR status: ost$status);

    osp$set_status_condition (ose$unix_system_error, status);
    osp$append_status_integer (osc$status_parameter_delimiter, stat, 10, FALSE, status);
    osp$append_status_parameter (osc$status_parameter_delimiter, system_call, status);
    IF syserrlist_message <> ' ' THEN
      osp$append_status_parameter (osc$status_parameter_delimiter, syserrlist_message (1,
            clp$trimmed_string_size (syserrlist_message)), status);
    IFEND;

  PROCEND osp$set_status_from_errno;
?? OLDTITLE ??
*IFEND
*IF NOT $true(osv$unix)
?? NEWTITLE := '[XDCL, #GATE] osp$monitor_fault_to_status', EJECT ??
*copy osh$monitor_fault_to_status

  PROCEDURE [XDCL, #GATE] osp$monitor_fault_to_status
    (    monitor_fault: ost$monitor_fault;
         minimum_save_area_p: ^ost$minimum_save_area;
     VAR status: ost$status);

?? NEWTITLE := 'append_address_to_status', EJECT ??

    PROCEDURE append_address_to_status
      (    address: ost$pva;
       VAR status {input, output} : ost$status);

      osp$append_status_integer (osc$status_parameter_delimiter, address.ring, 16, FALSE, status);
      osp$append_status_integer (' ', address.seg, 16, FALSE, status);
      osp$append_status_integer (' ', address.offset, 16, FALSE, status);
    PROCEND append_address_to_status;
?? OLDTITLE ??
?? NEWTITLE := 'handle_broken_task_fault', EJECT ??

    PROCEDURE handle_broken_task_fault;

      VAR
        broken_task: ^tmt$broken_task_monitor_fault,
        broken_task_dsp: ^ost$pva,
        broken_task_mcr: ^0 .. 0ffff(16),
        broken_task_ucr: ^0 .. 0ffff(16),
        executing_ring: ost$ring,
        executing_segment: ^ost$p_register,
        p_register: integer;

      broken_task := #LOC (monitor_fault.contents);
      broken_task_mcr := #LOC (broken_task^.monitor_condition_register);
      CASE broken_task^.broken_task_condition OF
      = tmc$btc_mntr_fault_buffer_full =
        osp$set_status_abnormal (pmc$program_management_id, pme$monitor_fault_buffer_full, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER(broken_task^.monitor_fault_id),
             10, FALSE, status);
        append_address_to_status (broken_task^.p.pva, status);
        osp$append_status_integer (osc$status_parameter_delimiter, broken_task_mcr^, 16, FALSE, status);
        broken_task_ucr := #LOC (broken_task^.user_condition_register);
        osp$append_status_integer (osc$status_parameter_delimiter, broken_task_ucr^, 16, FALSE, status);

      = tmc$btc_mf_traps_disabled =
        osp$set_status_abnormal (pmc$program_management_id, pme$fault_with_traps_disabled, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER(broken_task^.monitor_fault_id),
              10, FALSE, status);
        append_address_to_status (broken_task^.p.pva, status);
        broken_task_dsp := #LOC (broken_task^.a0);
        append_address_to_status (broken_task_dsp^, status);
        osp$append_status_integer (osc$status_parameter_delimiter, broken_task_mcr^, 16, FALSE, status);

      = tmc$btc_invalid_a0 =
        p_register := #READ_REGISTER (osc$pr_p_reg);
        executing_segment := #LOC (p_register);

{ If the error occurred in an NOS/VE segment report the error as a DSP error otherwise
{ report the error as an "inconsistent stack."

{ NOTE: The procedure tmp$dispose_of_broken_task relies on the status condition
{       pme$inconsistent_stack.

        IF minimum_save_area_p^.p_register.pva.seg < mmc$first_loader_predefined_seg THEN
          broken_task_dsp := #LOC (broken_task^.a0);
          osp$set_status_abnormal (pmc$program_management_id, pme$invalid_dynamic_space_ptr, '', status);
          append_address_to_status (broken_task_dsp^, status);
          append_address_to_status (broken_task^.p.pva, status);
          osp$append_status_integer (osc$status_parameter_delimiter, broken_task_mcr^, 16, FALSE, status);
          broken_task_ucr := #LOC (broken_task^.user_condition_register);
          osp$append_status_integer (osc$status_parameter_delimiter, broken_task_ucr^, 16, FALSE, status);
        ELSE
          osp$set_status_abnormal (pmc$program_management_id, pme$inconsistent_stack, '', status);
        IFEND;

      = tmc$btc_invalid_p =
        osp$set_status_abnormal (pmc$program_management_id, pme$invalid_p_register, '', status);
        append_address_to_status (broken_task^.p.pva, status);
        append_address_to_status (broken_task_dsp^, status);
        osp$append_status_integer (osc$status_parameter_delimiter, broken_task_mcr^, 16, FALSE, status);
        broken_task_ucr := #LOC (broken_task^.user_condition_register);
        osp$append_status_integer (osc$status_parameter_delimiter, broken_task_ucr^, 16, FALSE, status);

      = tmc$btc_mcr_traps_disabled =
        osp$set_status_abnormal (pmc$program_management_id, pme$mcr_with_traps_disabled, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, broken_task_mcr^, 16, FALSE, status);
        append_address_to_status (broken_task^.p.pva, status);

      = tmc$btc_ucr_traps_disabled =
        osp$set_status_abnormal (pmc$program_management_id, pme$ucr_with_traps_disabled, '', status);
        broken_task_ucr := #LOC (broken_task^.user_condition_register);
        osp$append_status_integer (osc$status_parameter_delimiter, broken_task_ucr^, 16, FALSE, status);
        append_address_to_status (broken_task^.p.pva, status);

      = tmc$btc_system_error =
        osp$set_status_abnormal (pmc$program_management_id, pme$system_error, '', status);

      ELSE
        osp$set_status_abnormal (pmc$program_management_id, pme$undefined_broken_task, '', status);
        append_address_to_status (broken_task^.p.pva, status);
      CASEND;

    PROCEND handle_broken_task_fault;
?? OLDTITLE ??
?? NEWTITLE := 'handle_mcr_fault', EJECT ??

    PROCEDURE handle_mcr_fault;

      CONST
        default_mcr_message = 'MCR fault - MCR = 0000',
        mcr_message_length = 22,
        mcr_length = 4;

      VAR
        mcr_faults: ^tmt$mcr_faults,
        mcr_faults_mcr_register: ^0 .. 0ffff(16),
        mcr_message: string (mcr_message_length),
        mcr_string: string (mcr_length);

      mcr_faults := #LOC (monitor_fault.contents);
      mcr_faults_mcr_register := #LOC (mcr_faults^.faults);
      clp$convert_integer_to_rjstring (mcr_faults_mcr_register^, 16, FALSE, '0', mcr_string,
            { ignore } status);
      mcr_message := default_mcr_message;
      mcr_message (mcr_message_length - mcr_length + 1, mcr_length) := mcr_string;

      osp$set_status_abnormal (pmc$program_management_id, pme$system_condition, mcr_message, status);
      append_address_to_status (minimum_save_area_p^.p_register.pva, status);
      osp$append_status_parameter (' ', 'PVA', status);
      osp$append_status_integer ('=', mcr_faults^.untranslatable_pointer.ring, 16, FALSE, status);
      osp$append_status_integer (' ', mcr_faults^.untranslatable_pointer.seg, 16, FALSE, status);
      osp$append_status_integer (' ', mcr_faults^.untranslatable_pointer.offset, 16, FALSE, status);

    PROCEND handle_mcr_fault;
?? OLDTITLE ??
?? NEWTITLE := 'handle_segment_fault', EJECT ??

    PROCEDURE handle_segment_fault;

      VAR
        error_pva: ost$pva,
        segment_access_condition: ^mmt$segment_access_condition;

      segment_access_condition := #LOC (monitor_fault.contents);
      error_pva.ring := #RING (segment_access_condition^.segment);
      error_pva.seg := #SEGMENT (segment_access_condition^.segment);
      error_pva.offset := #OFFSET (segment_access_condition^.segment);

      CASE segment_access_condition^.identifier OF
      = mmc$sac_io_read_error =
        osp$set_status_abnormal (pmc$program_management_id, mme$io_read_error, '', status);
      = mmc$sac_read_beyond_eoi =
        osp$set_status_abnormal (pmc$program_management_id, mme$read_beyond_eoi, '', status);
      = mmc$sac_read_write_beyond_msl =
        osp$set_status_abnormal (pmc$program_management_id, mme$read_write_beyond_msl, '', status);
      = mmc$sac_segment_access_error =
        osp$set_status_abnormal (pmc$program_management_id, mme$segment_access_error, '', status);
      = mmc$sac_ring_violation =
        osp$set_status_abnormal (pmc$program_management_id, mme$ring_violation, '', status);
      = mmc$sac_no_append_permission =
        osp$set_status_abnormal (pmc$program_management_id, mme$write_beyond_eoi_no_append, '', status);
      = mmc$sac_file_server_terminated =
        osp$set_status_abnormal (pmc$program_management_id, mme$file_server_terminated, '', status);
      = mmc$sac_pf_space_limit_exceeded =
        osp$set_status_abnormal (pmc$program_management_id, mme$pf_space_limit_exceeded, '', status);
      = mmc$sac_tf_space_limit_exceeded =
        osp$set_status_abnormal (pmc$program_management_id, mme$tf_space_limit_exceeded, '', status);
      ELSE
        osp$set_status_abnormal ('OS', ose$unknown_segment_condition, '', status);
      CASEND;
      append_address_to_status (error_pva, status);
      append_address_to_status (minimum_save_area_p^.p_register.pva, status);
    PROCEND handle_segment_fault;
?? OLDTITLE ??
?? EJECT ??

    CASE monitor_fault.identifier OF
    = tmc$broken_task_fault_id =
      handle_broken_task_fault;

    = tmc$mcr_fault =
      handle_mcr_fault;

    = mmc$segment_fault_processor_id =
      handle_segment_fault;

    = tmc$unknown_system_req_fault =
      osp$set_status_abnormal (pmc$program_management_id, pme$unknown_system_request, '', status);
      append_address_to_status (minimum_save_area_p^.p_register.pva, status);

    ELSE
      osp$set_status_abnormal (pmc$program_management_id, pme$unknown_monitor_fault, '', status);
      append_address_to_status (minimum_save_area_p^.p_register.pva, status);
    CASEND;
  PROCEND osp$monitor_fault_to_status;
?? OLDTITLE ??
*IFEND

MODEND osm$set_status_abnormal;
