?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL PROC Formatter' ??
MODULE clm$format_proc_header;

{
{ PURPOSE:
{   This module contains the routines that format and (optionally) translate
{   an SCL procedure/function header or PDT.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc amt$file_identifier
*copyc amt$page_width
*copyc clc$max_proc_names
*copyc clc$proc_pdt_parameter_limits
*copyc cle$ecc_parsing
*copyc clt$command_line
*copyc clt$command_line_size
*copyc ost$name
*copyc ost$status
?? POP ??
*copyc amp$put_next
*copyc clp$append_status_parse_state
*copyc clp$convert_type_spec_to_desc
*copyc clp$get_statement_to_format
*copyc clp$identify_lexical_units
*copyc clp$initialize_parse_state
*copyc clp$internal_convert_to_string
*copyc clp$internal_generate_old_pdt
*copyc clp$internal_generate_pdt
*copyc clp$internal_gen_type_spec
*copyc clp$scan_non_space_lexical_unit
*copyc clp$translate_pdt
*copyc clp$trimmed_string_size
*copyc clp$unbundle_pdt
*copyc mmp$create_scratch_segment
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper
?? EJECT ??

  VAR
    lexical_work_area_segment: [STATIC] amt$segment_pointer := [amc$sequence_pointer, NIL],
    saved_line_work_area_segment: [STATIC] amt$segment_pointer := [amc$sequence_pointer, NIL],
    symbolic_work_area_segment: [STATIC] amt$segment_pointer := [amc$sequence_pointer, NIL],
    work_area_segment: [STATIC] amt$segment_pointer := [amc$sequence_pointer, NIL];

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

  PROCEDURE [XDCL] clp$format_proc_header
    (    output_file_id: amt$file_identifier;
         page_width: amt$page_width;
         supplied_first_line: ^clt$command_line;
         translate: boolean;
         indent_column: amt$page_width;
     VAR proc_name: ost$name;
     VAR error_count {input, output} : 0 .. amc$file_byte_limit;
     VAR status: ost$status);

    VAR
      command_or_function: clt$command_or_function,
      end_of_input: boolean,
      line_supplied: boolean,
      name: ost$name,
      parse: clt$parse_state,
      representation: ^clt$data_representation,
      representation_put: boolean,
      request: clt$convert_to_string_request,
      saved_line_count: integer,
      saved_line_work_area: ^clt$work_area,
      symbolic_qualifiers_work_area: ^clt$work_area,
      work_area: ^clt$work_area;

?? NEWTITLE := 'format_old_pdt', EJECT ??

    PROCEDURE format_old_pdt
      (    proc_or_pdt: ost$name);

      VAR
        aliases: ^array [1 .. * ] of pmt$program_name,
        extra_info_area: ^SEQ (REP clc$proc_pdt_info_area_size of cell),
        ignore_application_type_present: boolean,
        name_index: clt$parameter_name_index,
        new_pdt: clt$unbundled_pdt,
        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),
        pdt: clt$parameter_descriptor_table,
        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,
        symbolic_qualifier_count: integer,
        symbolic_qualifiers_text_size: integer;

?? NEWTITLE := 'put_old_pdt', EJECT ??

      PROCEDURE [INLINE] put_old_pdt;


        request.initial_indentation := indent_column - 1;
        request.continuation_indentation := 0;
        request.max_string := page_width;
        request.include_advanced_items := TRUE;
        request.include_hidden_items := TRUE;
        request.kind := clc$convert_old_pdt;
        request.multi_line_old_pdt_format := TRUE;
        request.proc_or_pdt := proc_or_pdt;
        request.proc_names := proc_names;
        request.old_pdt := pdt;
        request.symbolic_parameters := symbolic_parameters;

        clp$internal_convert_to_string (request, work_area, representation, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        put_representation;

      PROCEND put_old_pdt;
?? OLDTITLE, EJECT ??

      NEXT proc_name_area IN work_area;
      NEXT parameter_name_area IN work_area;
      NEXT parameter_area IN work_area;
      NEXT symbolic_parameter_area IN work_area;
      NEXT extra_info_area IN work_area;

      clp$internal_generate_old_pdt (proc_or_pdt, ^get_line, work_area, parse, proc_name_area^,
            parameter_name_area^, parameter_area^, symbolic_parameter_area^, extra_info_area^, proc_names,
            pdt, symbolic_parameters, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      proc_name := proc_names^ [1];

      IF translate THEN
        clp$translate_pdt (pdt, FALSE, TRUE, ^report_status, symbolic_parameters,
              symbolic_qualifiers_work_area, work_area, ignore_application_type_present, new_pdt, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF UPPERBOUND (proc_names^) > 1 THEN
          PUSH aliases: [1 .. UPPERBOUND (proc_names^) - 1];
          FOR name_index := 1 TO UPPERBOUND (proc_names^) - 1 DO
            aliases^ [name_index] := proc_names^ [name_index + 1];
          FOREND;
        ELSE
          aliases := NIL;
        IFEND;
        put_pdt (aliases, clc$normal_usage_entry, clc$xdcl_command_or_function, ^new_pdt);
      ELSE
        put_old_pdt;
      IFEND;

    PROCEND format_old_pdt;
?? TITLE := 'format_pdt', EJECT ??

    PROCEDURE format_pdt
      (    command_or_function: clt$command_or_function);

      VAR
        aliases: ^array [1 .. * ] of pmt$program_name,
        availability: clt$named_entry_availability,
        command_log_option: clt$command_log_option,
        command_or_function_scope: clt$command_or_function_scope,
        pdt: ^clt$parameter_description_table,
        unbundled_pdt: clt$unbundled_pdt;


      clp$scan_non_space_lexical_unit (parse);

      clp$internal_generate_pdt (command_or_function, ^get_line, symbolic_qualifiers_work_area, work_area,
            parse, proc_name, aliases, availability, command_or_function_scope, command_log_option, pdt,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      RESET pdt;
      clp$unbundle_pdt (pdt, work_area, unbundled_pdt, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      put_pdt (aliases, availability, command_or_function_scope, ^unbundled_pdt);

    PROCEND format_pdt;
?? TITLE := 'format_type', EJECT ??
{
{ This routine is not complete and probably doesn't belong in this module anyway.
{ Its here just as a sketch of how much of the formatting for TYPE/TYPEND
{ might be done.
{

    PROCEDURE format_type;

      VAR
        end_of_input: boolean,
        type_name: clt$type_name,
        type_description: clt$type_description,
        type_specification: ^clt$type_specification;

?? NEWTITLE := 'put_type', EJECT ??

      PROCEDURE [INLINE] put_type
        (    type_description: ^clt$type_description);


        request.initial_indentation := indent_column - 1;
        request.continuation_indentation := 0;
        request.max_string := page_width;
        request.include_advanced_items := TRUE;
        request.include_hidden_items := TRUE;
        request.kind := clc$convert_type_description;
        request.multi_line_type_format := TRUE;
        request.type_description := type_description;
        request.symbolic_type_qualifiers_area := symbolic_qualifiers_work_area;

        clp$internal_convert_to_string (request, work_area, representation, status);
        IF NOT status.normal THEN
          EXIT format_type;
        IFEND;

        put_representation;

      PROCEND put_type;
?? OLDTITLE, EJECT ??

      clp$scan_non_space_lexical_unit (parse);
      WHILE parse.unit.kind = clc$lex_end_of_line DO
        get_line (parse, end_of_input, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF end_of_input THEN
          osp$set_status_abnormal ('CL', cle$expecting_type_name, 'end of input', status);
          RETURN;
        IFEND;
        clp$scan_non_space_lexical_unit (parse);
      WHILEND;

      IF parse.unit.kind <> clc$lex_name THEN
        osp$set_status_abnormal ('CL', cle$expecting_type_name, '', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        RETURN;
      IFEND;
      #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), type_name);
      clp$scan_non_space_lexical_unit (parse);
      WHILE parse.unit.kind = clc$lex_end_of_line DO
        get_line (parse, end_of_input, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF end_of_input THEN
          osp$set_status_abnormal ('CL', cle$expecting_after_type_name, 'end of input', status);
          RETURN;
        IFEND;
        clp$scan_non_space_lexical_unit (parse);
      WHILEND;

      IF (parse.unit.kind <> clc$lex_colon) AND (parse.unit.kind <> clc$lex_equal) THEN
        osp$set_status_abnormal ('CL', cle$expecting_after_type_name, '', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        RETURN;
      IFEND;

      clp$scan_non_space_lexical_unit (parse);

      clp$internal_gen_type_spec (type_name, FALSE, ^get_line, symbolic_qualifiers_work_area, work_area,
            parse, type_specification, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_type_spec_to_desc (type_specification, work_area, type_description, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      put_type (^type_description);

      IF (parse.unit.kind = clc$lex_space) OR (parse.unit.kind = clc$lex_semicolon) THEN
        clp$scan_non_space_lexical_unit (parse);
      IFEND;
      IF parse.unit.kind = clc$lex_end_of_line THEN
        get_line (parse, end_of_input, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF NOT end_of_input THEN
          clp$scan_non_space_lexical_unit (parse);
        IFEND;
      IFEND;
      IF parse.unit.kind = clc$lex_name THEN
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), type_name);
      ELSE
        type_name := '';
      IFEND;
      IF type_name <> 'TYPEND' THEN
        osp$set_status_abnormal ('CL', cle$expecting_typend, '', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        RETURN;
      IFEND;

    PROCEND format_type;
?? TITLE := 'get_line', EJECT ??

    PROCEDURE get_line
      (VAR parse: clt$parse_state;
       VAR end_of_input: boolean;
       VAR status: ost$status);

      VAR
        got_line: boolean,
        lexical_units: ^clt$lexical_units,
        lexical_work_area: ^clt$work_area,
        line: ^clt$command_line,
        saved_line: ^clt$command_line,
        saved_line_size: ^clt$command_line_size;


      status.normal := TRUE;

      IF line_supplied THEN
        line := supplied_first_line;
        got_line := TRUE;
        line_supplied := FALSE;
      ELSE
        clp$get_statement_to_format (line, got_line, status);
      IFEND;

      end_of_input := NOT got_line;
      IF end_of_input THEN
        RETURN;
      IFEND;

      NEXT saved_line_size IN saved_line_work_area;
      saved_line_size^ := STRLENGTH (line^);
      NEXT saved_line: [saved_line_size^] IN saved_line_work_area;
      saved_line^ := line^;
      saved_line_count := saved_line_count + 1;

      lexical_work_area := lexical_work_area_segment.sequence_pointer;
      clp$identify_lexical_units (line, lexical_work_area, lexical_units, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$initialize_parse_state (line, lexical_units, parse);

    PROCEND get_line;
?? TITLE := 'put_line', EJECT ??

    PROCEDURE [INLINE] put_line
      (    line: string ( * ));

      VAR
        ignore_byte_address: amt$file_byte_address;


      amp$put_next (output_file_id, ^line, STRLENGTH (line), ignore_byte_address, status);
      IF NOT status.normal THEN
        EXIT clp$format_proc_header;
      IFEND;

    PROCEND put_line;
?? TITLE := 'put_pdt', EJECT ??

    PROCEDURE [INLINE] put_pdt
      (    aliases: ^array [1 .. * ] of pmt$program_name;
           availability: clt$named_entry_availability;
           command_or_function_scope: clt$command_or_function_scope;
           pdt: ^clt$unbundled_pdt);


      request.initial_indentation := indent_column - 1;
      request.continuation_indentation := 0;
      request.max_string := page_width;
      request.include_advanced_items := TRUE;
      request.include_hidden_items := TRUE;
      request.kind := clc$convert_unbundled_pdt;
      request.multi_line_pdt_format := TRUE;
      request.parameter_starts_line := TRUE;
      request.individual_parameter := FALSE;
      request.individual_parameter_number := LOWERVALUE (clt$parameter_number);
      request.include_header := TRUE;
      request.command_or_function_name := proc_name;
      request.aliases := aliases;
      request.availability := availability;
      request.command_or_function_scope := command_or_function_scope;
      request.pdt := pdt;
      request.pvt := NIL;
      request.symbolic_pdt_qualifiers_area := symbolic_qualifiers_work_area;
      request.include_implementation_info := TRUE;

      clp$internal_convert_to_string (request, work_area, representation, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      put_representation;

    PROCEND put_pdt;
?? TITLE := 'put_representation', EJECT ??

    PROCEDURE [INLINE] put_representation;

      VAR
        representation_line: ^clt$string_value,
        representation_line_count: ^clt$data_representation_count,
        representation_line_index: clt$data_representation_count,
        representation_line_size: ^clt$string_size;


      RESET representation;
      NEXT representation_line_count IN representation;

      FOR representation_line_index := 1 TO representation_line_count^ DO
        NEXT representation_line_size IN representation;
        NEXT representation_line: [representation_line_size^] IN representation;
        put_line (representation_line^);
      FOREND;

      representation_put := TRUE;

    PROCEND put_representation;
?? TITLE := 'put_saved_lines', EJECT ??

    PROCEDURE put_saved_lines;

      VAR
        saved_line: ^clt$command_line,
        saved_line_size: ^clt$command_line_size,
        saved_status: ost$status;


      saved_status := status;

      RESET saved_line_work_area;

      WHILE saved_line_count > 1 DO
        NEXT saved_line_size IN saved_line_work_area;
        NEXT saved_line: [saved_line_size^] IN saved_line_work_area;
        put_line (saved_line^);
        saved_line_count := saved_line_count - 1;
      WHILEND;

      status := saved_status;

    PROCEND put_saved_lines;
?? TITLE := 'report_status', EJECT ??

    PROCEDURE report_status
      (    parameter_name: ost$name;
           error_status: ost$status;
       VAR status: ost$status);

{ PURPOSE:
{   The purpose of this procedure is to report to the formatter output file any errors
{   detected by clp$translate_pdt.

      VAR
        error_line: string (120),
        size: integer;


      status.normal := TRUE;
      error_count := error_count + 1;

      STRINGREP (error_line, size, ' " Problem with translating PROC parameter - ',
            parameter_name (1, clp$trimmed_string_size (parameter_name)));
      put_line (error_line (1, size));

      STRINGREP (error_line, size, ' --ERROR-- ', error_status.text.value (2, error_status.text.size - 1),
            ' can not be translated.');
      put_line (error_line (1, size));

    PROCEND report_status;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    IF work_area_segment.sequence_pointer = NIL THEN
      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, work_area_segment, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      RESET work_area_segment.sequence_pointer;
    IFEND;
    work_area := work_area_segment.sequence_pointer;

    IF symbolic_work_area_segment.sequence_pointer = NIL THEN
      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, symbolic_work_area_segment,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      RESET symbolic_work_area_segment.sequence_pointer;
    IFEND;
    symbolic_qualifiers_work_area := symbolic_work_area_segment.sequence_pointer;

    IF saved_line_work_area_segment.sequence_pointer = NIL THEN
      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, saved_line_work_area_segment,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      RESET saved_line_work_area_segment.sequence_pointer;
    IFEND;
    saved_line_work_area := saved_line_work_area_segment.sequence_pointer;

    IF lexical_work_area_segment.sequence_pointer = NIL THEN
      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, lexical_work_area_segment, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      RESET lexical_work_area_segment.sequence_pointer;
    IFEND;

    saved_line_count := 0;
    line_supplied := supplied_first_line <> NIL;
    representation_put := FALSE;

  /format_proc_header/
    BEGIN
      get_line (parse, end_of_input, status);
      IF (NOT status.normal) OR end_of_input THEN
        EXIT /format_proc_header/;
      IFEND;
      clp$scan_non_space_lexical_unit (parse);

      IF parse.unit.kind = clc$lex_name THEN
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
        IF (name = 'PROC') OR (name = 'PDT') THEN
          format_old_pdt (name);
        ELSEIF name = 'TYPE' THEN
          format_type;
        ELSE
          IF name = 'PROCEDURE' THEN
            command_or_function := clc$command;
          ELSEIF name = 'FUNCTION' THEN
            command_or_function := clc$function;
          ELSE
            osp$set_status_abnormal ('CL', cle$expecting_proc_func_or_type, name, status);
            EXIT /format_proc_header/;
          IFEND;
          format_pdt (command_or_function);
        IFEND;
      ELSE
        osp$set_status_abnormal ('CL', cle$expecting_proc_func_or_type, '', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        EXIT /format_proc_header/;
      IFEND;
    END /format_proc_header/;

    IF (NOT status.normal) AND (NOT representation_put) THEN
      put_saved_lines;
    IFEND;

  PROCEND clp$format_proc_header;

MODEND clm$format_proc_header;
