?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Object Library Generator' ??
MODULE ocm$create_message_module;


{ PURPOSE:
{   To create a message module and replace or combine it on the new object library.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_mt_generator
*copyc llt$object_library_header
*copyc loc$task_services_library_name
*copyc oce$library_generator_errors
*copyc oct$display_toggles
*copyc ost$status
?? POP ??
*copyc clp$define_message_module
*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$generate_message
*copyc ocp$initialize_olg_working_heap
*copyc ocp$search_nlm_tree
*copyc osp$set_status_abnormal
*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 := 'ocp$_create_message_module' ??
?? EJECT ??

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

{ PROCEDURE (ocm$creol_cremm) create_message_module, cremm (
{   name, n: program_name = $required
{   manual, m: program_name = $optional
{   natural_language, nl: any of
{       key
{         us_english, danish, dutch, english, finnish, flemish, french, german,
{         italian, norwegian, portuguese spanish, swedish
{       keyend
{       name
{     anyend = us_english
{   merge_option, mo: 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 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      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 .. 13] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        default_value: string (10),
      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 (7),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 15, 10, 42, 33, 7],
    clc$command, 9, 5, 1, 0, 0, 0, 5, 'OCM$CREOL_CREMM'], [
    ['M                              ',clc$abbreviation_entry, 2],
    ['MANUAL                         ',clc$nominal_entry, 2],
    ['MERGE_OPTION                   ',clc$nominal_entry, 4],
    ['MO                             ',clc$abbreviation_entry, 4],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['NATURAL_LANGUAGE               ',clc$nominal_entry, 3],
    ['NL                             ',clc$abbreviation_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [6, 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, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [2, 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, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [7, 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, 513, clc$optional_default_parameter, 0, 10],
{ PARAMETER 4
    [3, 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, 229, clc$optional_default_parameter, 0, 7],
{ PARAMETER 5
    [9, 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$program_name_type]],
{ PARAMETER 2
    [[1, 0, clc$program_name_type]],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    488, [[1, 0, clc$keyword_type], [13], [
      ['DANISH                         ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['DUTCH                          ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
      ['ENGLISH                        ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
      ['FINNISH                        ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
      ['FLEMISH                        ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
      ['FRENCH                         ', clc$nominal_entry,
  clc$normal_usage_entry, 7],
      ['GERMAN                         ', clc$nominal_entry,
  clc$normal_usage_entry, 8],
      ['ITALIAN                        ', clc$nominal_entry,
  clc$normal_usage_entry, 9],
      ['NORWEGIAN                      ', clc$nominal_entry,
  clc$normal_usage_entry, 10],
      ['PORTUGUESE                     ', clc$nominal_entry,
  clc$normal_usage_entry, 11],
      ['SPANISH                        ', clc$nominal_entry,
  clc$normal_usage_entry, 12],
      ['SWEDISH                        ', clc$nominal_entry,
  clc$normal_usage_entry, 13],
      ['US_ENGLISH                     ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'us_english'],
{ PARAMETER 4
    [[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 5
    [[1, 0, clc$status_type]]];

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

    CONST
      p$name = 1,
      p$manual = 2,
      p$natural_language = 3,
      p$merge_option = 4,
      p$status = 5;

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

?? 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 ??

    VAR

      time: ost$time,
      date: ost$date,
      ignore_status: ost$status,
      module_already_exists: boolean,

      nlm: ^oct$new_library_module_list,
      module_description: ^oct$module_description,

      sequence: ^SEQ ( * ),
      size: ost$segment_length,
      member_size: ost$segment_length,
      member: ^SEQ ( * ),

      module_name: pmt$program_name,
      natural_language: ost$natural_language,
      online_manual_name: ost$online_manual_name,
      work_area: ^SEQ ( * ),
      message_module: ^ost$message_template_module,

      temporary_module_header: llt$library_member_header,
      message_module_header: ^llt$library_member_header;

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

    status.normal := TRUE;
    RESET ocv$olg_scratch_seq;

    established_conditions.selector := pmc$condition_combination;
    established_conditions.combination := $pmt$condition_combination
          [ifc$interactive_condition, pmc$block_exit_processing];


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

    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;

    module_name := pvt [p$name].value^.program_name_value;

    IF pvt [p$natural_language].specified THEN
      IF pvt [p$natural_language].value^.kind = clc$keyword THEN
        natural_language := pvt [p$natural_language].value^.keyword_value;
      ELSE { name
        natural_language := pvt [p$natural_language].value^.name_value;
      IFEND;
    ELSE
      natural_language := osc$default_natural_language;
    IFEND;

    IF pvt [p$manual].specified THEN
      online_manual_name := pvt [p$manual].value^.program_name_value;
    ELSE
      online_manual_name := osc$null_name;
    IFEND;

    pmp$establish_condition_handler (established_conditions, ^condition_handler, ^established_descriptor,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /protect/
    BEGIN
      RESET ocv$olg_scratch_seq;
      NEXT work_area: [[REP (#SIZE (ocv$olg_scratch_seq^)) OF cell]] IN ocv$olg_scratch_seq;

      clp$define_message_module (module_name, natural_language, online_manual_name, work_area, message_module,
            status);

      IF NOT status.normal THEN
        IF status.condition <> cle$errors_in_module THEN
          EXIT /protect/;
        IFEND;
      IFEND;

      IF message_module = NIL THEN
        EXIT /protect/;
      IFEND;

      RESET ocv$olg_scratch_seq;

      NEXT message_module_header IN ocv$olg_scratch_seq;
      IF message_module_header = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_internal_olg_seg_overflow, '', status);
        RETURN;
      IFEND;

      temporary_module_header.name := module_name;
      temporary_module_header.kind := llc$message_module;
      temporary_module_header.time_created := time;
      temporary_module_header.date_created := date;
      temporary_module_header.generator_id := llc$object_library_generator;
      temporary_module_header.generator_name_vers := occ$generator_name CAT llc$object_library_version;
      temporary_module_header.commentary := osc$null_name;
      temporary_module_header.number_of_aliases := 0;

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

      module_description^.name := temporary_module_header.name;
      module_description^.source := occ$current;
      module_description^.kind := occ$message_module;

      ocp$search_nlm_tree (temporary_module_header.name, nlm, module_already_exists);

{ Check for error conditions.

      CASE pvt [p$merge_option].value^.keyword_value (1) OF
      = 'A' =
        IF module_already_exists THEN
          osp$set_status_abnormal ('OC', oce$e_module_already_on_library, temporary_module_header.name,
                status);
          EXIT /protect/;
        IFEND;
      = 'R' =
        IF NOT module_already_exists THEN
          osp$set_status_abnormal ('OC', oce$e_module_not_found, temporary_module_header.name, status);
          EXIT /protect/;
        IFEND;
      ELSE
      CASEND;

{ Replace the module if it exists already; add it if it doesn't.

      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;
      RESET message_module;
      member_size := #SIZE (message_module^);
      NEXT sequence: [[REP member_size OF cell]] IN ocv$olg_scratch_seq;

      size := i#current_sequence_position (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_abnormal ('OC', oce$e_internal_olg_seg_overflow, '', status);
        RETURN;
      IFEND;

      RESET module_description^.file;
      NEXT module_description^.message_module_header IN module_description^.file;
      module_description^.message_module_header^ := temporary_module_header;
      NEXT member: [[REP member_size OF cell]] IN module_description^.file;
      member^ := message_module^;

      module_description^.message_module_header^.member := #REL (member, module_description^.file^);
      module_description^.message_module_header^.member_size := member_size;
    END /protect/;
    pmp$disestablish_cond_handler (established_conditions, ignore_status);


  PROCEND ocp$_create_message_module;

MODEND ocm$create_message_module;
