?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Define SCL Procedure for Object Library' ??
MODULE clm$define_scl_procedure;

{
{ PURPOSE:
{   This module contains the procedure that prepares an SCL Procedure for
{   addition to or replacement on object library.  It is part of the object
{   library generator utility.
{
{ NOTE:
{   A small amount of "compilation" is performed during this process.  This
{   "compilation" consists of capturing the "generated" form of the procedure's
{   parameter description table (PDT) and saving the lexical information for
{   each line of the procedure.
{   For "old style" PROCs, the PDT is translated prior to capturing it.
{

?? NEWTITLE := 'Global Declarations' ??
?? NEWTITLE := 'clt$scl_procedure and clt$input_data', EJECT ??
*copyc clt$scl_procedure
*copyc clt$scl_procedure_header
*copyc clt$input_data
*copyc clt$input_data_line_header
?? OLDTITLE, EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc clc$max_proc_names
*copyc clc$proc_pdt_parameter_limits
*copyc cle$ecc_control_statement
*copyc cle$expecting_proc
*copyc clt$command_log_option
*copyc clt$command_or_function
*copyc clt$named_entry_availability
*copyc llt$command_kind
*copyc osd$virtual_address
*copyc ost$status
*copyc pmt$program_name
?? POP ??
*copyc clp$append_status_parse_state
*copyc clp$convert_pdt
*copyc clp$get_collect_text_cmnd_info
*copyc clp$get_variable
*copyc clp$get_work_area
*copyc clp$internal_evaluate_sub_param
*copyc clp$internal_generate_old_pdt
*copyc clp$internal_generate_pdt
*copyc clp$parse_command
*copyc clp$pop_parameters
*copyc clp$push_parameters
*copyc clp$scan_any_lexical_unit
*copyc clp$scan_non_space_lexical_unit
*copyc clp$scan_unnested_cmnd_lex_unit
*copyc clp$trimmed_string_size
*copyc i#current_sequence_position
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper
*copyc osv$upper_to_lower

?? TITLE := 'clp$define_scl_procedure', EJECT ??
*copyc clh$define_scl_procedure

  PROCEDURE [XDCL] clp$define_scl_procedure
    (    file_id: amt$file_identifier;
         work_area: ^SEQ ( * );
     VAR procedure_name: pmt$program_name;
     VAR aliases: ^array [1 .. * ] of pmt$program_name;
     VAR command_or_function: clt$command_or_function;
     VAR availability: clt$named_entry_availability;
     VAR command_kind: llt$command_kind;
     VAR command_log_option: clt$command_log_option;
     VAR scl_procedure: ^clt$scl_procedure;
     VAR file_position: amt$file_position;
     VAR status: ost$status);

    CONST
      definition_version_variable = 'OCV$SCL_PROCEDURE_VERSION',
      procedure_file_name = 'file_of_scl_procedures         ';

    VAR
      definition_version: [STATIC] clt$declaration_version := clc$declaration_version,
      definition_version_determined: [STATIC] boolean := FALSE;

    VAR
      command_line_header: ^clt$input_data_line_header,
      end_of_input: boolean,
      entire_procedure: ^clt$input_data,
      header: ^clt$scl_procedure_header,
      header_word: ost$name,
      header_word_size: ost$name_size,
      ignore_status: ^ost$status,
      initial_line_for_echoing: ^clt$command_line,
      last_component_line_header: ^clt$input_data_line_header,
      name: ost$name,
      original_work_area_2: ^clt$work_area,
      parse: clt$parse_state,
      parameter_description_table: ^clt$parameter_description_table,
      pdt: ^clt$parameter_description_table,
      procedure_body: ^clt$input_data,
      procedure_body_size: ost$segment_length,
      procedure_declaration: ^clt$input_data,
      procedure_declaration_size: ost$segment_length,
      saved_procedure_declaration: ^clt$input_data,
      scl_procedure_size: ost$segment_length,
      terminator_name: ost$name,
      work_area_1: ^clt$work_area,
      work_area_2: ^^clt$work_area;

?? NEWTITLE := 'capture_command_line', EJECT ??

    PROCEDURE capture_command_line
      (    line: ^clt$command_line;
           lexical_units: ^clt$lexical_units);

      VAR
        command_line: ^clt$command_line,
        command_lexical_units: ^clt$lexical_units,
        component_lines: ^clt$input_data,
        saved_component_lines: ^clt$input_data,
        size_of_component_lines_data: ost$segment_length;


      IF definition_version = 0 THEN
        RETURN;
      IFEND;

      IF last_component_line_header = command_line_header THEN
        command_line_header^.number_of_lexical_units := UPPERBOUND (lexical_units^);
        NEXT command_lexical_units: [1 .. command_line_header^.number_of_lexical_units] IN work_area_1;
        command_lexical_units^ := lexical_units^;

        command_line_header := NIL;
        RETURN;
      IFEND;

      size_of_component_lines_data := i#current_sequence_position (work_area_1);
      RESET work_area_1 TO command_line_header;
      size_of_component_lines_data := size_of_component_lines_data -
            i#current_sequence_position (work_area_1);
      NEXT component_lines: [[REP size_of_component_lines_data OF cell]] IN work_area_1;
      PUSH saved_component_lines: [[REP size_of_component_lines_data OF cell]];
      saved_component_lines^ := component_lines^;

      RESET work_area_1 TO component_lines;
      NEXT command_line_header IN work_area_1;
      command_line_header^.line_size := STRLENGTH (line^);
      command_line_header^.number_of_lexical_units := UPPERBOUND (lexical_units^);
      command_line_header^.size_of_component_lines_data := size_of_component_lines_data;
      NEXT command_line: [command_line_header^.line_size] IN work_area_1;
      command_line^ := line^;
      NEXT command_lexical_units: [1 .. command_line_header^.number_of_lexical_units] IN work_area_1;
      command_lexical_units^ := lexical_units^;
      NEXT component_lines: [[REP size_of_component_lines_data OF cell]] IN work_area_1;
      component_lines^ := saved_component_lines^;

      command_line_header := NIL;

    PROCEND capture_command_line;
?? TITLE := 'capture_data_line', EJECT ??

    PROCEDURE capture_data_line
      (    line: ^clt$command_line);

      VAR
        last_component_line: ^clt$command_line,
        line_size: ^clt$command_line_size;


      IF definition_version = 0 THEN
        NEXT line_size IN work_area_1;
        line_size^ := STRLENGTH (line^);
        NEXT last_component_line: [line_size^] IN work_area_1;
        last_component_line^ := line^;

      ELSE
        NEXT last_component_line_header IN work_area_1;
        last_component_line_header^.line_size := STRLENGTH (line^);
        last_component_line_header^.number_of_lexical_units := 0;
        last_component_line_header^.size_of_component_lines_data := 0;
        NEXT last_component_line: [last_component_line_header^.line_size] IN work_area_1;
        last_component_line^ := line^;

        IF command_line_header = NIL THEN
          command_line_header := last_component_line_header;
        IFEND;
      IFEND;

    PROCEND capture_data_line;
?? TITLE := 'define_old_proc_header', EJECT ??

    PROCEDURE define_old_proc_header;

      VAR
        alias_index: 1 .. clc$max_proc_names - 1,
        extra_info_area: ^SEQ (REP clc$proc_pdt_info_area_size of cell),
        old_pdt: clt$parameter_descriptor_table,
        parameter_area: ^SEQ (REP clc$max_proc_pdt_parameters of clt$parameter_descriptor),
        parameter_name_area: ^SEQ (REP clc$max_proc_pdt_param_names of clt$parameter_name_descriptor),
        proc_name_area: ^SEQ (REP clc$max_proc_names of ost$name),
        proc_names: ^clt$proc_names,
        symbolic_parameter_area: ^SEQ (REP clc$max_proc_pdt_parameters of clt$symbolic_parameter),
        symbolic_parameters: ^clt$symbolic_parameters;


      PUSH proc_name_area;
      PUSH parameter_name_area;
      PUSH parameter_area;
      PUSH symbolic_parameter_area;
      PUSH extra_info_area;

      clp$internal_generate_old_pdt ('PROC', ^clp$input_procedure, work_area_2^, parse, proc_name_area^,
            parameter_name_area^, parameter_area^, symbolic_parameter_area^, extra_info_area^, proc_names,
            old_pdt, symbolic_parameters, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      command_or_function := clc$command;
      availability := clc$advertised_entry;
      command_kind := llc$entry_point;
      command_log_option := clc$automatically_log;

      procedure_name := proc_names^ [1];
      IF UPPERBOUND (proc_names^) > 1 THEN
        NEXT aliases: [1 .. UPPERBOUND (proc_names^) - 1] IN work_area_2^;
        FOR alias_index := 1 TO UPPERBOUND (aliases^) DO
          aliases^ [alias_index] := proc_names^ [alias_index + 1];
        FOREND;
      ELSE
        aliases := NIL;
      IFEND;

      clp$convert_pdt (old_pdt, work_area_2^, pdt, status);

    PROCEND define_old_proc_header;
?? TITLE := 'define_procedure_header', EJECT ??

    PROCEDURE define_procedure_header;

      VAR
        command_or_function_scope: clt$command_or_function_scope;


      clp$scan_non_space_lexical_unit (parse);

      clp$internal_generate_pdt (command_or_function, ^clp$input_procedure, NIL, work_area_2^, parse,
            procedure_name, aliases, availability, command_or_function_scope, command_log_option, pdt,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      CASE command_or_function_scope OF
      = clc$local_command_or_function =
        command_kind := llc$local_to_library;
      = clc$gate_command_or_function =
        command_kind := llc$gate;
      ELSE {clc$xdcl_command_or_function
        command_kind := llc$entry_point;
      CASEND;

    PROCEND define_procedure_header;
?? TITLE := 'determine_definition_version', EJECT ??

    PROCEDURE determine_definition_version;

      VAR
        ignore_access_mode: clt$data_access_mode,
        ignore_class: clt$variable_class,
        ignore_evaluation_method: clt$expression_eval_method,
        ignore_type_specification: ^clt$type_specification,
        value: ^clt$data_value;


      clp$get_variable (definition_version_variable, work_area_2^, ignore_class, ignore_access_mode,
            ignore_evaluation_method, ignore_type_specification, value, status);

      IF NOT status.normal THEN
        status.normal := TRUE;
      ELSEIF (value <> NIL) AND (value^.kind = clc$integer) AND (0 <= value^.integer_value.value) AND
            (value^.integer_value.value <= clc$declaration_version) THEN
        definition_version := value^.integer_value.value;
      IFEND;

    PROCEND determine_definition_version;
?? TITLE := 'read_proc_body', EJECT ??

    PROCEDURE read_proc_body;

      VAR
        collect_text_info: clt$collect_text_command_info,
        collect_text_pvt: ^clt$parameter_value_table,
        command_name: clt$name,
        command_parse: clt$parse_state,
        empty_command: boolean,
        form: clt$command_reference_form,
        ignore_command_ref_parse: clt$parse_state,
        ignore_escaped: boolean,
        ignore_file: clt$file,
        ignore_label: ost$name,
        ignore_prompting_requested: boolean,
        ignore_util_command_list_entry: ^clt$command_list_entry,
        line_size: clt$command_line_size,
        separator: clt$lexical_unit_kind,
        until_string: ^clt$command_line;


      collect_text_pvt := NIL;
      until_string := NIL;

      parse.unit.kind := clc$lex_end_of_line;
      WHILE TRUE DO
        IF parse.unit.kind = clc$lex_end_of_line THEN

          IF until_string <> NIL THEN
            REPEAT
              clp$ip_get_data_line (clv$ip.line^, line_size, end_of_input, status);
              IF NOT status.normal THEN
                RETURN;
              ELSEIF end_of_input THEN
                osp$set_status_abnormal ('CL', cle$unbalanced_block_structure, 'end_of_input', status);
                osp$append_status_parameter (osc$status_parameter_delimiter, until_string^, status);
                RETURN;
              IFEND;
            UNTIL clv$ip.line^ (1, line_size) = until_string^;
            until_string := NIL;
          IFEND;

          clp$input_procedure (parse, end_of_input, status);
          IF (NOT status.normal) OR end_of_input THEN
            RETURN;
          IFEND;
          clp$scan_non_space_lexical_unit (parse);
        IFEND;

        command_parse := parse;
        clp$scan_unnested_cmnd_lex_unit (parse);
        command_parse.index_limit := parse.unit_index;
        IF parse.unit.kind = clc$lex_semicolon THEN
          clp$scan_any_lexical_unit (parse);
        IFEND;

        clp$parse_command (command_parse, ignore_prompting_requested, ignore_escaped, ignore_label,
              ignore_command_ref_parse, ignore_file, form, command_name, ignore_util_command_list_entry,
              separator, empty_command, status);

        IF status.normal AND (NOT empty_command) AND (form = clc$name_only_command_ref) AND
              (separator <> clc$lex_equal) THEN

          IF command_name.value = terminator_name THEN
            CASE separator OF
            = clc$lex_end_of_line =
              RETURN;
            = clc$lex_semicolon   =
              IF parse.unit_is_space THEN
                clp$scan_non_space_lexical_unit (parse);
              IFEND;
              IF parse.unit.kind <> clc$lex_end_of_line THEN
                osp$set_status_abnormal ('CL', cle$unexpected_after_procend, '', status);
                clp$append_status_parse_state ( osc$status_parameter_delimiter, parse, status);
                osp$append_status_parameter (osc$status_parameter_delimiter, terminator_name, status);
              IFEND;
              RETURN;
            = clc$lex_space =
              IF command_parse.unit.kind <> clc$lex_name THEN
                osp$set_status_abnormal ('CL', cle$expecting_label, '', status);
                clp$append_status_parse_state ( osc$status_parameter_delimiter, command_parse, status);
                osp$append_status_parameter (osc$status_parameter_delimiter, terminator_name, status);
                RETURN;
              IFEND;
              #TRANSLATE (osv$lower_to_upper, command_parse.text^
                    (command_parse.unit_index, command_parse.unit.size), name);
              IF name <> procedure_name THEN
                osp$set_status_abnormal ('CL', cle$wrong_statement_label, terminator_name, status);
                RETURN;
              IFEND;
              clp$scan_non_space_lexical_unit (command_parse);
              CASE command_parse.unit.kind OF
              = clc$lex_end_of_line =
                RETURN;
              = clc$lex_semicolon =
                IF parse.unit_is_space THEN
                  clp$scan_non_space_lexical_unit (parse);
                IFEND;
                IF parse.unit.kind <> clc$lex_end_of_line THEN
                  osp$set_status_abnormal ('CL', cle$unexpected_after_end_label, '', status);
                  clp$append_status_parse_state ( osc$status_parameter_delimiter, parse, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, terminator_name, status);
                IFEND;
              ELSE
                osp$set_status_abnormal ('CL', cle$unexpected_after_end_label, '', status);
                clp$append_status_parse_state ( osc$status_parameter_delimiter, command_parse, status);
                osp$append_status_parameter (osc$status_parameter_delimiter, terminator_name, status);
              CASEND;
              RETURN;
            ELSE
              osp$set_status_abnormal ('CL', cle$unexpected_after_procend, '', status);
              clp$append_status_parse_state ( osc$status_parameter_delimiter, command_parse, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, terminator_name, status);
              RETURN;
            CASEND;

          ELSEIF (command_name.value = 'COLLECT_TEXT') OR (command_name.value = 'COLT') THEN
            IF collect_text_pvt = NIL THEN
              clp$get_collect_text_cmnd_info (collect_text_info);
              PUSH collect_text_pvt: [1 .. collect_text_info.number_of_parameters];
            IFEND;
            clp$internal_evaluate_sub_param (command_parse, collect_text_info.pdt, work_area_2^,
                  collect_text_pvt, status);
            IF NOT collect_text_pvt^ [collect_text_info.input_parameter_number].specified THEN
{
{ An input parameter was not specified.
{
              IF collect_text_pvt^ [collect_text_info.until_parameter_number].specified THEN
                IF collect_text_pvt^ [collect_text_info.until_parameter_number].value <> NIL THEN
{
{ An until string was specified and could be evaluated.
{
                  PUSH until_string: [STRLENGTH (collect_text_pvt^ [collect_text_info.until_parameter_number].
                        value^.string_value^)];
                  until_string^ := collect_text_pvt^ [collect_text_info.until_parameter_number].value^.
                        string_value^;
                ELSE
{
{ An until string was specified but could NOT be evaluated.
{ Return with bad status.
{
                  RETURN;
                IFEND;
              ELSE
{
{ An until string was not specified.  The default is assumed.
{
                until_string := collect_text_info.default_until_string;
              IFEND;
            IFEND;
          IFEND;

        IFEND;
      WHILEND;

    PROCEND read_proc_body;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    scl_procedure := NIL;

    work_area_1 := work_area;

    clp$get_work_area (#RING (^work_area_2), work_area_2, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    original_work_area_2 := work_area_2^;

    IF NOT definition_version_determined THEN
      determine_definition_version;
      definition_version_determined := TRUE;
      work_area_2^ := original_work_area_2;
    IFEND;

    clp$ip_initialize (procedure_file_name, file_id, ^file_position, ^capture_command_line,
          ^capture_data_line, work_area_2^, status);

{ Push a sub-parameters block in order to prevent parameter prompting from being
{ activated for functions during the reading of the procedure.
{ Ensure that a corresponding "pop" of the sub-parameters block occurs prior to
{ returning to this routine's caller.

    clp$push_parameters (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /define_scl_procedure/
    BEGIN
      REPEAT
        RESET work_area_1;
        command_line_header := NIL;
        clp$input_procedure (parse, end_of_input, status);
        IF NOT status.normal THEN
          EXIT /define_scl_procedure/;
        ELSEIF end_of_input THEN
          osp$set_status_abnormal ('CL', cle$expecting_proc, 'PROCEDURE / PROC / FUNCTION', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'end of input', status);
          EXIT /define_scl_procedure/;
        IFEND;
        clp$scan_non_space_lexical_unit (parse);
      UNTIL parse.unit.kind <> clc$lex_end_of_line;

      IF parse.unit.kind = clc$lex_name THEN
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
        header_word := name;
        header_word_size := parse.unit.size;
        IF name = 'PROC' THEN
          terminator_name := 'PROCEND';
          define_old_proc_header;
        ELSEIF definition_version = 0 THEN
          osp$set_status_abnormal ('CL', cle$expecting_proc, 'PROC', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
          EXIT /define_scl_procedure/;
        ELSE
          IF name = 'PROCEDURE' THEN
            terminator_name := 'PROCEND';
            command_or_function := clc$command;
          ELSEIF name = 'FUNCTION' THEN
            terminator_name := 'FUNCEND';
            command_or_function := clc$function;
          ELSE
            osp$set_status_abnormal ('CL', cle$expecting_proc, 'PROCEDURE / PROC / FUNCTION', status);
            osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
            EXIT /define_scl_procedure/;
          IFEND;
          define_procedure_header;
        IFEND;
        IF NOT status.normal THEN
          EXIT /define_scl_procedure/;
        IFEND;
      ELSE
        osp$set_status_abnormal ('CL', cle$expecting_proc, 'PROCEDURE / PROC / FUNCTION', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        EXIT /define_scl_procedure/;
      IFEND;

      IF definition_version > 0 THEN
        procedure_declaration_size := i#current_sequence_position (work_area_1);
        RESET work_area_1;
        NEXT procedure_declaration: [[REP procedure_declaration_size OF cell]] IN work_area_1;
        NEXT saved_procedure_declaration: [[REP procedure_declaration_size OF cell]] IN work_area_2^;
        saved_procedure_declaration^ := procedure_declaration^;
        RESET work_area_1;

        NEXT header IN work_area_1;
        header^.identifying_first_byte := UPPERVALUE (header^.identifying_first_byte);
        header^.version := clc$declaration_version;
        header^.command_or_function_name := procedure_name;

        NEXT initial_line_for_echoing: [header_word_size + 1 + clp$trimmed_string_size (procedure_name)] IN
              work_area_1;
        initial_line_for_echoing^ := header_word;
        #TRANSLATE (osv$upper_to_lower, procedure_name, initial_line_for_echoing^ (header_word_size + 2, * ));

        NEXT parameter_description_table: [[REP #SIZE (pdt^) OF cell]] IN work_area_1;
        RESET parameter_description_table;
        parameter_description_table^ := pdt^;

        NEXT procedure_declaration: [[REP procedure_declaration_size OF cell]] IN work_area_1;
        RESET procedure_declaration;
        procedure_declaration^ := saved_procedure_declaration^;
        RESET work_area_2^ TO saved_procedure_declaration;

        procedure_body := work_area_1;
      IFEND;

      read_proc_body;
      IF NOT status.normal THEN
        EXIT /define_scl_procedure/;
      IFEND;

      IF definition_version > 0 THEN
        procedure_body_size := i#current_sequence_position (work_area_1) -
              i#current_sequence_position (procedure_body);
        work_area_1 := procedure_body;
        NEXT procedure_body: [[REP procedure_body_size OF cell]] IN work_area_1;
        RESET procedure_body;

        RESET work_area_1 TO procedure_declaration;
        NEXT entire_procedure: [[REP procedure_declaration_size + procedure_body_size OF cell]] IN
              work_area_1;
        RESET entire_procedure;
      IFEND;

      scl_procedure_size := i#current_sequence_position (work_area_1);
      RESET work_area_1;
      NEXT scl_procedure: [[REP scl_procedure_size OF cell]] IN work_area_1;
      RESET scl_procedure;

      IF definition_version > 0 THEN
        header^.initial_line_for_echoing := #REL (initial_line_for_echoing, scl_procedure^);
        header^.parameter_description_table := #REL (parameter_description_table, scl_procedure^);
        header^.check_parameter_statements := NIL;
        header^.entire_procedure := #REL (entire_procedure, scl_procedure^);
        header^.procedure_declaration := #REL (procedure_declaration, scl_procedure^);
        header^.check_statement := NIL;
        header^.procedure_body := #REL (procedure_body, scl_procedure^);
      IFEND;

      work_area_2^ := original_work_area_2;

    END /define_scl_procedure/;

    IF status.normal THEN
      clp$pop_parameters (status);
    ELSE
      NEXT ignore_status IN work_area_1;
      clp$pop_parameters (ignore_status^);
    IFEND;

  PROCEND clp$define_scl_procedure;
*copyc cli$input_procedures

MODEND clm$define_scl_procedure;
