?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Object Code Management: Create Function Description' ??
MODULE ocm$create_function_description;

{
{ PURPOSE:
{   This module contains the commands that create function descriptions.
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_parsing
*copyc clt$parameter_list
*copyc llt$function_description
*copyc llt$object_library_header
*copyc oce$library_generator_errors
*copyc oct$display_toggles
*copyc ost$status
?? POP ??
*copyc clp$count_list_elements
*copyc clp$evaluate_parameters
*copyc i#current_sequence_position
*copyc ocp$add_an_nlm
*copyc ocp$close_all_open_files
*copyc ocp$create_an_nlm
*copyc ocp$initialize_olg_working_heap
*copyc ocp$search_nlm_tree
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$continue_to_cause
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc pmp$get_date
*copyc pmp$get_time
*copyc ocv$nlm_list
*copyc ocv$olg_scratch_seq
*copyc ocv$olg_working_heap
*copyc ocv$open_file_list
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$_create_function_descriptio', EJECT ??

  PROCEDURE [XDCL] ocp$_create_function_descriptio
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$creol_crefd) create_function_description, crefd (
{   name, names, n: any of
{       data_name
{       record
{         name: data_name
{         aliases: list rest of data_name = $optional
{       recend
{     anyend = $required
{   starting_procedure, sp: (BY_NAME) program_name = $required
{   library, l: (BY_NAME) any of
{       key
{         osf$current_library
{       keyend
{       file
{       string
{     anyend = $optional
{   availability, a: (BY_NAME) key
{       (normal_usage, nu)
{       (advanced_usage, au)
{       (hidden, h)
{     keyend = normal_usage
{   scope, s: (BY_NAME) key
{       (xdcl, x)
{       (gate, g)
{       (local, l)
{     keyend = xdcl
{   merge_option, mo: (BY_NAME) key
{       (add, a)
{       (replace, r)
{       (combine, c)
{     keyend = combine
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 14] of clt$pdt_parameter_name,
      parameters: array [1 .. 7] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$union_type_qualifier,
        type_size_1: clt$type_specification_size,
        element_type_spec_1: record
          header: clt$type_specification_header,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$list_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
            recend,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$union_type_qualifier,
        type_size_1: clt$type_specification_size,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (12),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (4),
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (7),
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 9, 8, 10, 4, 58, 88],
    clc$command, 14, 7, 2, 0, 0, 0, 7, 'OCM$CREOL_CREFD'], [
    ['A                              ',clc$abbreviation_entry, 4],
    ['AVAILABILITY                   ',clc$nominal_entry, 4],
    ['L                              ',clc$abbreviation_entry, 3],
    ['LIBRARY                        ',clc$nominal_entry, 3],
    ['MERGE_OPTION                   ',clc$nominal_entry, 6],
    ['MO                             ',clc$abbreviation_entry, 6],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['NAMES                          ',clc$alias_entry, 1],
    ['S                              ',clc$abbreviation_entry, 5],
    ['SCOPE                          ',clc$nominal_entry, 5],
    ['SP                             ',clc$abbreviation_entry, 2],
    ['STARTING_PROCEDURE             ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 7]],
    [
{ PARAMETER 1
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 124,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 79, clc$optional_parameter,
  0, 0],
{ PARAMETER 4
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_default_parameter, 0, 12],
{ PARAMETER 5
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 6
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 7
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$data_name_type, clc$record_type],
    FALSE, 2],
    3, [[1, 0, clc$data_name_type]],
    101, [[1, 0, clc$record_type], [2],
      ['NAME                           ', clc$required_field, 3], [[1, 0, clc$data_name_type]],
      ['ALIASES                        ', clc$optional_field, 19], [[1, 0, clc$list_type], [3, 0,
  clc$max_list_size, TRUE],
          [[1, 0, clc$data_name_type]]
        ]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$program_name_type]],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type, clc$string_type],
    FALSE, 3],
    44, [[1, 0, clc$keyword_type], [1], [
      ['OSF$CURRENT_LIBRARY            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]],
    8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]
    ],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [6], [
    ['ADVANCED_USAGE                 ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['AU                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['H                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['HIDDEN                         ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['NORMAL_USAGE                   ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['NU                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1]]
    ,
    'normal_usage'],
{ PARAMETER 5
    [[1, 0, clc$keyword_type], [6], [
    ['G                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['GATE                           ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['LOCAL                          ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['X                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['XDCL                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'xdcl'],
{ PARAMETER 6
    [[1, 0, clc$keyword_type], [6], [
    ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ADD                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['COMBINE                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['REPLACE                        ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'combine'],
{ PARAMETER 7
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$starting_procedure = 2,
      p$library = 3,
      p$availability = 4,
      p$scope = 5,
      p$merge_option = 6,
      p$status = 7;

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


    VAR
      alias_list: ^pmt$module_list,
      alias_number: clt$list_size,
      function_description_contents: ^llt$function_desc_contents,
      function_description_header: ^llt$library_member_header,
      date: ost$date,
      ignore_status: ost$status,
      library_parameter: ^clt$string_value,
      library_path: ^fst$file_reference,
      member: ^SEQ ( * ),
      member_size: ost$segment_length,
      module_already_exists: boolean,
      module_description: ^oct$module_description,
      nlm: ^oct$new_library_module_list,
      node: ^clt$data_value,
      sequence: ^SEQ ( * ),
      size: ost$segment_length,
      time: ost$time;

    VAR
      established_conditions: pmt$condition,
      established_descriptor: pmt$established_handler;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to handle the terminate break and
{   block exit conditions.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      IF (condition.selector = ifc$interactive_condition) AND
            (condition.interactive_condition = ifc$terminate_break) THEN

{ Ignore the condition.

        RETURN;
      ELSEIF condition.selector = pmc$block_exit_processing THEN
        ocp$close_all_open_files (ocv$open_file_list);
        ocp$initialize_olg_working_heap;
        RESET ocv$olg_scratch_seq;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??

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

    RESET ocv$olg_scratch_seq;

    pmp$get_time (osc$hms_time, time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    pmp$get_date (osc$mdy_date, date, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    established_conditions.selector := pmc$condition_combination;
    established_conditions.combination := $pmt$condition_combination
          [ifc$interactive_condition, pmc$block_exit_processing];
    pmp$establish_condition_handler (established_conditions, ^condition_handler, ^established_descriptor,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /protect/
    BEGIN

      NEXT function_description_header IN ocv$olg_scratch_seq;
      IF function_description_header = NIL THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      IFEND;

      IF pvt [p$name].value^.kind = clc$data_name THEN
        function_description_header^.name := pvt [p$name].value^.data_name_value;
        node := NIL;
        function_description_header^.number_of_aliases := 0;
      ELSE
        function_description_header^.name := pvt [p$name].value^.field_values^ [1].value^.data_name_value;
        node := pvt [p$name].value^.field_values^ [2].value;
        function_description_header^.number_of_aliases := clp$count_list_elements (node);
      IFEND;
      IF function_description_header^.name (1) <> '$' THEN
        osp$set_status_abnormal ('CL', cle$function_name_needs_$, function_description_header^.name, status);
        EXIT /protect/;
      IFEND;

      function_description_header^.kind := llc$function_description;
      function_description_header^.time_created := time;
      function_description_header^.date_created := date;
      function_description_header^.generator_id := llc$object_library_generator;
      function_description_header^.generator_name_vers := occ$generator_name CAT llc$object_library_version;
      function_description_header^.commentary := osc$null_name;

      IF function_description_header^.number_of_aliases <> 0 THEN
        NEXT alias_list: [1 .. function_description_header^.number_of_aliases] IN ocv$olg_scratch_seq;
        IF alias_list = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;
        FOR alias_number := 1 TO function_description_header^.number_of_aliases DO
          IF node^.element_value^.data_name_value (1) <> '$' THEN
            osp$set_status_abnormal ('CL', cle$function_name_needs_$, node^.element_value^.data_name_value,
                  status);
            EXIT /protect/;
          IFEND;
          alias_list^ [alias_number] := node^.element_value^.data_name_value;
          node := node^.link;
        FOREND;
      IFEND;

      IF pvt [p$availability].value^.keyword_value = 'HIDDEN' THEN
        function_description_header^.command_function_availability := clc$hidden_entry;
      ELSEIF pvt [p$availability].value^.keyword_value = 'ADVANCED_USAGE' THEN
        function_description_header^.command_function_availability := clc$advanced_usage_entry;
      ELSE {NORMAL_USAGE}
        function_description_header^.command_function_availability := clc$normal_usage_entry;
      IFEND;

      IF pvt [p$scope].value^.keyword_value = 'XDCL' THEN
        function_description_header^.command_function_kind := llc$entry_point;
      ELSEIF pvt [p$scope].value^.keyword_value = 'GATE' THEN
        function_description_header^.command_function_kind := llc$gate;
      ELSE {LOCAL}
        function_description_header^.command_function_kind := llc$local_to_library;
      IFEND;

      function_description_header^.command_log_option := clc$automatically_log;

      NEXT function_description_contents IN ocv$olg_scratch_seq;
      IF function_description_contents = NIL THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      IFEND;

      function_description_contents^.version := llc$function_desc_version;
      function_description_contents^.starting_procedure :=
            pvt [p$starting_procedure].value^.program_name_value;

      IF NOT pvt [p$library].specified THEN
        function_description_contents^.library_path_size := 0;
      ELSE
        CASE pvt [p$library].value^.kind OF
        = clc$keyword = {OSF$CURRENT_LIBRARY}
          library_parameter := ^pvt [p$library].value^.keyword_value;
        = clc$file =
          library_parameter := pvt [p$library].value^.file_value;
        ELSE {clc$string}
          library_parameter := pvt [p$library].value^.string_value;
        CASEND;
        IF STRLENGTH (library_parameter^) >= fsc$max_path_size THEN
          function_description_contents^.library_path_size := fsc$max_path_size;
        ELSE
          function_description_contents^.library_path_size := STRLENGTH (library_parameter^);
        IFEND;
        NEXT library_path: [function_description_contents^.library_path_size] IN ocv$olg_scratch_seq;
        IF library_path = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;
        library_path^ := library_parameter^;
      IFEND;

      ALLOCATE module_description IN ocv$olg_working_heap^;
      IF module_description = NIL THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      IFEND;

      module_description^.name := function_description_header^.name;
      module_description^.source := occ$current;
      module_description^.kind := occ$function_description;

      ocp$search_nlm_tree (function_description_header^.name, nlm, module_already_exists);

      IF pvt [p$merge_option].value^.keyword_value = 'ADD' THEN
        IF module_already_exists THEN
          osp$set_status_abnormal ('OC', oce$e_module_already_on_library, function_description_header^.name,
                status);
          EXIT /protect/;
        ELSE
          ocp$create_an_nlm (module_description, nlm, status);
          IF NOT status.normal THEN
            EXIT /protect/;
          IFEND;
          ocp$add_an_nlm (ocv$nlm_list^.b_link, nlm);
        IFEND;

      ELSEIF pvt [p$merge_option].value^.keyword_value = 'REPLACE' THEN
        IF module_already_exists THEN
          nlm^.description := module_description;
          nlm^.changed_info := NIL;
        ELSE
          osp$set_status_abnormal ('OC', oce$e_module_not_found, function_description_header^.name, status);
          EXIT /protect/;
        IFEND;

      ELSE {COMBINE}
        IF module_already_exists THEN
          nlm^.description := module_description;
          nlm^.changed_info := NIL;
        ELSE
          ocp$create_an_nlm (module_description, nlm, status);
          IF NOT status.normal THEN
            EXIT /protect/;
          IFEND;
          ocp$add_an_nlm (ocv$nlm_list^.b_link, nlm);
        IFEND;
      IFEND;

      size := i#current_sequence_position (ocv$olg_scratch_seq);
      RESET ocv$olg_scratch_seq;
      NEXT sequence: [[REP size OF cell]] IN ocv$olg_scratch_seq;
      ALLOCATE module_description^.file: [[REP size OF cell]] IN ocv$olg_working_heap^;
      IF module_description^.file = NIL THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      IFEND;

      module_description^.file^ := sequence^;
      RESET module_description^.file;
      NEXT module_description^.function_description_header IN module_description^.file;
      IF module_description^.function_description_header^.number_of_aliases <> 0 THEN
        NEXT alias_list: [1 .. module_description^.function_description_header^.number_of_aliases] IN
              module_description^.file;
        module_description^.function_description_header^.aliases :=
              #REL (alias_list, module_description^.file^);
      IFEND;

      member_size := size - i#current_sequence_position (module_description^.file);
      NEXT member: [[REP member_size OF cell]] IN module_description^.file;

      module_description^.function_description_header^.member := #REL (member, module_description^.file^);
      module_description^.function_description_header^.member_size := member_size;

    END /protect/;
    pmp$disestablish_cond_handler (established_conditions, ignore_status);

  PROCEND ocp$_create_function_descriptio;

MODEND ocm$create_function_description;
