?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Function Manager' ??
MODULE clm$function_manager;

{
{ PURPOSE:
{   This module contains the procedures that support the processing of
{   functions.
{
{ NOTE:
{   The clp$scan_argument_list interface has been moved to module
{   clm$scan_parameter_list.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$compiling_for_test_harness
*copyc clc$exiting_condition
*copyc clc$reset_dereference_name
*copyc cle$ecc_command_processing
*copyc cle$ecc_parsing
*copyc cle$ecc_utilities
*copyc cle$not_yet_implemented
*copyc cle$unable_to_call_function
*copyc cle$unexpected_call_to
*copyc cle$work_area_overflow
*copyc clt$data_value
*copyc clt$function_name
*copyc clt$function_result
*copyc clt$i_parameter_list_contents
*copyc clt$parse_state
*copyc clt$type_description
*copyc clt$type_specification
*copyc clt$variable_access_info
*copyc clt$variable_ref_expression
*copyc clt$work_area
*copyc cyd$run_time_error_condition
*IF $true(osv$unix)
*copyc cyt$mips_signal_handler
*IFEND
*copyc fsc$compiling_for_test_harness
*copyc llt$function_description
*copyc ost$caller_identifier
*copyc ost$status
*IF NOT $true(osv$unix)
*copyc pfe$error_condition_codes
*IFEND
?? POP ??
*IF NOT $true(osv$unix)
*copyc amv$nil_file_identifier
*IFEND
*copyc clp$append_status_parse_state
*copyc clp$convert_clt$value_to_value
*copyc clp$convert_int_value_to_ext
*IF NOT $true(osv$unix)
*copyc clp$convert_string_to_file
*IFEND
*copyc clp$convert_type_desc_to_spec
*IF NOT $true(osv$unix)
*copyc clp$echo_trace_information
*IFEND
*copyc clp$evaluate_parameters
*IF NOT $true(osv$unix)
*copyc clp$find_cmnd_or_func_in_prog
*IFEND
*copyc clp$find_command_list
*IF NOT $true(osv$unix)
*copyc clp$find_connected_files
*IFEND
*copyc clp$find_current_block
*IF NOT $true(osv$unix)
*copyc clp$get_interpreter_mode
*copyc clp$get_proc_value
*IFEND
*copyc clp$get_work_area
*IF NOT $true(osv$unix)
*copyc clp$load_from_library
*copyc clp$load_system_entry_point
*IFEND
*copyc clp$make_unspecified_value
*copyc clp$pop_block_stack
*copyc clp$pop_input_stack
*copyc clp$pop_terminated_blocks
*copyc clp$process_command_file
*IF NOT $true(osv$unix)
*copyc clp$process_exit_condition
*copyc clp$process_proc_parameters
*IFEND
*copyc clp$push_function_block
*IF NOT $true(osv$unix)
*copyc clp$push_function_proc_block
*IFEND
*copyc clp$scan_any_lexical_unit
*copyc clp$scan_bal_paren_lexical_unit
*copyc clp$scan_non_space_lexical_unit
*IF NOT $true(osv$unix)
*copyc clp$search_command_library
*IFEND
*copyc clp$trimmed_string_size
*copyc clv$system_functions
*copyc clv$system_functions_v0
*IF NOT $true(osv$unix)
  ?IF fsc$compiling_for_test_harness AND clc$compiling_for_test_harness THEN
*copyc fsv$test_harness_fnctns
  ?IFEND
*IFEND
*copyc osp$append_status_parameter
*IF NOT $true(osv$unix)
*copyc osp$disestablish_cond_handler
*copyc osp$enforce_exception_policies
*copyc osp$establish_condition_handler
*copyc osp$file_access_condition
*IFEND
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*IF NOT $true(osv$unix)
*copyc pmp$cause_condition
*copyc pmp$continue_to_cause
*copyc pmp$get_task_id
*copyc pmp$inward_call
*copyc pmp$load
*copyc pmp$pop_task_debug_mode
*copyc pmp$push_task_debug_mode
*ELSE
*copyc osp$set_status_from_errno
*copyc pmp_get_task_id
*IFEND
*IF NOT $true(osv$unix)
*copyc osv$initial_exception_context
*IFEND
?? TITLE := 'Declarations for "special functions"', EJECT ??

{
{ A "special" function is one that can be used in the context of a variable
{ reference, e.g. on the left side of an assignment statement.  The work of
{ such functions is split between the function processor and the caller of
{ clp$evaluate_function.  The function processor simply gathers the parameters
{ it is passed into a clt$function_result.
{
{ The processors for the special functions are at the end of this module.
{

  TYPE
    clt$special_function_processor = ^procedure
           (    evaluate_for_write: boolean;
                parameter_list: clt$parameter_list;
            VAR work_area {input, output} : ^clt$work_area;
            VAR result: clt$function_result;
            VAR status: ost$status);

?? TITLE := 'clp$evaluate_function', EJECT ??

  PROCEDURE [XDCL] clp$evaluate_function
    (    evaluate_for_write: boolean;
         name: clt$function_name;
         context_type_description: ^clt$type_description;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: clt$function_result;
     VAR found: boolean;
     VAR status: ost$status);

    CONST
*IF NOT $true(osv$unix)
      max_functions = 7fffffff(16);
*ELSE
      max_functions = 7ffffffe(16);
*IFEND

    VAR
      block_at_start_of_function: ^clt$block,
      caller_id: ost$caller_identifier,
      callers_save_area: ^ost$stack_frame_save_area,
      command_list: ^clt$command_list,
      current_entry: ^clt$command_list_entry,
      current_task_id: pmt$task_id,
      entry_after_fence: ^clt$command_list_entry,
      function_block: ^clt$block,
      got_task_id: boolean,
*IF $true(osv$unix)
      handler_established: boolean,
*IFEND
      ignore_cmnd_list_found_in_task: boolean,
      index: 1 .. max_functions,
      invoking_function: boolean,
      parameter_list_given: boolean,
      parameters_parse: clt$parse_state,
      search_mode: clt$command_search_modes,
      search_status: ^ost$status,
      source: clt$command_or_function_source,
      system_functions_searched: boolean;

?? NEWTITLE := 'function_condition_handler', EJECT ??

{
{ PURPOSE:
{   This condition handler is established to catch any conditions that occur
{   during the processing of a function.  It is also established for "block
{   exit" conditions and since it cannot disestablish itself, it is during the
{   processing of a block exit condition that cleanup activities are performed.
{

    PROCEDURE function_condition_handler
*IF $true(osv$unix)
      (    signal_no: integer;
           code: integer;
           p_sigcontext: ^cyt$mips_sigcontext);
*ELSE
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        exit_control_block: ^clt$block,
        ignore_status: ost$status,
        run_time_status: ^ost$status;


      CASE condition.selector OF

      = pmc$block_exit_processing =
*IFEND

{ --- Handle block exit.

        IF function_block <> NIL THEN
          clp$pop_terminated_blocks (block_at_start_of_function, status);
        IFEND;
        RETURN;

*IF NOT $true(osv$unix)
      = mmc$segment_access_condition =

{ --- Handle segment access conditions.

        osp$set_status_from_condition ('CL', condition, save_area, status, ignore_status);
        IF (status.condition = cle$work_area_overflow) AND (status.text.size = 0) THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
        IFEND;
        EXIT clp$evaluate_function;

      = pmc$system_conditions =
        IF pmc$detected_uncorrected_err IN condition.system_conditions THEN

{ --- Handle hardware detected uncorrected error condition.

          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          osp$set_status_from_condition ('CL', condition, save_area, status, ignore_status);
          EXIT clp$evaluate_function;

        ELSEIF invoking_function AND (($pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$environment_specification, pmc$invalid_segment_ring_0, pmc$out_call_in_return] *
              condition.system_conditions) <> $pmt$system_conditions []) AND
              (save_area^.minimum_save_area.a2_previous_save_area = callers_save_area) THEN

{ --- Handle system (hardware detected) conditions resulting from attempt to
{     invoke function processor.

          osp$set_status_abnormal ('CL', cle$unable_to_call_function, name, status);
          EXIT clp$evaluate_function;

        ELSE

{ --- Handle other system (hardware detected) conditions.

          osp$set_status_from_condition ('CL', condition, save_area, status, ignore_status);
          EXIT clp$evaluate_function;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN

{ --- Handle CYBIL run time error.

          run_time_status := condition_information;
          status := run_time_status^;
          EXIT clp$evaluate_function;

        ELSEIF (condition.user_condition_name = clc$exiting_condition) AND
              (function_block <> NIL) AND function_block^.being_exited THEN

{ --- Handle exit initiated via command level EXIT statement.
{
{ This condition is raised in the task that "owns" the SCL block which is the
{ target of the EXIT statement.
{ This condition is specifically dealt with in the condition handlers that
{ cover processing of the various kinds of input, command and function blocks.
{ The condition_information for this condition is a pointer to the outermost
{ block which is being exited and has such a corresponding condition handler.
{ The handler which is "covering" this "exit_control_block" performs a
{ non-local (CYBIL) exit out of its establishing procedure.
{ Other such handlers simply "continue" the condition.

          exit_control_block := condition_information;
          IF #OFFSET (exit_control_block) <> #OFFSET (function_block) THEN
            pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          IFEND;
          EXIT clp$evaluate_function;

        ELSE

{ --- "Continue" any other user defined condition.

          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          RETURN;
        IFEND;

      ELSE

{ --- "Continue" any other condition.

        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        RETURN;
      CASEND;
*IFEND

    PROCEND function_condition_handler;
?? TITLE := 'get_task_id', EJECT ??

    PROCEDURE [INLINE] get_task_id;

*IF $true(osv$unix)
      VAR
        c_status: integer;
*IFEND

      IF NOT got_task_id THEN
*IF NOT $true(osv$unix)
        pmp$get_task_id (current_task_id, status);
*ELSE
        pmp_get_task_id (current_task_id, c_status);
        IF c_status = 0 THEN
          status.normal := TRUE;
        ELSE
          osp$set_status_from_errno ('GET_TASK_ID', c_status, '', status);
        IFEND;
*IFEND
        IF NOT status.normal THEN
          EXIT clp$evaluate_function;
        IFEND;
        got_task_id := TRUE;
      IFEND;

    PROCEND get_task_id;
?? TITLE := 'isolate_parameters', EJECT ??

    PROCEDURE [INLINE] isolate_parameter_list;

      VAR
        parameter_list_index: clt$string_index;


      parameters_parse := parse;
      parameter_list_given := parse.unit.kind = clc$lex_left_parenthesis;

      IF parameter_list_given THEN
        parameter_list_index := parse.index;
        clp$scan_bal_paren_lexical_unit (parse);
        IF parse.unit_index >= parse.index_limit THEN
          osp$set_status_abnormal ('CL', cle$expecting_rparen_of_plist, name, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT clp$evaluate_function;
        IFEND;
        parameters_parse.index_limit := parse.unit_index;
        clp$scan_non_space_lexical_unit (parameters_parse);
        clp$scan_any_lexical_unit (parse);
      ELSE
        parameters_parse.index_limit := parse.unit_index;
      IFEND;

    PROCEND isolate_parameter_list;
?? TITLE := 'invoke_contemporary_function', EJECT ??

    PROCEDURE [INLINE] invoke_contemporary_function
      (    loaded_function: clt$function_processor);

      VAR
        parameter_list: clt$i_parameter_list_contents;


      IF evaluate_for_write THEN
        osp$set_status_abnormal ('CL', cle$function_is_read_only, name, status);

      ELSE
        IF function_block = NIL THEN
          clp$push_function_block (caller_id.ring, name, source, parameters_parse, context_type_description,
                function_block);
        IFEND;

*IF NOT $true(osv$unix)
        callers_save_area := #PREVIOUS_SAVE_AREA ();
*ELSE
        callers_save_area := NIL;
*IFEND
        invoking_function := TRUE;
        #SPOIL (callers_save_area, invoking_function);

        parameter_list.identifying_size_field := UPPERVALUE (parameter_list.identifying_size_field);

        loaded_function^ (#SEQ (parameter_list) ^, work_area, result.value, status);

        invoking_function := FALSE;
        #SPOIL (invoking_function);

        IF status.normal AND (result.value = NIL) THEN
          osp$set_status_abnormal ('CL', cle$no_function_result, name, status);
        IFEND;
      IFEND;

    PROCEND invoke_contemporary_function;
?? TITLE := 'invoke_original_function', EJECT ??

    PROCEDURE [INLINE] invoke_original_function
      (    loaded_function: clt$function);

      VAR
        clt_name: clt$name,
        value: clt$value;


      IF evaluate_for_write THEN
        osp$set_status_abnormal ('CL', cle$function_is_read_only, name, status);

      ELSE
        clt_name.value := name;
        clt_name.size := clp$trimmed_string_size (name);

        clp$push_function_block (caller_id.ring, name, source, parameters_parse, context_type_description,
              function_block);

*IF NOT $true(osv$unix)
        callers_save_area := #PREVIOUS_SAVE_AREA ();
*ELSE
        callers_save_area := NIL;
*IFEND
        invoking_function := TRUE;
        #SPOIL (callers_save_area, invoking_function);

        loaded_function^ (clt_name, parameters_parse.text^ (parameters_parse.unit_index,
              parameters_parse.index_limit - parameters_parse.unit_index), value, status);

        invoking_function := FALSE;
        #SPOIL (invoking_function);

        IF status.normal THEN
          clp$convert_clt$value_to_value (value, work_area, result.value, status);
        IFEND;
      IFEND;

    PROCEND invoke_original_function;
?? TITLE := 'invoke_special_function', EJECT ??

    PROCEDURE [INLINE] invoke_special_function
      (    special_function: clt$special_function_processor);

      VAR
        parameter_list: clt$i_parameter_list_contents;


      clp$push_function_block (caller_id.ring, name, source, parameters_parse, context_type_description,
            function_block);

*IF NOT $true(osv$unix)
      callers_save_area := #PREVIOUS_SAVE_AREA ();
*ELSE
      callers_save_area := NIL;
*IFEND
      invoking_function := TRUE;
      #SPOIL (callers_save_area, invoking_function);

      parameter_list.identifying_size_field := UPPERVALUE (parameter_list.identifying_size_field);

      special_function^ (evaluate_for_write, #SEQ (parameter_list) ^, work_area, result, status);

      invoking_function := FALSE;
      #SPOIL (invoking_function);

    PROCEND invoke_special_function;
?? TITLE := 'process_contemporary_function', EJECT ??

    PROCEDURE [INLINE] process_contemporary_function
      (    contemporary_function_entry: clt$function_proc_table_entry);

      VAR
*IF NOT $true(osv$unix)
        contemporary_function: clt$function_processor,
        loaded_address: pmt$loaded_address;
*ELSE
        contemporary_function: clt$function_processor;
*IFEND


      source.function_interface := clc$fi_contemporary;
      source.ordinal := contemporary_function_entry.ordinal;

      CASE contemporary_function_entry.call_method OF

      = clc$linked_call =
        invoke_contemporary_function (contemporary_function_entry.func);

*IF NOT $true(osv$unix)
      = clc$unlinked_call =
        pmp$load (contemporary_function_entry.procedure_name, pmc$procedure_address, loaded_address, status);
        IF status.normal THEN
          #CONVERT_POINTER_TO_PROCEDURE (loaded_address.pointer_to_procedure, contemporary_function);
          invoke_contemporary_function (contemporary_function);
        ELSE
          osp$set_status_abnormal ('CL', cle$unable_to_call_function, name, status);
        IFEND;

      = clc$proc_call, clc$program_call =
        process_utility_lib_function (contemporary_function_entry.procedure_name);
*IFEND

      ELSE
        osp$set_status_abnormal ('CL', cle$unable_to_call_function, name, status);
      CASEND;

    PROCEND process_contemporary_function;
*IF NOT $true(osv$unix)
?? TITLE := 'process_library_function', EJECT ??

    PROCEDURE process_library_function
      (    local_file_name: amt$local_file_name);

      VAR
        context: ^ost$ecp_exception_context,
        file_id: amt$file_identifier,
        library_file: clt$file,
        library_search_info: clt$command_library_search_info,
        nested_commands_can_be_echoed: boolean,
        ring_attributes: amt$ring_attributes;

      context := NIL;

      library_file.local_file_name := local_file_name;

      REPEAT
        clp$search_command_library (name, clc$function, TRUE, work_area, library_file.local_file_name,
              file_id, ring_attributes, nested_commands_can_be_echoed, library_search_info, found, status);
        IF osp$file_access_condition (status) THEN
          IF context = NIL THEN
          PUSH context;
            context^ := osv$initial_exception_context;
            context^.file.selector := osc$ecp_file_reference;
            context^.file.file_reference := ^library_file.local_file_name;
          IFEND;
          context^.condition_status := status;
          osp$enforce_exception_policies (context^);
          status := context^.condition_status;
        IFEND;
      UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

      IF status.normal THEN
        IF found THEN
          IF evaluate_for_write THEN
            osp$set_status_abnormal ('CL', cle$function_is_read_only, name, status);
            RETURN;
          IFEND;

          source.ordinal := library_search_info.ordinal;
          CASE library_search_info.module_kind OF

          = llc$function_procedure =
            invoke_scl_procedure_function (name, context_type_description, source, ring_attributes, file_id,
                  library_file, library_search_info, nested_commands_can_be_echoed, parameters_parse,
                  work_area, result, function_block, status);

          = llc$function_description =
            invoke_described_function (name, context_type_description, source, ring_attributes,
                  parameters_parse, work_area, library_file, library_search_info, result, function_block,
                  status);

          CASEND;
        IFEND;

      IFEND;

    PROCEND process_library_function;
*IFEND
?? TITLE := 'process_original_function', EJECT ??

    PROCEDURE [INLINE] process_original_function
      (    original_function_entry: clt$function_table_entry);

      VAR
*IF NOT $true(osv$unix)
        original_function: clt$function,
        loaded_address: pmt$loaded_address;
*ELSE
        original_function: clt$function;
*IFEND


      source.function_interface := clc$fi_original;
      source.ordinal := original_function_entry.ordinal;

      CASE original_function_entry.call_method OF

      = clc$linked_call =
        invoke_original_function (original_function_entry.func);

*IF NOT $true(osv$unix)
      = clc$unlinked_call =
        pmp$load (original_function_entry.procedure_name, pmc$procedure_address, loaded_address, status);
        IF status.normal THEN
          #CONVERT_POINTER_TO_PROCEDURE (loaded_address.pointer_to_procedure, original_function);
          invoke_original_function (original_function);
        ELSE
          osp$set_status_abnormal ('CL', cle$unable_to_call_function, name, status);
        IFEND;

      = clc$proc_call =
        osp$set_status_abnormal ('CL', cle$not_yet_implemented, 'function procedures (', status);
        osp$append_status_parameter (' ', name, status);
        osp$append_status_parameter (' ', ')', status);
*IFEND

      ELSE
        osp$set_status_abnormal ('CL', cle$unable_to_call_function, name, status);
      CASEND;

    PROCEND process_original_function;
?? TITLE := 'process_system_function', EJECT ??

    PROCEDURE [INLINE] process_system_function;

      VAR
        special_function: clt$special_function_processor;


      source.kind := clc$system_commands;
      source.system_command_table := NIL;

*IF NOT $true(osv$unix)
      IF (command_list^.system_command_library_lfn <> osc$null_name) AND
            command_list^.system_library_contains.functions THEN
        process_library_function (osc$null_name);
        IF found THEN
          RETURN;
        IFEND;
      IFEND;
*IFEND

      search_contemporary_functions (clv$system_functions);
      IF found THEN
*IF NOT $true(osv$unix)
        IF name = '$PARAMETER_VALUE' THEN
          special_function := ^clp$$parameter_value;
        ELSEIF name = '$VALUE' THEN
          special_function := ^clp$$value;
        ELSEIF name = '$VNAME' THEN
          special_function := ^clp$$vname;
        ELSE
          special_function := NIL;
        IFEND;
        IF special_function <> NIL THEN

          source.function_interface := clc$fi_contemporary;
          source.ordinal := clv$system_functions^ [index].ordinal;
          invoke_special_function (special_function);

        ELSE

*IFEND
          process_contemporary_function (clv$system_functions^ [index]);
*IF NOT $true(osv$unix)

        IFEND;
*IFEND
      ELSE
        search_original_functions (clv$system_functions_v0);
        IF found THEN

          process_original_function (clv$system_functions_v0^ [index]);

        IFEND;
      IFEND;

    PROCEND process_system_function;
*IF NOT $true(osv$unix)
?? TITLE := 'process_utility_aux_function', EJECT ??

    PROCEDURE process_utility_aux_function;

      VAR
        index: integer;


      FOR index := 1 TO UPPERBOUND (source.utility_info^.auxiliary_libraries^) DO
        IF source.utility_info^.auxiliary_libraries^ [index].contains.functions THEN
          source.kind := clc$library_commands;
          source.local_file_name := source.utility_info^.auxiliary_libraries^ [index].name;
          process_library_function (source.utility_info^.auxiliary_libraries^ [index].name);
          IF NOT status.normal THEN
            status.normal := TRUE;
          ELSEIF found THEN
            RETURN;
          IFEND;
        IFEND;
      FOREND;

    PROCEND process_utility_aux_function;
*IFEND
?? TITLE := 'process_utility_function', EJECT ??

    PROCEDURE process_utility_function;


      source.kind := clc$sub_commands;
      source.utility_name := current_entry^.utility_name;
      source.utility_info := current_entry^.utility_info;
      source.utility_termination_command := FALSE;
      source.auxilliary_table := FALSE;

      search_contemporary_functions (current_entry^.utility_info^.contemporary_functions);

      IF found THEN
        IF NOT current_entry^.utility_info^.command_level THEN
          get_task_id;
          IF current_entry^.utility_info^.task_id <> current_task_id THEN
            osp$set_status_abnormal ('CL', cle$util_cmds_fctns_unavailable, name, status);
          IFEND;
        IFEND;

        IF status.normal THEN
          process_contemporary_function (current_entry^.utility_info^.contemporary_functions^ [index]);
        IFEND;

      ELSE
        search_original_functions (current_entry^.utility_info^.original_functions);

        IF found THEN
          IF NOT current_entry^.utility_info^.command_level THEN
            get_task_id;
            IF current_entry^.utility_info^.task_id <> current_task_id THEN
              osp$set_status_abnormal ('CL', cle$util_cmds_fctns_unavailable, name, status);
            IFEND;
          IFEND;

          IF status.normal THEN
            process_original_function (current_entry^.utility_info^.original_functions^ [index]);
          IFEND;

        ELSE
          search_contemporary_functions (current_entry^.utility_info^.dialog_info.functions);

          IF found THEN
            IF NOT current_entry^.utility_info^.command_level THEN
              get_task_id;
              IF current_entry^.utility_info^.task_id <> current_task_id THEN
                osp$set_status_abnormal ('CL', cle$util_cmds_fctns_unavailable, name, status);
              IFEND;
            IFEND;

            IF status.normal THEN
              source.auxilliary_table := TRUE;
              process_contemporary_function (current_entry^.utility_info^.dialog_info.functions^ [index]);
            IFEND;

*IF NOT $true(osv$unix)
          ELSEIF source.utility_info^.auxiliary_libraries <> NIL THEN
            process_utility_aux_function;
*IFEND
          IFEND;
        IFEND;
      IFEND;

    PROCEND process_utility_function;
*IF NOT $true(osv$unix)
?? TITLE := 'process_utility_lib_function', EJECT ??

    PROCEDURE process_utility_lib_function
      (    procedure_name: pmt$program_name);

      VAR
        context: ^ost$ecp_exception_context,
        file_id: amt$file_identifier,
        found_function: boolean,
        index: integer,
        library_file: clt$file,
        library_search_info: clt$command_library_search_info,
        nested_commands_can_be_echoed: boolean,
        ring_attributes: amt$ring_attributes;

      context := NIL;

    /search/
      BEGIN
        IF source.utility_info^.libraries <> NIL THEN
          FOR index := 1 TO UPPERBOUND (source.utility_info^.libraries^) DO
            library_file.local_file_name := source.utility_info^.libraries^ [index];

            REPEAT
              clp$search_command_library (procedure_name, clc$function, FALSE, work_area,
                    library_file.local_file_name, file_id, ring_attributes, nested_commands_can_be_echoed,
                    library_search_info, found_function, status);
              IF osp$file_access_condition (status) THEN
                IF context = NIL THEN
                  PUSH context;
                  context^ := osv$initial_exception_context;
                  context^.file.selector := osc$ecp_file_reference;
                  context^.file.file_reference := ^library_file.local_file_name;
                IFEND;
                context^.condition_status := status;
                osp$enforce_exception_policies (context^);
                status := context^.condition_status;
              IFEND;
            UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
            IF NOT status.normal THEN
              EXIT clp$evaluate_function;
            ELSEIF found_function THEN
              EXIT /search/;
            IFEND;
          FOREND;

          osp$set_status_abnormal ('CL', cle$unable_to_call_function, name, status);
          EXIT clp$evaluate_function;

        ELSE
          clp$find_cmnd_or_func_in_prog (procedure_name, clc$function, work_area,
                library_file.local_file_name, ring_attributes, library_search_info, status);
          IF NOT status.normal THEN
            osp$set_status_abnormal ('CL', cle$unable_to_call_function, name, status);
            EXIT clp$evaluate_function;
          IFEND;
          file_id := amv$nil_file_identifier;
          nested_commands_can_be_echoed := FALSE;
        IFEND;
      END /search/;

      IF evaluate_for_write THEN
        osp$set_status_abnormal ('CL', cle$function_is_read_only, name, status);
        EXIT clp$evaluate_function;
      IFEND;

      CASE library_search_info.module_kind OF

      = llc$function_procedure =
        invoke_scl_procedure_function (name, context_type_description, source, ring_attributes, file_id,
              library_file, library_search_info, nested_commands_can_be_echoed, parameters_parse, work_area,
              result, function_block, status);

      = llc$function_description =
        invoke_described_function (name, context_type_description, source, ring_attributes, parameters_parse,
              work_area, library_file, library_search_info, result, function_block, status);

      ELSE
        osp$set_status_abnormal ('CL', cle$unable_to_call_function, name, status);
        EXIT clp$evaluate_function;
      CASEND;

    PROCEND process_utility_lib_function;
*IFEND
?? TITLE := 'search_contemporary_functions', EJECT ??

    PROCEDURE [INLINE] search_contemporary_functions
      (    function_processor_table: ^clt$function_processor_table);

      VAR
        low_index: 1 .. max_functions + 1,
        temp: integer,
        high_index: 0 .. max_functions;


      IF function_processor_table <> NIL THEN
        low_index := 1;
        high_index := UPPERBOUND (function_processor_table^);
        REPEAT
          temp  := low_index + high_index;
          index := temp DIV 2;
          IF name = function_processor_table^ [index].name THEN
            found := TRUE;
          ELSEIF name > function_processor_table^ [index].name THEN
            low_index := index + 1;
          ELSE
            high_index := index - 1;
          IFEND;
        UNTIL found OR (low_index > high_index);
      IFEND;

    PROCEND search_contemporary_functions;
?? TITLE := 'search_original_functions', EJECT ??

    PROCEDURE [INLINE] search_original_functions
      (    function_table: ^clt$function_table);

      VAR
        low_index: 1 .. max_functions + 1,
        temp: integer,
        high_index: 0 .. max_functions;


      IF function_table <> NIL THEN
        low_index := 1;
        high_index := UPPERBOUND (function_table^);
        REPEAT
          temp := low_index + high_index;
          index := temp DIV 2;
          IF name = function_table^ [index].name THEN
            found := TRUE;
          ELSEIF name > function_table^ [index].name THEN
            low_index := index + 1;
          ELSE
            high_index := index - 1;
          IFEND;
        UNTIL found OR (low_index > high_index);
      IFEND;

    PROCEND search_original_functions;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    found := FALSE;
    result.kind := clc$fr_value;
    result.value := NIL;

*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
*ELSE
    caller_id.ring := osc$user_ring;
*IFEND

    search_status := NIL;

    isolate_parameter_list;

    clp$find_current_block (block_at_start_of_function);

    function_block := NIL;
    invoking_function := FALSE;
    #SPOIL (invoking_function, function_block);
*IF $true(osv$unix)
    handler_established := #establish_condition_handler (-1, ^function_condition_handler);
*ELSE
    osp$establish_condition_handler (^function_condition_handler, TRUE);
*IFEND

  /process_function/
    BEGIN
      source.index := 1;
      source.size := 0;
      source.reference_index := 1;
      source.reference_size := 0;

      got_task_id := FALSE;
      system_functions_searched := FALSE;

      clp$find_command_list (command_list, ignore_cmnd_list_found_in_task);
*IF NOT $true(osv$unix)
      IF block_at_start_of_function^.use_command_search_mode THEN
        search_mode := command_list^.search_mode;
      ELSE
        search_mode := clc$global_command_search;
      IFEND;

      IF search_mode = clc$exclusive_command_search THEN
        entry_after_fence := command_list^.entries.entry_after_fence;
      ELSE
        entry_after_fence := NIL;
      IFEND;
*ELSE
      search_mode := clc$global_command_search;
      entry_after_fence := NIL;
*IFEND

      current_entry := command_list^.entries.first_entry;

    /search_list/
      WHILE current_entry <> entry_after_fence DO
        CASE current_entry^.kind OF

*IF NOT $true(osv$unix)
        = clc$library_commands =
          IF current_entry^.library_contains.functions THEN
            source.kind := clc$library_commands;
            source.local_file_name := current_entry^.local_file_name;
            process_library_function (current_entry^.local_file_name);
          IFEND;

*IFEND
        = clc$system_commands =
          process_system_function;
          system_functions_searched := TRUE;

        = clc$sub_commands =
          process_utility_function;
          IF (NOT status.normal) AND (status.condition = cle$util_cmds_fctns_unavailable) THEN
            IF search_status = NIL THEN
              PUSH search_status;
              search_status^ := status;
            IFEND;
            status.normal := TRUE;
            found := FALSE;
          IFEND;

        ELSE
          ;
        CASEND;

        IF (NOT status.normal) OR found THEN
          EXIT /process_function/;
        IFEND;

        current_entry := current_entry^.next_entry;
      WHILEND /search_list/;

      IF NOT system_functions_searched THEN
        process_system_function;
        IF (NOT status.normal) OR found THEN
          EXIT /process_function/;
        IFEND;
      IFEND;

*IF NOT $true(osv$unix)
      ?IF fsc$compiling_for_test_harness AND clc$compiling_for_test_harness THEN
        process_original_function (fsv$test_harness_fnctns);
        IF (NOT status.normal) OR found THEN
          EXIT /process_function/;
        IFEND;
      ?IFEND
*IFEND
    END /process_function/;

    IF function_block <> NIL THEN
      clp$pop_terminated_blocks (block_at_start_of_function, status);
      function_block := NIL;
      #SPOIL (function_block);
    IFEND;

*IF $true(osv$unix)
    IF handler_established THEN
      handler_established := NOT #disestablish_condition_handler (-1);
    IFEND;
*ELSE
    osp$disestablish_cond_handler;
*IFEND

    IF (NOT status.normal) OR found THEN
      RETURN;
    IFEND;

    IF search_status <> NIL THEN
      status := search_status^;
    ELSEIF parameter_list_given THEN
      osp$set_status_abnormal ('CL', cle$unknown_function, name, status);
    IFEND;

  PROCEND clp$evaluate_function;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$get_expected_type', EJECT ??
*copyc clh$get_expected_type

  PROCEDURE [XDCL, #GATE] clp$get_expected_type
    (VAR work_area {input, output} : ^clt$work_area;
     VAR expected_type: ^clt$type_specification;
     VAR status: ost$status);

    VAR
      block: ^clt$block;


    status.normal := TRUE;

  /get_expected_type/
    BEGIN
      clp$find_current_block (block);
      IF (block^.kind = clc$input_block) AND block^.input.prompting_input THEN
        block := block^.previous_block;
      IFEND;
      IF block^.kind <> clc$function_block THEN
        osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$get_expected_type', status);
        EXIT /get_expected_type/;
      IFEND;

      IF block^.expected_function_type = NIL THEN
        expected_type := NIL;
      ELSE
        clp$convert_type_desc_to_spec (block^.expected_function_type, work_area, expected_type, status);
        IF (NOT status.normal) AND (status.condition = cle$work_area_overflow) THEN
          status.text.size := 0;
          osp$append_status_parameter (osc$status_parameter_delimiter, 'clp$get_expected_type', status);
        IFEND;
      IFEND;

{ Inform the expression evaluator that a function processor cared about the
{ current type specification so that the function will be reevaluated if necessary.

      pmp$push_task_debug_mode (pmc$debug_mode_off, status);
      IF NOT status.normal THEN
        EXIT /get_expected_type/;
      IFEND;
      pmp$cause_condition (clc$reset_dereference_name, NIL, {ignore} status);
      pmp$pop_task_debug_mode ( {ignore} status);
      status.normal := TRUE;
    END /get_expected_type/;

  PROCEND clp$get_expected_type;
?? TITLE := 'clp$$parameter_value', EJECT ??

  PROCEDURE clp$$parameter_value
    (    evaluate_for_write: boolean;
         parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: clt$function_result;
     VAR status: ost$status);

{ FUNCTION (osm$$parameter_value) $parameter_value (
{   parameter: data_name = $required
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 1] of clt$pdt_parameter_name,
        parameters: array [1 .. 1] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [87, 10, 20, 17, 15, 25, 421], clc$function, 1, 1, 1, 0, 0, 0, 0,
            'OSM$$PARAMETER_VALUE'], [['PARAMETER                      ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$data_name_type]]];

?? POP ??

    CONST
      p$parameter = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    result.kind := clc$fr_parameter_name;
    result.parameter_name := pvt [p$parameter].value^.data_name_value;

  PROCEND clp$$parameter_value;
?? TITLE := 'clp$$value', EJECT ??

  PROCEDURE clp$$value
    (    evaluate_for_write: boolean;
         parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: clt$function_result;
     VAR status: ost$status);

{ FUNCTION (osm$$value) $value (
{   parameter: data_name = $required
{   value_set_number: integer 1..clc$max_value_sets = 1
{   value_number: integer 1..clc$max_values_per_set = 1
{   low_or_high: key
{       low, high
{     keyend = low
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 4] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
          default_value: string (1),
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
          default_value: string (1),
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 2] of clt$keyword_specification,
          default_value: string (3),
        recend,
      recend := [[1, [87, 10, 20, 17, 16, 4, 407], clc$function, 4, 4, 1, 0, 0, 0, 0, 'OSM$$VALUE'],
            [['LOW_OR_HIGH                    ', clc$nominal_entry, 4],
            ['PARAMETER                      ', clc$nominal_entry, 1],
            ['VALUE_NUMBER                   ', clc$nominal_entry, 3],
            ['VALUE_SET_NUMBER               ', clc$nominal_entry, 2]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [4, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_default_parameter, 0,
            1],

{ PARAMETER 3

      [3, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_default_parameter, 0,
            1],

{ PARAMETER 4

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 81, clc$optional_default_parameter, 0,
            3]],

{ PARAMETER 1

      [[1, 0, clc$data_name_type]],

{ PARAMETER 2

      [[1, 0, clc$integer_type], [1, clc$max_value_sets, 10], '1'],

{ PARAMETER 3

      [[1, 0, clc$integer_type], [1, clc$max_values_per_set, 10], '1'],

{ PARAMETER 4

      [[1, 0, clc$keyword_type], [2], [['HIGH                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['LOW                            ', clc$nominal_entry,
            clc$normal_usage_entry, 1]], 'low']];

?? POP ??

    CONST
      p$parameter = 1,
      p$value_set_number = 2,
      p$value_number = 3,
      p$low_or_high = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      access_mode: clt$data_access_mode,
      low_or_high: clt$low_or_high,
      qualifiers_given: boolean;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$low_or_high].value^.keyword_value = 'LOW' THEN
      low_or_high := clc$low;
    ELSE
      low_or_high := clc$high;
    IFEND;
    qualifiers_given := (pvt [p$value_set_number].value^.integer_value.value <> 1) OR
          (pvt [p$value_number].value^.integer_value.value <> 1) OR (low_or_high <> clc$low);

    IF evaluate_for_write THEN
      result.kind := clc$fr_parameter_name;
      result.parameter_name := pvt [p$parameter].value^.data_name_value;
      IF qualifiers_given THEN
        osp$set_status_abnormal ('CL', cle$qual_$value_is_read_only, '', status);
      IFEND;
    ELSE
      result.kind := clc$fr_value;
      clp$get_proc_value (pvt [p$parameter].value^.data_name_value,
            pvt [p$value_set_number].value^.integer_value.value,
            pvt [p$value_number].value^.integer_value.value, low_or_high, work_area, access_mode,
            result.value, status);
      IF status.normal THEN
        IF access_mode = clc$read_write THEN
          result.kind := clc$fr_parameter_name;
          result.parameter_name := pvt [p$parameter].value^.data_name_value;
          IF qualifiers_given THEN
            osp$set_status_abnormal ('CL', cle$qual_$value_is_read_only, '', status);
          IFEND;
        ELSEIF result.value = NIL THEN
          clp$make_unspecified_value (work_area, result.value);
          IF qualifiers_given THEN
            osp$set_status_abnormal ('CL', cle$cannot_read_component, pvt [p$parameter].value^.
                  data_name_value, status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND clp$$value;
?? TITLE := 'clp$$vname', EJECT ??

  PROCEDURE clp$$vname
    (    evaluate_for_write: boolean;
         parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: clt$function_result;
     VAR status: ost$status);

{ FUNCTION (osm$$vname) $vname (
{   variable: string = $required
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 1] of clt$pdt_parameter_name,
        parameters: array [1 .. 1] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend := [[1, [87, 10, 20, 17, 16, 41, 580], clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$VNAME'],
            [['VARIABLE                       ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]];

?? POP ??

    CONST
      p$variable = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    result.kind := clc$fr_variable_reference;
    result.variable := pvt [p$variable].value^.string_value;

  PROCEND clp$$vname;
?? TITLE := 'invoke_described_function', EJECT ??

  PROCEDURE invoke_described_function
    (    name: clt$function_name;
         context_type_description: ^clt$type_description;
         source: clt$command_or_function_source;
         ring_attributes: amt$ring_attributes;
         parameters_parse: clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR library_file {input, output} : clt$file;
     VAR library_search_info {input, output} : clt$command_library_search_info;
     VAR result: clt$function_result;
     VAR function_block: ^clt$block;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      callers_save_area: ^ost$stack_frame_save_area,
      converter: record
        case 0 .. 1 of
        = 0 =
          procedure_pointer: ^procedure
            (    name: clt$function_name;
                 context_type_description: ^clt$type_description;
                 source: clt$command_or_function_source;
                 ring_attributes: amt$ring_attributes;
                 parameters_parse: clt$parse_state;
             VAR work_area {input, output} : ^clt$work_area;
             VAR library_file {input, output} : clt$file;
             VAR library_search_info {input, output} : clt$command_library_search_info;
             VAR result: clt$function_result;
             VAR function_block: ^clt$block;
             VAR status: ost$status),
        = 1 =
          code_base_pointer: ^ost$external_code_base_pointer,
        casend,
      recend,
      function_description_contents: ^llt$function_desc_contents,
      invoking_function: boolean,
      library_path: ^fst$file_reference,
      loaded_address: pmt$loaded_address,
      loaded_function: clt$function_processor,
      parameter_list: clt$i_parameter_list_contents;

?? NEWTITLE := 'described_function_cond_handler', EJECT ??

{
{ PURPOSE:
{   This condition handler duplicates most of the function_condition_handler
{   within clp$evaluate_function.  It is allows any condition that arise to be
{   processed in the ring in which the function processor runs.
{

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

      VAR
        exit_control_block: ^clt$block,
        ignore_status: ost$status,
        run_time_status: ^ost$status;


      CASE condition.selector OF

      = pmc$block_exit_processing =

{ --- Handle block exit.

        RETURN;

      = mmc$segment_access_condition =

{ --- Handle segment access conditions.

        osp$set_status_from_condition ('CL', condition, save_area, status, ignore_status);
        IF (status.condition = cle$work_area_overflow) AND (status.text.size = 0) THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
        IFEND;
        EXIT invoke_described_function;

      = pmc$system_conditions =
        IF pmc$detected_uncorrected_err IN condition.system_conditions THEN

{ --- Handle hardware detected uncorrected error condition.

          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          osp$set_status_from_condition ('CL', condition, save_area, status, ignore_status);
          EXIT invoke_described_function;

        ELSEIF invoking_function AND (($pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$environment_specification, pmc$invalid_segment_ring_0, pmc$out_call_in_return] *
              condition.system_conditions) <> $pmt$system_conditions []) AND
              (save_area^.minimum_save_area.a2_previous_save_area = callers_save_area) THEN

{ --- Handle system (hardware detected) conditions resulting from attempt to
{     invoke function processor.

          osp$set_status_abnormal ('CL', cle$unable_to_call_function, name, status);
          EXIT invoke_described_function;

        ELSE

{ --- Handle other system (hardware detected) conditions.

          osp$set_status_from_condition ('CL', condition, save_area, status, ignore_status);
          EXIT invoke_described_function;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN

{ --- Handle CYBIL run time error.

          run_time_status := condition_information;
          status := run_time_status^;
          EXIT invoke_described_function;

        ELSEIF (condition.user_condition_name = clc$exiting_condition) AND
              (function_block <> NIL) AND function_block^.being_exited THEN

{ --- Handle exit initiated via command level EXIT statement.
{
{ This condition is raised in the task that "owns" the SCL block which is the
{ target of the EXIT statement.
{ This condition is specifically dealt with in the condition handlers that
{ cover processing of the various kinds of input, command and function blocks.
{ The condition_information for this condition is a pointer to the outermost
{ block which is being exited and has such a corresponding condition handler.
{ The handler which is "covering" this "exit_control_block" performs a
{ non-local (CYBIL) exit out of its establishing procedure.
{ Other such handlers simply "continue" the condition.

          exit_control_block := condition_information;
          IF #OFFSET (exit_control_block) <> #OFFSET (function_block) THEN
            pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          IFEND;
          EXIT invoke_described_function;

        ELSE

{ --- "Continue" any other user defined condition.

          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          RETURN;
        IFEND;

      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        RETURN;
      CASEND;

    PROCEND described_function_cond_handler;
?? TITLE := 'my_parameter_list', EJECT ??

*IF NOT $true(osv$unix)

    FUNCTION my_parameter_list: ^cell;

      VAR
        psa: ^ost$stack_frame_save_area;


      psa := #PREVIOUS_SAVE_AREA ();
      my_parameter_list := psa^.a4;

    FUNCEND my_parameter_list;
*IFEND
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

*IF NOT $true(osv$unix)
    IF ring_attributes.r2 < #RING (^converter) THEN

{ This routine must call itself at the target ring in order to process the procedure at that ring.

      converter.procedure_pointer := ^invoke_described_function;
      pmp$inward_call (converter.code_base_pointer, ring_attributes.r2, my_parameter_list (),
            #PREVIOUS_SAVE_AREA ());

{ The above call to PMP$INWARD_CALL should result in control being returned
{ directly to this procedure's caller.  The following RETURN statement is
{ here just for "safety's sake".

      RETURN;
    IFEND;

    #CALLER_ID (caller_id);

*ELSE
    caller_id.ring := osc$user_ring;
*IFEND

    NEXT function_description_contents IN library_search_info.command_or_function_module;
    IF function_description_contents = NIL THEN
      osp$set_status_abnormal ('CL', cle$unable_to_call_function, name, status);
      RETURN;
    IFEND;

    clp$push_function_block (caller_id.ring, name, source, parameters_parse, context_type_description,
          function_block);

    osp$establish_condition_handler (^described_function_cond_handler, FALSE);

    IF function_description_contents^.library_path_size > 0 THEN
      NEXT library_path: [function_description_contents^.library_path_size] IN
            library_search_info.command_or_function_module;
      IF library_path = NIL THEN
        osp$set_status_abnormal ('CL', cle$unable_to_call_function, name, status);
        RETURN;
      ELSEIF library_path^ <> 'OSF$CURRENT_LIBRARY' THEN
        clp$convert_string_to_file (library_path^, library_file, status);
        IF NOT status.normal THEN
          osp$set_status_abnormal ('CL', cle$unable_to_call_function, name, status);
          RETURN;
        IFEND;
      IFEND;
      IF library_file.local_file_name = osc$null_name THEN
        clp$load_system_entry_point (function_description_contents^.starting_procedure,
              pmc$procedure_address, loaded_address, status);
      ELSE
        clp$load_from_library (function_description_contents^.starting_procedure, pmc$procedure_address,
              library_file.local_file_name, loaded_address, status);
      IFEND;
    ELSE
      pmp$load (function_description_contents^.starting_procedure, pmc$procedure_address, loaded_address,
            status);
    IFEND;

    IF status.normal THEN
      #CONVERT_POINTER_TO_PROCEDURE (loaded_address.pointer_to_procedure, loaded_function);
    IFEND;
    IF (NOT status.normal) OR (loaded_function = NIL) THEN
      osp$set_status_abnormal ('CL', cle$unable_to_call_function, name, status);
      RETURN;
    IFEND;

*IF NOT $true(osv$unix)
    callers_save_area := #PREVIOUS_SAVE_AREA ();
*ELSE
    callers_save_area := NIL;
*IFEND
    invoking_function := TRUE;
    #SPOIL (callers_save_area, invoking_function);

    parameter_list.identifying_size_field := UPPERVALUE (parameter_list.identifying_size_field);

    loaded_function^ (#SEQ (parameter_list) ^, work_area, result.value, status);
    invoking_function := FALSE;
    #SPOIL (invoking_function);

    IF status.normal AND (result.value = NIL) THEN
      osp$set_status_abnormal ('CL', cle$no_function_result, name, status);
    IFEND;

  PROCEND invoke_described_function;
?? TITLE := 'invoke_scl_procedure_function', EJECT ??

  PROCEDURE invoke_scl_procedure_function
    (    name: clt$function_name;
         context_type_description: ^clt$type_description;
         source: clt$command_or_function_source;
         ring_attributes: amt$ring_attributes;
         file_id: amt$file_identifier;
         library_file: clt$file;
         library_search_info: clt$command_library_search_info;
         nested_commands_can_be_echoed: boolean;
     VAR parameters_parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: clt$function_result;
     VAR function_block: ^clt$block;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      connected_files: ^clt$connected_files,
      context_type_specification: ^clt$type_specification,
      converter: record
        case 0 .. 1 of
        = 0 =
          procedure_pointer: ^procedure
            (    name: clt$function_name;
                 context_type_description: ^clt$type_description;
                 source: clt$command_or_function_source;
                 ring_attributes: amt$ring_attributes;
                 file_id: amt$file_identifier;
                 library_file: clt$file;
                 library_search_info: clt$command_library_search_info;
                 nested_commands_can_be_echoed: boolean;
             VAR parameters_parse {input, output} : clt$parse_state;
             VAR work_area {input, output} : ^clt$work_area;
             VAR result: clt$function_result;
             VAR function_block: ^clt$block;
             VAR status: ost$status),
        = 1 =
          code_base_pointer: ^ost$external_code_base_pointer,
        casend,
      recend,
      end_proc_block: ^clt$block,
      header: ^clt$scl_procedure_header,
      interpreter_mode: clt$interpreter_modes,
      local_status: ost$status,
      parameters_work_area: ^^clt$work_area,
      proc_data: ^clt$scl_procedure;

?? NEWTITLE := 'function_procedure_cond_handler', EJECT ??

{
{ PURPOSE:
{   This condition handler duplicates most of the function_condition_handler
{   within clp$evaluate_function.  It is allows any condition that arises to be
{   processed in the ring in which the function processor runs.
{

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

      VAR
        exit_control_block: ^clt$block,
        ignore_status: ost$status,
        run_time_status: ^ost$status;


      CASE condition.selector OF

      = pmc$block_exit_processing =

{ --- Handle block exit.

        IF function_block <> NIL THEN
          clp$pop_terminated_blocks (function_block, status);
          handle_exit_from_procedure;
        IFEND;
        RETURN;

      = mmc$segment_access_condition =

{ --- Handle segment access conditions.

        osp$set_status_from_condition ('CL', condition, save_area, status, ignore_status);
        IF (status.condition = cle$work_area_overflow) AND (status.text.size = 0) THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
        IFEND;
        EXIT invoke_scl_procedure_function;

      = pmc$system_conditions =

{ --- Handle system (hardware detected) conditions.

        IF pmc$detected_uncorrected_err IN condition.system_conditions THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        IFEND;
        osp$set_status_from_condition ('CL', condition, save_area, status, ignore_status);
        EXIT invoke_scl_procedure_function;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN

{ --- Handle CYBIL run time error.

          run_time_status := condition_information;
          status := run_time_status^;
          EXIT invoke_scl_procedure_function;

        ELSEIF (condition.user_condition_name = clc$exiting_condition) AND
              (function_block <> NIL) AND function_block^.being_exited THEN

{ --- Handle exit initiated via command level EXIT statement.
{
{ This condition is raised in the task that "owns" the SCL block which is the
{ target of the EXIT statement.
{ This condition is specifically dealt with in the condition handlers that
{ cover processing of the various kinds of input, command and function blocks.
{ The condition_information for this condition is a pointer to the outermost
{ block which is being exited and has such a corresponding condition handler.
{ The handler which is "covering" this "exit_control_block" performs a
{ non-local (CYBIL) exit out of its establishing procedure.
{ Other such handlers simply "continue" the condition.

          exit_control_block := condition_information;
          IF #OFFSET (exit_control_block) <> #OFFSET (function_block) THEN
            pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          IFEND;
          EXIT invoke_scl_procedure_function;

        ELSE

{ --- "Continue" any other user defined condition.

          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          RETURN;
        IFEND;

      ELSE

{ --- "Continue" any other condition.

        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        RETURN;
      CASEND;

    PROCEND function_procedure_cond_handler;
?? TITLE := 'handle_exit_from_procedure', EJECT ??

    PROCEDURE [INLINE] handle_exit_from_procedure;


      clp$process_exit_condition (function_block, status);

      IF function_block^.input_can_be_echoed THEN
        clp$find_connected_files (connected_files);
        IF connected_files^.echo_count > 0 THEN
          clp$echo_trace_information ('CLC$ECHO_FUNCTION_PROC_END', ^name,
                ^library_file.local_file_name, ^status, {ignore} local_status);
        IFEND;
      IFEND;

    PROCEND handle_exit_from_procedure;
?? TITLE := 'my_parameter_list', EJECT ??
*IF NOT $true(osv$unix)


    FUNCTION my_parameter_list: ^cell;

      VAR
        psa: ^ost$stack_frame_save_area;


      psa := #PREVIOUS_SAVE_AREA ();
      my_parameter_list := psa^.a4;

    FUNCEND my_parameter_list;
*IFEND
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

*IF NOT $true(osv$unix)
    IF ring_attributes.r2 < #RING (^converter) THEN

{ This routine must call itself at the target ring in order to process the procedure at that ring.

      converter.procedure_pointer := ^invoke_scl_procedure_function;
      pmp$inward_call (converter.code_base_pointer, ring_attributes.r2, my_parameter_list (),
            #PREVIOUS_SAVE_AREA ());

{ The above call to PMP$INWARD_CALL should result in control being returned
{ directly to this procedure's caller.  The following RETURN statement is
{ here just for "safety's sake".

      RETURN;
    IFEND;

    #CALLER_ID (caller_id);

*ELSE
    caller_id.ring := osc$user_ring;
*IFEND

    IF context_type_description = NIL THEN
      context_type_specification := NIL;
    ELSE
      clp$convert_type_desc_to_spec (context_type_description, work_area, context_type_specification,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    proc_data := library_search_info.command_or_function_module;
    IF proc_data = NIL THEN
      header := NIL;
    ELSE
      RESET proc_data;
      NEXT header IN proc_data;
      IF header <> NIL THEN
        proc_data := #PTR (header^.procedure_body, proc_data^);
      IFEND;
      RESET proc_data;
    IFEND;

    clp$get_interpreter_mode (interpreter_mode);

    clp$push_function_proc_block (caller_id.ring, name, source,
          nested_commands_can_be_echoed AND (interpreter_mode <> clc$help_mode),
          library_file.local_file_name, file_id, proc_data, context_type_specification, function_block);

    osp$establish_condition_handler (^function_procedure_cond_handler, TRUE);

    IF function_block^.input_can_be_echoed THEN
      clp$find_connected_files (connected_files);
      IF connected_files^.echo_count > 0 THEN
        clp$echo_trace_information ('CLC$ECHO_FUNCTION_PROC_BEGIN', ^name,
              ^library_file.local_file_name, NIL, {ignore} local_status);
      IFEND;
    IFEND;

    IF status.normal THEN
*IF NOT $true(osv$unix)
      clp$get_work_area (#RING (^parameters_work_area), parameters_work_area, status);
*ELSE
      clp$get_work_area (osc$user_ring, parameters_work_area, status);
*IFEND
      IF status.normal THEN
        clp$process_proc_parameters (clc$function, library_search_info.command_or_function_module, header,
              function_block^.input_can_be_echoed, parameters_parse, parameters_work_area^, status);
      IFEND;
    IFEND;

    IF status.normal THEN
      clp$process_command_file (function_block, NIL, status);

      IF status.normal AND (function_block^.function_proc_result <> NIL) THEN
        clp$convert_int_value_to_ext (function_block^.function_proc_result,
              function_block^.function_proc_result^.header.value, work_area, result.value, status);
      IFEND;
    IFEND;

    IF status.normal AND (NOT function_block^.being_exited) THEN
      clp$find_current_block (end_proc_block);
      IF end_proc_block <> function_block THEN
        osp$set_status_abnormal ('CL', cle$unbalanced_block_structure, function_block^.kind_end_name,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, end_proc_block^.kind_end_name,
              status);
      IFEND;
    IFEND;

    handle_exit_from_procedure;

    osp$disestablish_cond_handler;

    clp$pop_input_stack (end_proc_block, local_status);
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

    IF status.normal AND (result.value = NIL) THEN
      osp$set_status_abnormal ('CL', cle$no_function_result, name, status);
    IFEND;

  PROCEND invoke_scl_procedure_function;
*IFEND

MODEND clm$function_manager;
