?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Variable Storage Manager' ??
MODULE clm$variable_storage_manager;

{
{ PURPOSE:
{   This module contains the procedures that create, delete and write command language variables.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_parsing
*copyc cle$ecc_utilities
*IF $true(osv$unix)
*copyc cle$not_supported
*IFEND
*copyc cle$unexpected_call_to
*copyc cle$unknown_variable
*copyc cle$var_already_created
*copyc cle$work_area_overflow
*copyc clk$remove_variable
*copyc clt$access_variable_requests
*copyc clt$environment_variable_scope
*copyc clt$procedure_variable_scope
*copyc clt$variable_access_handle
*copyc clt$variable_declaration_scope
*copyc clt$variable_information
*copyc clt$variable_scope
*copyc oss$task_private
*copyc oss$task_shared
?? POP ??
*IF NOT $true(osv$unix)
*copyc clp$add_variable_to_tree
*copyc clp$check_name_for_boolean
*copyc clp$compute_variable_name_hash
*copyc clp$convert_ext_value_to_int
*copyc clp$convert_int_to_var_value
*copyc clp$convert_int_value_to_ext
*copyc clp$convert_type_spec_to_desc
*copyc clp$create_default_init_value
*copyc clp$create_variable_type
*copyc clp$delete_variable_access
*copyc clp$delete_variable_from_tree
*IFEND
*copyc clp$evaluate_type_conformance
*copyc clp$evaluate_value_conformance
*copyc clp$find_current_block
*IF NOT $true(osv$unix)
*copyc clp$find_first_var_block
*copyc clp$find_next_var_block
*copyc clp$find_variable_access
*IFEND
*copyc clp$read_qualified_data_value
*copyc clp$trimmed_string_size
*copyc clp$validate_name
*IF NOT $true(osv$unix)
*copyc clp$write_qualified_data_value
*copyc osp$clear_job_signature_lock
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$establish_condition_handler
*copyc osp$increment_locked_variable
*copyc osp$set_job_signature_lock
*IFEND
*copyc osp$set_status_abnormal
*IF NOT $true(osv$unix)
*copyc osv$task_private_heap
*IFEND
*copyc osv$task_shared_heap
*IF NOT $true(osv$unix)
*copyc pmp$continue_to_cause
*IFEND
?? EJECT ??

*IF NOT $true(osv$unix)
  VAR
    clv$var_access_assignment_count: [XDCL, oss$task_shared] integer := 0;

  VAR
    clv$retain_unprintable_char: [XDCL, #GATE, oss$task_private] boolean := FALSE;

  VAR
    clv$call_from_colt_command: [XDCL, #GATE, oss$task_private] boolean := FALSE;

  VAR
    clv$first_header_creation: [XDCL, #GATE, oss$task_private] boolean := FALSE;

  VAR
    clv$max_variable_allocation: [XDCL, #GATE, oss$task_shared] ost$segment_length := 4000000(16);

  VAR
    clv$total_variable_allocation: [STATIC, oss$task_shared] ost$segment_length := 0;

  VAR
    clv$variable_access_lock: [STATIC, oss$task_shared] ost$signature_lock := [0];

  TYPE
    conversion_value = record
      case converted: boolean of
      = TRUE =
        max_string_size: ost$string_size,
        converted_value: clt$variable_value,
      casend
    recend;

  TYPE
    utility_name_definition = record
      case defined: boolean of
      = TRUE =
        value: ost$name,
      casend,
    recend;

  TYPE
    clt$deferred_variable_list = record
      name: ost$name,
      link: ^clt$deferred_variable_list,
    recend;

  VAR
    clv$deferred_variable_list: [STATIC, oss$task_private] ^clt$deferred_variable_list := NIL;


?? TITLE := 'check_name', EJECT ??

  PROCEDURE [INLINE] check_name
    (    name: clt$variable_name;
     VAR status: ost$status);

    VAR
      ignore_bool: clt$boolean,
      name_is_boolean: boolean;


    status.normal := TRUE;

    clp$check_name_for_boolean (name, ignore_bool, name_is_boolean);
    IF name_is_boolean THEN
      osp$set_status_abnormal ('CL', cle$special_name_use, name, status);
      RETURN;
    IFEND;
    IF name (1) = '$' THEN
      osp$set_status_abnormal ('CL', cle$improper_use_of_$, name, status);
      RETURN;
    IFEND;

  PROCEND check_name;
?? TITLE := 'clp$access_param_variable', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$access_param_variable
    (    name: clt$parameter_name;
         access_variable_requests: clt$access_variable_requests;
     VAR work_area {input, output} : ^clt$work_area;
     VAR variable_information: clt$variable_information;
     VAR variable_access_handle: clt$variable_access_handle;
     VAR status: ost$status);

    VAR
      access_info: ^clt$variable_access_info,
      block: ^clt$block,
      index: clt$parameter_name_index,
      found: boolean;


    status.normal := TRUE;
    variable_information.access_info_found := FALSE;

    osp$establish_block_exit_hndlr (^variable_abort_handler);
    osp$set_job_signature_lock (clv$variable_access_lock);

    access_info := NIL;
    clp$find_current_block (block);

  /find_block/
    WHILE block <> NIL DO
      CASE block^.kind OF
      = clc$command_proc_block, clc$function_proc_block =
        IF block^.parameters.evaluated THEN
          IF block^.parameters.procedure_parameters THEN
            clp$search_parameter_names (name, block^.parameters.names, index, found);
            IF found THEN
              access_info := ^block^.parameters.accesses^ [block^.parameters.names^ [index].position].info;
            IFEND;
          IFEND;
          EXIT /find_block/;
        IFEND;
      = clc$input_block =
        IF block^.inherited_input.found THEN
          block := block^.inherited_input.block;
          CYCLE /find_block/;
        IFEND;
      ELSE
        ;
      CASEND;

      IF block^.static_link <> NIL THEN
        block := block^.static_link;
      ELSE
        block := block^.previous_block;
      IFEND;

    WHILEND /find_block/;

    IF access_info <> NIL THEN
      variable_information.access_info_found := TRUE;
      copy_variable_information (access_info, access_variable_requests, work_area, variable_information,
            variable_access_handle, status);
    IFEND;

    osp$clear_job_signature_lock (clv$variable_access_lock);
    osp$disestablish_cond_handler;

  PROCEND clp$access_param_variable;
?? TITLE := 'clp$access_variable', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$access_variable
    (    name: clt$variable_name;
         hashed_name: clt$variable_name;
         hash: clt$variable_name_hash;
         lock: boolean;
         access_variable_requests: clt$access_variable_requests;
     VAR work_area {input,output} : ^clt$work_area;
     VAR variable_information: clt$variable_information;
     VAR variable_access_handle: clt$variable_access_handle;
     VAR status: ost$status);

{ LOCK should always be set to TRUE unless the caller to this
{ procedure knows the lock has already been previously set. Currently
{ the only time this occurs is when 'pushing' a variable.

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           ignore_condition_information: ^pmt$condition_information;
           ignore_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      IF lock THEN
        osp$clear_job_signature_lock (clv$variable_access_lock);
      IFEND;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    VAR
      access_info: ^clt$variable_access_info,
      allowed_classes: clt$internal_variable_classes,
      associated_utility : boolean,
      block: ^clt$block,
      inherited_allowed_classes: clt$internal_variable_classes,
      inherited_block: ^clt$block;


    status.normal := TRUE;
    variable_information.access_info_found := FALSE;

    IF lock THEN
      osp$establish_block_exit_hndlr (^abort_handler);
      osp$set_job_signature_lock (clv$variable_access_lock);
    IFEND;

    access_info := NIL;
    allowed_classes := -$clt$internal_variable_classes [];
    clp$find_first_var_block (allowed_classes, inherited_allowed_classes, inherited_block, block,
          associated_utility);

  /find_block/
    WHILE block <> NIL DO
      IF (inherited_block <> NIL) AND (block^.kind IN $clt$block_kinds
            [clc$command_proc_block, clc$function_proc_block]) AND block^.parameters.evaluated THEN
        allowed_classes := $clt$internal_variable_classes [clc$env_variable, clc$lib_variable,
              clc$pushed_variable];
      IFEND;
      clp$find_variable_access (name, hashed_name, hash, allowed_classes, block, access_info);
      IF access_info <> NIL THEN
        EXIT /find_block/;
      IFEND;
      IF (block^.kind IN $clt$block_kinds [clc$command_proc_block, clc$function_proc_block]) AND
            block^.parameters.evaluated THEN
        allowed_classes := $clt$internal_variable_classes [clc$env_variable, clc$lib_variable,
              clc$pushed_variable];
      IFEND;
      IF associated_utility AND (block = inherited_block) THEN
        allowed_classes := $clt$internal_variable_classes [clc$env_variable, clc$lib_variable,
              clc$pushed_variable];
      IFEND;
      clp$find_next_var_block (allowed_classes, inherited_allowed_classes, inherited_block, block,
            associated_utility);
    WHILEND /find_block/;

    IF access_info <> NIL THEN
      variable_information.access_info_found := TRUE;
      copy_variable_information (access_info, access_variable_requests, work_area, variable_information,
            variable_access_handle, status);
    IFEND;

    IF lock THEN
      osp$clear_job_signature_lock (clv$variable_access_lock);
      osp$disestablish_cond_handler;
    IFEND;

  PROCEND clp$access_variable;
?? NEWTITLE := 'clp$add_to_defer_list', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$add_to_defer_list
    (    name: ost$name;
     VAR status: ost$status);

    VAR
      entry: ^clt$deferred_variable_list,
      deferred_variable_list: ^clt$deferred_variable_list;


    status.normal := TRUE;

    deferred_variable_list := clv$deferred_variable_list;
    WHILE deferred_variable_list <> NIL DO
      IF name = deferred_variable_list^.name THEN
        osp$set_status_abnormal ('CL', cle$recursive_deferred_variable, name, status);
        RETURN;
      IFEND;
      deferred_variable_list := deferred_variable_list^.link;
    WHILEND;

    ALLOCATE entry IN osv$task_private_heap^;
    entry^.name := name;
    entry^.link := clv$deferred_variable_list;
    clv$deferred_variable_list := entry;

  PROCEND clp$add_to_defer_list;
?? NEWTITLE := 'clp$change_colt_ruc_value', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$change_colt_ruc_value
    (    retain_unprintable_characters: boolean;
         call_from_colt_command: boolean);

    clv$retain_unprintable_char := retain_unprintable_characters;
    clv$call_from_colt_command := call_from_colt_command;

  PROCEND clp$change_colt_ruc_value;
?? NEWTITLE := 'clp$change_hdr_creation_value', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$change_hdr_creation_value
    (    first_header_creation_value: boolean);

    clv$first_header_creation := first_header_creation_value;

  PROCEND clp$change_hdr_creation_value;
?? TITLE := 'clp$change_variable_value', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$change_variable_value
    (    name: clt$variable_name;
         data_value: ^clt$data_value;
         value_qualifiers: ^clt$value_qualifiers;
         type_description: ^clt$type_description;
         qualified_type_description: ^clt$type_description;
         variable_access_handle: clt$variable_access_handle;
         allow_padding_or_truncation: boolean;
     VAR work_area {input,output} : ^clt$work_area;
     VAR status: ost$status);

    VAR
      access_info: ^clt$variable_access_info,
      conformance_checked: boolean,
      new_total_variable_allocation: integer,
      original_value: ^clt$internal_data_value,
      original_work_area: ^clt$work_area,
      pad_or_truncate_string: boolean,
      saved_work_area: ^clt$work_area,
      string_value: ^clt$string_value,
      type_conformance: clt$type_conformance,
      value: ^clt$data_value,
      variable_descriptor: ^clt$variable_descriptor,
      variable_value: ^clt$internal_data_value;


    status.normal := TRUE;
    osp$establish_block_exit_hndlr (^variable_abort_handler);
    osp$set_job_signature_lock (clv$variable_access_lock);
    original_work_area := work_area;

  /change_variable/
    BEGIN
*IF NOT $true(osv$unix)
      access_info := #ADDRESS (#RING (^access_info), #SEGMENT (osv$task_shared_heap),
            variable_access_handle.access_info_offset);
*ELSE
      access_info := #ADDRESS (variable_access_handle.access_info_offset);
*IFEND
      IF (access_info^.assignment_counter <> variable_access_handle.assignment_counter) OR
            (#OFFSET (access_info^.descriptor) <> variable_access_handle.descriptor_offset) THEN
        osp$set_status_abnormal ('CL', cle$unknown_variable, name, status);
        EXIT /change_variable/;
      IFEND;

      variable_descriptor := access_info^.descriptor;
      value := data_value;
      variable_value := NIL;
      conformance_checked := FALSE;
      pad_or_truncate_string := FALSE;

      IF data_value^.kind = clc$deferred THEN
        conformance_checked := TRUE;
      ELSEIF qualified_type_description <> NIL THEN
        IF (qualified_type_description^.kind = clc$string_type) AND allow_padding_or_truncation AND
              (value^.kind = clc$string) THEN
          pad_or_truncate_string := TRUE;
        ELSE
          clp$evaluate_value_conformance (value, qualified_type_description, clc$conforms_to_type, status);
          IF NOT status.normal THEN
            EXIT /change_variable/;
          IFEND;
        IFEND;
        conformance_checked := TRUE;
      IFEND;

      saved_work_area := NIL;

      IF pad_or_truncate_string THEN
        IF STRLENGTH (value^.string_value^) > qualified_type_description^.max_string_size THEN
          value^.string_value := ^value^.string_value^ (1, qualified_type_description^.max_string_size);
        ELSEIF STRLENGTH (value^.string_value^) < qualified_type_description^.min_string_size THEN
          NEXT string_value: [qualified_type_description^.min_string_size] IN work_area;
          IF string_value = NIL THEN
            osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
            EXIT /change_variable/;
          IFEND;
          string_value^ := value^.string_value^;
          value^.string_value := string_value;
        IFEND;
      IFEND;

      IF value_qualifiers <> NIL THEN
        IF variable_descriptor^.header.value <> NIL THEN
          original_value := variable_descriptor^.header.value;
        ELSE

{ The following call is made to get an initial estimate for the size of a variable, when the first
{ assignment to that variable is actually to one of its components.

          original_value := NIL;
          clp$convert_ext_value_to_int (type_description, NIL, NIL, work_area, original_value, status);
          IF NOT status.normal THEN
            IF status.condition = cle$work_area_overflow THEN
              osp$set_status_abnormal ('CL', cle$no_space_for_variable, name, status);
            IFEND;
            EXIT /change_variable/;
          IFEND;
        IFEND;
        clp$write_qualified_data_value (name, value_qualifiers, original_value, value, conformance_checked,
              allow_padding_or_truncation, work_area, variable_value, status);
        IF NOT status.normal THEN
          IF status.condition = cle$work_area_overflow THEN
            osp$set_status_abnormal ('CL', cle$no_space_for_variable, name, status);
          IFEND;
          EXIT /change_variable/;
        IFEND;
        IF NOT conformance_checked THEN
          saved_work_area := work_area;
          clp$convert_int_value_to_ext (variable_value, variable_value^.header.value, work_area, value,
                status);
          IF NOT status.normal THEN
            EXIT /change_variable/;
          IFEND;
        IFEND;
      IFEND;

      IF NOT conformance_checked THEN
        clp$evaluate_value_conformance (value, type_description, clc$conforms_to_type, status);
        IF NOT status.normal THEN
          EXIT /change_variable/;
        IFEND;
        IF saved_work_area <> NIL THEN
          work_area := saved_work_area;
        IFEND;
      IFEND;

      IF variable_value = NIL THEN
        clp$convert_ext_value_to_int (type_description, value, NIL, work_area, variable_value, status);
        IF NOT status.normal THEN
          IF status.condition = cle$work_area_overflow THEN
            osp$set_status_abnormal ('CL', cle$no_space_for_variable, name, status);
          IFEND;
          EXIT /change_variable/;
        IFEND;
      IFEND;

      IF variable_value = variable_descriptor^.header.value THEN
        EXIT /change_variable/;
      IFEND;

      new_total_variable_allocation := clv$total_variable_allocation + #SIZE (variable_value^);
      IF variable_descriptor^.header.value <> NIL THEN
        new_total_variable_allocation := new_total_variable_allocation -
              #SIZE (variable_descriptor^.header.value^);
      IFEND;
      IF new_total_variable_allocation > clv$max_variable_allocation THEN
        osp$set_status_abnormal ('CL', cle$no_space_for_variable, name, status);
        EXIT /change_variable/;
      IFEND;

      IF variable_descriptor^.header.value <> NIL THEN
        FREE variable_descriptor^.header.value IN osv$task_shared_heap^;
      IFEND;

      ALLOCATE variable_descriptor^.header.value: [[REP #SIZE (variable_value^.allocated_space) OF cell]] IN
            osv$task_shared_heap^;
      clv$total_variable_allocation := new_total_variable_allocation;

      variable_descriptor^.header.value^ := variable_value^;
    END /change_variable/;

    work_area := original_work_area;
    osp$clear_job_signature_lock (clv$variable_access_lock);
    osp$disestablish_cond_handler;

  PROCEND clp$change_variable_value;
?? TITLE := 'clp$create_var_from_conversion', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$create_var_from_conversion
    (    name: ost$name;
         kind: clt$variable_kinds;
         max_string_size: clt$string_size;
         create_array: boolean;
         lower_bound: clt$variable_dimension;
         upper_bound: clt$variable_dimension;
         scope: clt$variable_scope;
         initial_value: ^clt$data_value;
         return_variable: boolean;
     VAR work_area {input, output} : ^clt$work_area;
     VAR variable: clt$variable_reference;
     VAR status: ost$status);

    VAR
      declaration_scope: clt$variable_declaration_scope,
      return_variable_value: conversion_value,
      type_description: ^clt$type_description,
      type_specification: ^clt$type_specification,
      utility_name: utility_name_definition;


    status.normal := TRUE;

    check_name (name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$create_variable_type (kind, max_string_size, create_array, lower_bound, upper_bound, work_area,
          type_specification, type_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    return_variable_value.converted := return_variable;
    IF max_string_size <= osc$max_string_size THEN
      return_variable_value.max_string_size := max_string_size;
    ELSE
      return_variable_value.max_string_size := osc$max_string_size;
    IFEND;

    CASE scope.kind OF
    = clc$job_variable =
      declaration_scope := clc$job_scope;
      utility_name.defined := FALSE;
    = clc$utility_variable =
      declaration_scope := clc$utility_scope;
      utility_name.defined := TRUE;
      utility_name.value := scope.utility_name;
    = clc$local_variable =
      declaration_scope := clc$local_scope;
    = clc$xdcl_variable =
      declaration_scope := clc$xdcl_scope;
    = clc$xref_variable =
      declaration_scope := clc$xref_scope;
    ELSE

{ Should never get here.

      osp$set_status_abnormal ('CL', cle$bad_variable_scope, name, status);
      RETURN;
    CASEND;

    osp$establish_block_exit_hndlr (^variable_abort_handler);
    osp$set_job_signature_lock (clv$variable_access_lock);

    CASE declaration_scope OF
    = clc$job_scope, clc$utility_scope =
      internal_create_environment_var (name, clc$read_write, clc$immediate_evaluation, type_specification,
            declaration_scope, utility_name, type_description, initial_value, FALSE, return_variable_value,
            work_area, status);
    ELSE
      internal_create_procedure_var (name, clc$read_write, clc$immediate_evaluation, type_specification,
            declaration_scope, type_description, initial_value, return_variable_value, work_area, status);
    CASEND;

    osp$clear_job_signature_lock (clv$variable_access_lock);
    osp$disestablish_cond_handler;

    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF return_variable THEN
      variable.reference.value := name;
      variable.reference.size := clp$trimmed_string_size (name);
      variable.lower_bound := lower_bound;
      variable.upper_bound := upper_bound;
      variable.value := return_variable_value.converted_value;
    IFEND;

  PROCEND clp$create_var_from_conversion;
?? TITLE := 'clp$create_var_from_type_spec', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$create_var_from_type_spec
    (    name: clt$variable_name;
         scope: clt$variable_declaration_scope;
         access_mode: clt$data_access_mode;
         evaluation_method: clt$expression_eval_method;
         type_specification: ^clt$type_specification;
         initial_value: ^clt$data_value;
         require_existing_var_for_push: boolean;
     VAR work_area {input,output} : ^clt$work_area;
     VAR status: ost$status);

    VAR
      return_variable_value: conversion_value,
      type_description: ^clt$type_description,
      utility_name: utility_name_definition;


    status.normal := TRUE;
    type_description := NIL;
    return_variable_value.converted := FALSE;

    check_name (name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (access_mode = clc$read_only) AND (initial_value = NIL) AND (scope <> clc$push_scope) AND
          (scope <> clc$xref_scope) THEN
      osp$set_status_abnormal ('CL', cle$read_var_requires_value, name, status);
      RETURN;
    IFEND;

    IF NOT ((scope = clc$push_scope) AND require_existing_var_for_push) THEN
      NEXT type_description IN work_area;
      IF type_description = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;

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

    osp$establish_block_exit_hndlr (^variable_abort_handler);
    osp$set_job_signature_lock (clv$variable_access_lock);

    CASE scope OF
    = clc$environment_scope, clc$job_scope, clc$task_scope, clc$utility_scope, clc$push_scope =
      utility_name.defined := FALSE;
      internal_create_environment_var (name, access_mode, evaluation_method, type_specification, scope,
            utility_name, type_description, initial_value, require_existing_var_for_push,
            return_variable_value, work_area, status);
    = clc$local_scope, clc$xdcl_scope, clc$xref_scope =
      internal_create_procedure_var (name, access_mode, evaluation_method, type_specification, scope,
            type_description, initial_value, return_variable_value, work_area, status);
    CASEND;

    osp$clear_job_signature_lock (clv$variable_access_lock);
    osp$disestablish_cond_handler;

  PROCEND clp$create_var_from_type_spec;
?? TITLE := 'clp$delete_from_defer_list', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$delete_from_defer_list;

    VAR
      first_entry: ^clt$deferred_variable_list;

    first_entry := clv$deferred_variable_list;
    IF first_entry <> NIL THEN
      clv$deferred_variable_list := clv$deferred_variable_list^.link;
      FREE first_entry IN osv$task_private_heap^;
    IFEND;

  PROCEND clp$delete_from_defer_list;
?? TITLE := 'clp$delete_parameters', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$delete_parameters
    (VAR parameters: clt$parameters);

    VAR
      i: clt$parameter_number;


    IF parameters.procedure_parameters THEN
      IF parameters.values <> NIL THEN
        FREE parameters.values IN osv$task_shared_heap^;
      IFEND;

      IF parameters.accesses <> NIL THEN
        FOR i := 1 TO UPPERBOUND (parameters.accesses^) DO
          IF (parameters.accesses^ [i].info.access_mode = clc$read_write) AND parameters.accesses^ [i].
                info.parameter_passed THEN
            decrement_variable_access_count (parameters.accesses^ [i].info.descriptor);
            IF parameters.accesses^ [i].info.qualifiers <> NIL THEN
              FREE parameters.accesses^ [i].info.qualifiers IN osv$task_shared_heap^;
            IFEND;
          IFEND;
        FOREND;
      IFEND;
    IFEND;

    IF parameters.area <> NIL THEN
      FREE parameters.area IN osv$task_shared_heap^;
    IFEND;

  PROCEND clp$delete_parameters;
?? TITLE := 'clp$delete_variable', EJECT ??
*copyc clh$delete_variable

  PROCEDURE [XDCL, #GATE] clp$delete_variable
    (    name: string ( * );
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      name_is_valid: boolean,
      validated_name: ost$name;


    status.normal := TRUE;

    clp$validate_name (name, validated_name, name_is_valid);
    IF name_is_valid THEN
      clp$internal_delete_variable (validated_name, -$clt$internal_variable_classes [], local_status);
    ELSE
      osp$set_status_abnormal ('CL', cle$improper_variable_name, name, local_status);
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

  PROCEND clp$delete_variable;
?? TITLE := 'clp$delete_variables', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$delete_variables
    (VAR variables: clt$variables);

    VAR
      current_variable: ^clt$variable_access,
      i: clt$variable_name_hash,
      next_variable: ^clt$variable_access,
      variable_descriptor: ^clt$variable_descriptor;


    osp$establish_block_exit_hndlr (^variable_abort_handler);
    osp$set_job_signature_lock (clv$variable_access_lock);

    FOR i := 0 TO clc$max_variable_hash_groups - 1 DO
      variables.hash_groups [i].root := NIL;
      variables.hash_groups [i].environment_variables_in_group := 0;
      variables.hash_groups [i].procedure_variables_in_group := 0;
    FOREND;
    current_variable := variables.thread;
    variables.thread := NIL;
    WHILE current_variable <> NIL DO
      next_variable := current_variable^.forward_thread;
      decrement_variable_access_count (current_variable^.info.descriptor);
      FREE current_variable IN osv$task_shared_heap^;
      current_variable := next_variable;
    WHILEND;

    osp$clear_job_signature_lock (clv$variable_access_lock);
    osp$disestablish_cond_handler;

  PROCEND clp$delete_variables;
?? TITLE := 'clp$internal_delete_variable ', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$internal_delete_variable
    (    name: ost$name;
         allowed_classes: clt$internal_variable_classes;
     VAR status: ost$status);

    VAR
      hash: clt$variable_name_hash,
      hashed_name: clt$variable_name,
      variable_descriptor: ^clt$variable_descriptor;


    status.normal := TRUE;

    osp$establish_block_exit_hndlr (^variable_abort_handler);
    osp$set_job_signature_lock (clv$variable_access_lock);

  /delete_variable/
    BEGIN
      clp$compute_variable_name_hash (name, hashed_name, hash);
      clp$delete_variable_access (hashed_name, hash, allowed_classes, variable_descriptor);
      IF variable_descriptor = NIL THEN
        osp$set_status_abnormal ('CL', cle$unknown_variable, name, status);
        EXIT /delete_variable/;
      IFEND;
      decrement_variable_access_count (variable_descriptor);
    END /delete_variable/;

    osp$clear_job_signature_lock (clv$variable_access_lock);
    osp$disestablish_cond_handler;

  PROCEND clp$internal_delete_variable;
*IFEND
?? TITLE := 'clp$obtain_variable_value', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$obtain_variable_value
    (    name: clt$variable_name;
         variable_access_handle: ^clt$variable_access_handle;
         access_variable_requests: clt$access_variable_requests;
     VAR work_area {input, output} : ^clt$work_area;
     VAR qualified_type_description {input, output} : ^clt$type_description;
     VAR parse_value_qualifiers {input, output} : ^clt$value_qualifiers;
     VAR parse_value_qualifiers_index: integer;
     VAR value: ^clt$data_value;
     VAR status: ost$status);

    VAR
      access_info: ^clt$variable_access_info,
      internal_value: ^clt$internal_data_value,
      var_parameter_value_qualifiers: ^clt$value_qualifiers;

{
{ The parameter VALUE is NOT NIL in a few instances. The value
{ is either a function result or a deferred value of a variable
{ or an unspecified value.
{
{ The result value is evaluated from the parameter VALUE if it is NOT NIL.
{ Otherwise the result value is evaluated from the internal value from the
{ access info.
{


    status.normal := TRUE;
    internal_value := NIL;
    var_parameter_value_qualifiers := NIL;
    parse_value_qualifiers_index := 0;
*IF NOT $true(osv$unix)
    osp$establish_block_exit_hndlr (^variable_abort_handler);
    osp$set_job_signature_lock (clv$variable_access_lock);
*IFEND

  /obtain_value/
    BEGIN
      IF variable_access_handle <> NIL THEN
*IF NOT $true(osv$unix)
*IF NOT $true(osv$unix)
        access_info := #ADDRESS (#RING (^access_info), #SEGMENT (osv$task_shared_heap),
              variable_access_handle^.access_info_offset);
*ELSE
        access_info := #ADDRESS (variable_access_handle^.access_info_offset);
*IFEND
        IF (access_info^.assignment_counter <> variable_access_handle^.assignment_counter) OR
              (#OFFSET (access_info^.descriptor) <> variable_access_handle^.descriptor_offset) THEN
          osp$set_status_abnormal ('CL', cle$unknown_variable, name, status);
          EXIT /obtain_value/;
        IFEND;

        var_parameter_value_qualifiers := access_info^.qualifiers;

        IF value = NIL THEN
          internal_value := access_info^.descriptor^.header.value;
        IFEND;
*ELSE
{ I don't think we should get here for PHASE I, but if we do, just set status
{ to abnormal.
        osp$set_status_abnormal ('CL', cle$not_supported, 'Variables are',
              status);
        EXIT /obtain_value/;
*IFEND
      IFEND;

      IF (var_parameter_value_qualifiers = NIL) AND (parse_value_qualifiers = NIL) THEN
{
{ There are no value qualifiers.  Convert the internal value if necessary.
{
        IF internal_value <> NIL THEN
*IF NOT $true(osv$unix)
          clp$convert_int_value_to_ext (internal_value, internal_value^.header.value, work_area, value,
                status);
*ELSE
{ I don't think we should get here for PHASE I, but if we do, just set status
{ to abnormal.
        osp$set_status_abnormal ('CL', cle$not_supported, 'Variables are',
             status);
        EXIT /obtain_value/;
*IFEND
        IFEND;
      ELSEIF (value <> NIL) OR (internal_value <> NIL) THEN
{
{ Evaluate the value qualifiers according to the value.
{
        clp$read_qualified_data_value (name, access_variable_requests, var_parameter_value_qualifiers,
              internal_value, value, work_area, qualified_type_description, parse_value_qualifiers,
              parse_value_qualifiers_index, status);
        IF NOT status.normal THEN
          EXIT /obtain_value/;
        IFEND;
      ELSEIF NOT (clc$possible_file_reference IN access_variable_requests) THEN
{
{ There are value qualifiers but no value.  Return an error message because it is not a
{ possible file reference.
{
*IF NOT $true(osv$unix)
        osp$set_status_abnormal ('CL', cle$cannot_read_component, name, status);
*ELSE
        osp$set_status_abnormal ('CL', cle$not_supported, 'Variables are', status);
*IFEND
        EXIT /obtain_value/;
      ELSE
{
{ This is a possible file reference.  Reset the parse to the beginning.
{
        IF parse_value_qualifiers <> NIL THEN
          parse_value_qualifiers_index := 1;
        IFEND;
      IFEND;

    END /obtain_value/;

*IF NOT $true(osv$unix)
    osp$clear_job_signature_lock (clv$variable_access_lock);
    osp$disestablish_cond_handler;
*IFEND

  PROCEND clp$obtain_variable_value;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$pass_variable_parameter', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$pass_variable_parameter
    (    parameter_number: clt$parameter_number;
         access_handle: clt$variable_access_handle;
         value_qualifiers: ^clt$value_qualifiers;
         variable_name: clt$variable_name;
     VAR work_area {input, output} : ^clt$work_area;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      i: integer,
      number_of_qualifiers: integer,
      parameter_access: ^clt$parameter_access,
      size: integer,
      variable_access_info: ^clt$variable_access_info;

?? NEWTITLE := 'get_size_of_value_qualifiers', EJECT ??

    PROCEDURE [INLINE] get_size_of_value_qualifiers
      (    value_qualifiers: ^clt$value_qualifiers;
       VAR number_of_qualifiers: integer;
       VAR size: integer);

      VAR
        i: integer;


      IF value_qualifiers = NIL THEN
        number_of_qualifiers := 0;
        size := 0;
      ELSE
        number_of_qualifiers := UPPERBOUND (value_qualifiers^);
        size := (#SIZE (clt$value_qualifier)) * number_of_qualifiers;
        FOR i := 1 TO number_of_qualifiers DO
          CASE value_qualifiers^ [i].kind OF
          = clc$field_qualifier, clc$unspecified_field_qualifier =
            IF value_qualifiers^ [i].record_kind = clc$record_record THEN
              size := size + #SIZE (value_qualifiers^ [i].field_names^);
            IFEND;
          ELSE
            ;
          CASEND;
        FOREND;
      IFEND;

    PROCEND get_size_of_value_qualifiers;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    osp$establish_block_exit_hndlr (^variable_abort_handler);
    osp$set_job_signature_lock (clv$variable_access_lock);

  /pass_variable_parameter/
    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^.parameters.evaluated OR (block^.kind <> clc$command_proc_block) OR
            (block^.parameters.accesses = NIL) OR (parameter_number >
            UPPERBOUND (block^.parameters.accesses^)) OR block^.parameters.accesses^ [parameter_number].info.
            parameter_passed OR (block^.parameters.accesses^ [parameter_number].info.access_mode <>
            clc$read_write) THEN
        osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$pass_variable_parameter', status);
        EXIT /pass_variable_parameter/;
      IFEND;

*IF NOT $true(osv$unix)
      variable_access_info := #ADDRESS (#RING (block), #SEGMENT (osv$task_shared_heap),
            access_handle.access_info_offset);
*ELSE
      variable_access_info := #ADDRESS (access_handle.access_info_offset);
*IFEND
      IF (variable_access_info^.assignment_counter <> access_handle.assignment_counter) OR
            (#OFFSET (variable_access_info^.descriptor) <> access_handle.descriptor_offset) THEN
        osp$set_status_abnormal ('CL', cle$unknown_variable, variable_name, status);
        EXIT /pass_variable_parameter/;
      IFEND;

      parameter_access := ^block^.parameters.accesses^ [parameter_number];
      parameter_access^.info.class := clc$param_variable;
      parameter_access^.info.parameter_passed := TRUE;
      parameter_access^.info.descriptor := variable_access_info^.descriptor;
      variable_access_info^.descriptor^.header.access_count :=
            variable_access_info^.descriptor^.header.access_count + 1;

      get_size_of_value_qualifiers (value_qualifiers, number_of_qualifiers, size);
      IF number_of_qualifiers = 0 THEN
        EXIT /pass_variable_parameter/;
      IFEND;

      ALLOCATE parameter_access^.qualifiers_area: [[REP size OF cell]] IN osv$task_shared_heap^;
      RESET parameter_access^.qualifiers_area;
      NEXT parameter_access^.info.qualifiers: [1 .. number_of_qualifiers] IN
            parameter_access^.qualifiers_area;
      FOR i := 1 TO number_of_qualifiers DO
        parameter_access^.info.qualifiers^ [i] := value_qualifiers^ [i];
        CASE value_qualifiers^ [i].kind OF
        = clc$field_qualifier, clc$unspecified_field_qualifier =
          IF value_qualifiers^ [i].record_kind = clc$record_record THEN
            NEXT parameter_access^.info.qualifiers^ [i].field_names:
                  [1 .. UPPERBOUND (value_qualifiers^ [i].field_names^)] IN parameter_access^.qualifiers_area;
            parameter_access^.info.qualifiers^ [i].field_names^ := value_qualifiers^ [i].field_names^;
          IFEND;
        ELSE
          ;
        CASEND;
      FOREND;

    END /pass_variable_parameter/;

    osp$clear_job_signature_lock (clv$variable_access_lock);
    osp$disestablish_cond_handler;

  PROCEND clp$pass_variable_parameter;
?? TITLE := 'clp$unpass_variable_parameter', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$unpass_variable_parameter
    (    parameter_number: clt$parameter_number);

    VAR
      block: ^clt$block;


    clp$find_current_block (block);
    IF (block^.kind = clc$input_block) AND block^.input.prompting_input THEN
      block := block^.previous_block;
    IFEND;
    IF block^.parameters.evaluated OR (block^.kind <> clc$command_proc_block) OR
          (block^.parameters.accesses = NIL) OR (parameter_number >
          UPPERBOUND (block^.parameters.accesses^)) OR (NOT block^.parameters.accesses^ [parameter_number].
          info.parameter_passed) OR (block^.parameters.accesses^ [parameter_number].info.access_mode <>
          clc$read_write) THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^variable_abort_handler);
    osp$set_job_signature_lock (clv$variable_access_lock);

    block^.parameters.accesses^ [parameter_number].info.class := clc$param_variable;
    block^.parameters.accesses^ [parameter_number].info.parameter_passed := FALSE;
    decrement_variable_access_count (block^.parameters.accesses^ [parameter_number].info.descriptor);
    block^.parameters.accesses^ [parameter_number].info.qualifiers := NIL;
    block^.parameters.accesses^ [parameter_number].info.descriptor := block^.parameters.
          accesses^ [parameter_number].info.original_parameter_descriptor;
    IF block^.parameters.accesses^ [parameter_number].qualifiers_area <> NIL THEN
      FREE block^.parameters.accesses^ [parameter_number].qualifiers_area IN osv$task_shared_heap^;
    IFEND;

    osp$clear_job_signature_lock (clv$variable_access_lock);
    osp$disestablish_cond_handler;

  PROCEND clp$unpass_variable_parameter;
?? TITLE := 'complete_variable_access', EJECT ??

  PROCEDURE complete_variable_access
    (    access_mode: clt$data_access_mode;
         class: clt$internal_variable_class;
         descriptor: ^clt$variable_descriptor;
         qualifiers: ^clt$value_qualifiers;
         variable_access: ^clt$variable_access);


    variable_access^.info.access_mode := access_mode;
    variable_access^.info.class := class;
    variable_access^.info.parameter_passed := TRUE;
    variable_access^.info.descriptor := descriptor;
    variable_access^.info.qualifiers := qualifiers;
    osp$increment_locked_variable (clv$var_access_assignment_count, 0,
          variable_access^.info.assignment_counter);
    descriptor^.header.access_count := descriptor^.header.access_count + 1;

  PROCEND complete_variable_access;
?? TITLE := 'copy_variable_information', EJECT ??

  PROCEDURE copy_variable_information
    (    variable_access_info: ^clt$variable_access_info;
         access_variable_requests: clt$access_variable_requests;
     VAR work_area {input, output} : ^clt$work_area;
     VAR variable_information: clt$variable_information;
     VAR variable_access_handle: clt$variable_access_handle;
     VAR status: ost$status);

    VAR
      copy_internal_value: boolean,
      copy_type_specification: boolean,
      i_value: ^clt$i_data_value,
      internal_value: ^clt$internal_data_value,
      original_work_area: ^clt$work_area;

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           ignore_condition_information: ^pmt$condition_information;
           ignore_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      CASE condition.selector OF

      = pmc$block_exit_processing =
        work_area := original_work_area;
        #SPOIL (work_area);
        RETURN;

      = mmc$segment_access_condition =
        CASE condition.segment_access_condition.identifier OF
        = mmc$sac_read_write_beyond_msl, mmc$sac_no_append_permission =
*IF NOT $true(osv$unix)
          IF #SEGMENT (condition.segment_access_condition.segment) = #SEGMENT (work_area) THEN
*ELSE
          IF #LOC (condition.segment_access_condition.segment^) = #LOC (work_area^) THEN
*IFEND
            work_area_overflow;
          IFEND;
        ELSE
          ;
        CASEND;

      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? TITLE := 'work_area_overflow', EJECT ??

    PROCEDURE [INLINE] work_area_overflow;


      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      EXIT copy_variable_information;

    PROCEND work_area_overflow;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    original_work_area := work_area;
    #SPOIL (original_work_area);
    osp$establish_condition_handler (^abort_handler, TRUE);

    variable_access_handle.access_info_offset := #OFFSET (variable_access_info);
    variable_access_handle.descriptor_offset := #OFFSET (variable_access_info^.descriptor);
    variable_access_handle.assignment_counter := variable_access_info^.assignment_counter;

    variable_information.access_mode := variable_access_info^.access_mode;
    variable_information.class := variable_access_info^.class;
    variable_information.parameter_passed := variable_access_info^.parameter_passed;
    variable_information.evaluation_method := variable_access_info^.descriptor^.header.evaluation_method;
    variable_information.has_no_internal_value := variable_access_info^.descriptor^.header.value = NIL;
    variable_information.value_qualifiers_present := variable_access_info^.qualifiers <> NIL;

    IF NOT variable_information.has_no_internal_value THEN
      internal_value := variable_access_info^.descriptor^.header.value;
      i_value := #PTR (internal_value^.header.value, internal_value^);
    IFEND;

    IF clc$return_type_specification IN access_variable_requests THEN
      copy_type_specification := TRUE;
    ELSEIF (clc$type_spec_if_defer_method IN access_variable_requests) AND
          (variable_information.evaluation_method = clc$deferred_evaluation) THEN
      copy_type_specification := TRUE;
    ELSEIF (clc$value_info_if_defer_value IN access_variable_requests) AND
          (NOT variable_information.has_no_internal_value) AND (i_value^.kind = clc$deferred) THEN
      copy_type_specification := TRUE;
    ELSE
      copy_type_specification := FALSE;
    IFEND;

    IF copy_type_specification THEN
      NEXT variable_information.type_specification: [[REP #SIZE (variable_access_info^.descriptor^.
            type_specification) OF cell]] IN work_area;
      IF variable_information.type_specification = NIL THEN
        work_area_overflow;
      IFEND;
      variable_information.type_specification^ := variable_access_info^.descriptor^.type_specification;
    ELSE
      variable_information.type_specification := NIL;
    IFEND;

    IF variable_information.has_no_internal_value THEN
      copy_internal_value := FALSE;
    ELSEIF clc$return_internal_value IN access_variable_requests THEN
      copy_internal_value := TRUE;
    ELSEIF (clc$value_info_if_defer_value IN access_variable_requests) AND (i_value^.kind = clc$deferred) THEN
      copy_internal_value := TRUE;
    ELSE
      copy_internal_value := FALSE;
    IFEND;

    IF copy_internal_value THEN
      NEXT variable_information.internal_value: [[REP #SIZE (variable_access_info^.descriptor^.header.
            value^) OF cell]] IN work_area;
      IF variable_information.internal_value = NIL THEN
        work_area_overflow;
      IFEND;
      variable_information.internal_value^ := variable_access_info^.descriptor^.header.value^;
    ELSE
      variable_information.internal_value := NIL;
    IFEND;

    IF (clc$return_value_qualifiers IN access_variable_requests) AND
          variable_information.value_qualifiers_present THEN
      NEXT variable_information.value_qualifiers: [1 .. UPPERBOUND (variable_access_info^.qualifiers^)] IN
            work_area;
      IF variable_information.value_qualifiers = NIL THEN
        work_area_overflow;
      IFEND;
      variable_information.value_qualifiers^ := variable_access_info^.qualifiers^;
    ELSE
      variable_information.value_qualifiers := NIL;
    IFEND;

    IF clc$return_type_description IN access_variable_requests THEN
      NEXT variable_information.type_description IN work_area;
      IF variable_information.type_description = NIL THEN
        work_area_overflow;
      IFEND;
      clp$convert_type_spec_to_desc (^variable_access_info^.descriptor^.type_specification, work_area,
            variable_information.type_description^, status);
    ELSE
      variable_information.type_description := NIL;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND copy_variable_information;
?? TITLE := 'decrement_variable_access_count', EJECT ??

  PROCEDURE decrement_variable_access_count
    (VAR {input, output} variable_descriptor: ^clt$variable_descriptor);

    IF variable_descriptor <> NIL THEN
      variable_descriptor^.header.access_count := variable_descriptor^.header.access_count - 1;
      IF variable_descriptor^.header.access_count = 0 THEN
        IF variable_descriptor^.header.value <> NIL THEN
          clv$total_variable_allocation := clv$total_variable_allocation -
                #SIZE (variable_descriptor^.header.value^);
          FREE variable_descriptor^.header.value IN osv$task_shared_heap^;
        IFEND;
        FREE variable_descriptor IN osv$task_shared_heap^;
      IFEND;
    IFEND;

  PROCEND decrement_variable_access_count;
?? TITLE := 'find_first_var_creation_block', EJECT ??

  PROCEDURE find_first_var_creation_block
    (VAR allowed_classes {input, output} : clt$internal_variable_classes;
     VAR inherited_allowed_classes {input, output} : clt$internal_variable_classes;
     VAR inherited_block {input, output} : ^clt$block;
     VAR block {input, output} : ^clt$block);

    VAR
      associated_utility: boolean;


    clp$find_first_var_block (allowed_classes, inherited_allowed_classes, inherited_block, block,
          associated_utility);

    WHILE (block <> NIL) AND (inherited_block <> NIL) AND (NOT associated_utility) AND
          (block^.kind IN $clt$block_kinds [clc$command_proc_block, clc$function_proc_block]) AND
          block^.parameters.evaluated DO

      clp$find_next_var_block (allowed_classes, inherited_allowed_classes, inherited_block, block,
            associated_utility);

    WHILEND;

  PROCEND find_first_var_creation_block;
?? TITLE := 'initialize_variable_value', EJECT ??

  PROCEDURE initialize_variable_value
    (    name: clt$variable_name;
         initial_value: ^clt$data_value;
         type_description: ^clt$type_description;
     VAR work_area {input, output} : ^clt$work_area;
     VAR descriptor_header {input, output} : clt$variable_descriptor_header;
     VAR status: ost$status);

    VAR
      internal_value: ^clt$internal_data_value,
      original_work_area: ^clt$work_area,
      type_conformance: clt$type_conformance;


    status.normal := TRUE;
    original_work_area := work_area;

  /initialize_value/
    BEGIN
      IF (initial_value <> NIL) AND (initial_value^.kind <> clc$unspecified) THEN
        IF initial_value^.kind <> clc$deferred THEN
          clp$evaluate_value_conformance (initial_value, type_description, clc$conforms_to_type, status);
          IF NOT status.normal THEN
            EXIT /initialize_value/;
          IFEND;
        IFEND;
        internal_value := NIL;
        clp$convert_ext_value_to_int (type_description, initial_value, NIL, work_area, internal_value,
              status);
      ELSE
        clp$create_default_init_value (type_description, work_area, internal_value, status);
        IF status.normal AND (internal_value = NIL) THEN
          EXIT /initialize_value/;
        IFEND;
      IFEND;

      IF NOT status.normal THEN
        IF status.condition = cle$work_area_overflow THEN
          osp$set_status_abnormal ('CL', cle$no_space_for_variable, name, status);
        IFEND;
        EXIT /initialize_value/;
      ELSEIF (clv$total_variable_allocation + #SIZE (internal_value^)) > clv$max_variable_allocation THEN
        osp$set_status_abnormal ('CL', cle$no_space_for_variable, name, status);
        EXIT /initialize_value/;
      IFEND;

      ALLOCATE descriptor_header.value: [[REP #SIZE (internal_value^.allocated_space) OF cell]] IN
            osv$task_shared_heap^;
      clv$total_variable_allocation := clv$total_variable_allocation + #SIZE (internal_value^);

      descriptor_header.value^ := internal_value^;
    END /initialize_value/;

    work_area := original_work_area;

  PROCEND initialize_variable_value;
?? TITLE := 'internal_create_environment_var', EJECT ??

  PROCEDURE internal_create_environment_var
    (    name: clt$variable_name;
         access_mode: clt$data_access_mode;
         evaluation_method: clt$expression_eval_method;
         type_specification: ^clt$type_specification;
         scope: clt$environment_variable_scope;
         utility_name: utility_name_definition;
         type_description: ^clt$type_description;
         initial_value: ^clt$data_value;
         require_existing_var_for_push: boolean;
     VAR return_variable_value {input, output} : conversion_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR status: ost$status);

    VAR
      allowed_classes: clt$internal_variable_classes,
      declarer_block: ^clt$block,
      declarer_variable_access: ^clt$variable_access,
      descriptor: ^clt$variable_descriptor,
      descriptor_header: clt$variable_descriptor_header,
      hash: clt$variable_name_hash,
      hashed_name: clt$variable_name,
      ignore_associated_utility: boolean,
      inherited_allowed_classes: clt$internal_variable_classes,
      inherited_block: ^clt$block,
      local_access_mode: clt$data_access_mode,
      local_class: clt$internal_variable_class,
      local_type_specification: ^clt$type_specification,
      pushed_variable_information: clt$variable_information,
      type_conformance: clt$type_conformance,
      xref_block: ^clt$block,
      xref_variable_access: ^clt$variable_access;

?? NEWTITLE := 'process_push_scope', EJECT ??

    PROCEDURE process_push_scope;

      VAR
        access_variable_requests: clt$access_variable_requests,
        ignore_access_handle: clt$variable_access_handle;

?? NEWTITLE := 'initialize_push_variable_value', EJECT ??

      PROCEDURE [INLINE] initialize_push_variable_value;

        VAR
          initial_value_size: clt$internal_data_value_size;


        initial_value_size := #SIZE (pushed_variable_information.internal_value^.allocated_space);
        IF (clv$total_variable_allocation + initial_value_size) > clv$max_variable_allocation THEN
          osp$set_status_abnormal ('CL', cle$no_space_for_variable, name, status);
          EXIT internal_create_environment_var;
        IFEND;

        ALLOCATE descriptor_header.value: [[REP #SIZE (pushed_variable_information.
              internal_value^.allocated_space) OF cell]] IN osv$task_shared_heap^;
        clv$total_variable_allocation := clv$total_variable_allocation +
          #SIZE (pushed_variable_information.internal_value^);
        descriptor_header.value^ := pushed_variable_information.internal_value^;

      PROCEND initialize_push_variable_value;
?? OLDTITLE, EJECT ??



      access_variable_requests := $clt$access_variable_requests [clc$return_type_description];
      IF require_existing_var_for_push THEN
        access_variable_requests := access_variable_requests +
              $clt$access_variable_requests [clc$return_type_specification];
      IFEND;
      IF initial_value = NIL THEN
        access_variable_requests := access_variable_requests +
              $clt$access_variable_requests [clc$return_internal_value];
      IFEND;

      clp$access_variable (name, hashed_name, hash, FALSE, access_variable_requests, work_area,
            pushed_variable_information, ignore_access_handle, status);
      IF NOT status.normal THEN
        EXIT internal_create_environment_var;
      IFEND;

      IF pushed_variable_information.access_info_found THEN
        CASE pushed_variable_information.class OF
        = clc$env_variable, clc$lib_variable, clc$pushed_variable =
          ;
        ELSE
          osp$set_status_abnormal ('CL', cle$cannot_push_variable, name, status);
          EXIT internal_create_environment_var;
        CASEND;

        descriptor_header.evaluation_method := pushed_variable_information.evaluation_method;

        IF require_existing_var_for_push THEN
          local_type_specification := pushed_variable_information.type_specification;
        ELSE
          clp$evaluate_type_conformance (type_description, pushed_variable_information.type_description,
                clc$identical_types, status);
          IF NOT status.normal THEN
            EXIT internal_create_environment_var;
          IFEND;
        IFEND;

        IF (initial_value = NIL) AND (NOT pushed_variable_information.has_no_internal_value) THEN
          initialize_push_variable_value;
        IFEND;

      ELSEIF require_existing_var_for_push THEN
        osp$set_status_abnormal ('CL', cle$unknown_variable, name, status);
        EXIT internal_create_environment_var;
      IFEND;

      local_access_mode := clc$read_write;
      local_class := clc$pushed_variable;

    PROCEND process_push_scope;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    local_access_mode := access_mode;
    local_type_specification := type_specification;
    local_class := clc$env_variable;
    descriptor_header.access_count := 0;
    descriptor_header.evaluation_method := evaluation_method;
    descriptor_header.value := NIL;
    descriptor_header.library := NIL;

    clp$compute_variable_name_hash (name, hashed_name, hash);
    allowed_classes := $clt$internal_variable_classes [clc$env_variable, clc$xrefed_variable,
          clc$pushed_variable];
    find_first_var_creation_block (allowed_classes, inherited_allowed_classes, inherited_block,
          declarer_block);
    xref_block := declarer_block;

  /find_declarer_block/
    BEGIN
      WHILE declarer_block <> NIL DO
        CASE scope OF
        = clc$job_scope =
          IF (declarer_block^.kind = clc$task_block) AND (declarer_block^.task_kind = clc$job_monitor_task)
                THEN
            EXIT /find_declarer_block/;
          IFEND;
        = clc$environment_scope =
          EXIT /find_declarer_block/;
        = clc$task_scope =
          IF declarer_block^.kind = clc$task_block THEN
            EXIT /find_declarer_block/;
          IFEND;
        = clc$utility_scope =
          IF (declarer_block^.kind = clc$utility_block) AND ((NOT utility_name.defined) OR
                (declarer_block^.label = utility_name.value)) THEN
            EXIT /find_declarer_block/;
          IFEND;
        = clc$push_scope =
          process_push_scope;
          EXIT /find_declarer_block/;
        ELSE

{ Should not get here.

          osp$set_status_abnormal ('CL', cle$bad_variable_scope, name, status);
          RETURN;
        CASEND;
        clp$find_next_var_block (allowed_classes, inherited_allowed_classes, inherited_block, declarer_block,
              ignore_associated_utility);
      WHILEND;
      IF utility_name.defined THEN
        osp$set_status_abnormal ('CL', cle$unknown_utility, utility_name.value, status);
      ELSE
        osp$set_status_abnormal ('CL', cle$no_utility_active, '', status);
      IFEND;
      RETURN;
    END /find_declarer_block/;

    IF descriptor_header.value = NIL THEN

{ This is the usual path.  Process_push_scope sometimes creates the value.

      initialize_variable_value (name, initial_value, type_description, work_area, descriptor_header, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF return_variable_value.converted THEN
      clp$convert_int_to_var_value (descriptor_header.value, return_variable_value.max_string_size,
            return_variable_value.converted_value, status);
      IF NOT status.normal THEN
        IF descriptor_header.value <> NIL THEN
          clv$total_variable_allocation := clv$total_variable_allocation - #SIZE (descriptor_header.value^);
          FREE descriptor_header.value IN osv$task_shared_heap^;
        IFEND;
        RETURN;
      IFEND;
    IFEND;

    clp$add_variable_to_tree (hashed_name, hash, local_class, declarer_block^.variables,
          declarer_variable_access);

    IF declarer_variable_access = NIL THEN

{ A variable already exists by the same name in the declarer block.

      IF descriptor_header.value <> NIL THEN
        clv$total_variable_allocation := clv$total_variable_allocation - #SIZE (descriptor_header.value^);
        FREE descriptor_header.value IN osv$task_shared_heap^;
      IFEND;
      osp$set_status_abnormal ('CL', cle$var_already_created, name, status);
      RETURN;
    ELSEIF declarer_block <> xref_block THEN
      clp$add_variable_to_tree (hashed_name, hash, clc$xrefed_variable, xref_block^.variables,
            xref_variable_access);
      IF xref_variable_access = NIL THEN

{ A variable already exists by the same name in the xref block.

        clp$delete_variable_from_tree (hashed_name, hash, $clt$internal_variable_classes [local_class],
              declarer_block^.variables, descriptor);
        IF descriptor_header.value <> NIL THEN
          clv$total_variable_allocation := clv$total_variable_allocation - #SIZE (descriptor_header.value^);
          FREE descriptor_header.value IN osv$task_shared_heap^;
        IFEND;
        osp$set_status_abnormal ('CL', cle$var_already_created, name, status);
        RETURN;
      IFEND;
    IFEND;

    ALLOCATE descriptor: [[REP #SIZE (local_type_specification^) OF cell]] IN osv$task_shared_heap^;
    descriptor^.header := descriptor_header;
    descriptor^.type_specification := local_type_specification^;

    complete_variable_access (local_access_mode, local_class, descriptor, NIL, declarer_variable_access);
    IF declarer_block <> xref_block THEN
      complete_variable_access (local_access_mode, clc$xrefed_variable, descriptor, NIL,
            xref_variable_access);
    IFEND;

  PROCEND internal_create_environment_var;
?? TITLE := 'internal_create_procedure_var', EJECT ??

  PROCEDURE internal_create_procedure_var
    (    name: clt$variable_name;
         access_mode: clt$data_access_mode;
         evaluation_method: clt$expression_eval_method;
         type_specification: ^clt$type_specification;
         scope: clt$procedure_variable_scope;
         type_description: ^clt$type_description;
         initial_value: ^clt$data_value;
     VAR return_variable_value {input, output} : conversion_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR status: ost$status);

    VAR
      allowed_classes: clt$internal_variable_classes,
      block: ^clt$block,
      class: clt$internal_variable_class,
      declarer_type_description: clt$type_description,
      descriptor: ^clt$variable_descriptor,
      descriptor_header: clt$variable_descriptor_header,
      hash: clt$variable_name_hash,
      hashed_name: clt$variable_name,
      ignore_associated_utility: boolean,
      inherited_allowed_class: clt$internal_variable_classes,
      inherited_block: ^clt$block,
      type_conformance: clt$type_conformance,
      variable_access: ^clt$variable_access,
      variable_access_info: ^clt$variable_access_info,
      variable_block: ^clt$block;


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

    allowed_classes := $clt$internal_variable_classes [clc$xdcled_variable, clc$env_variable,
          clc$lib_variable, clc$pushed_variable, clc$xrefed_variable];
    find_first_var_creation_block (allowed_classes, inherited_allowed_class, inherited_block, block);
    clp$compute_variable_name_hash (name, hashed_name, hash);

    IF scope = clc$xref_scope THEN
      variable_block := block;

    /find_declarer_variable/
      BEGIN

      /find_var_block/
        WHILE TRUE DO
          IF variable_block = NIL THEN
            EXIT /find_var_block/;
          IFEND;

          clp$find_variable_access (name, hashed_name, hash, allowed_classes, variable_block,
                variable_access_info);
          IF variable_access_info <> NIL THEN
            EXIT /find_declarer_variable/;
          IFEND;

          clp$find_next_var_block (allowed_classes, inherited_allowed_class, inherited_block, variable_block,
                ignore_associated_utility);

        WHILEND /find_var_block/;
        osp$set_status_abnormal ('CL', cle$unknown_variable, name, status);
        RETURN;
      END /find_declarer_variable/;

      IF (variable_access_info^.access_mode = clc$read_only) AND (access_mode = clc$read_write) THEN
        osp$set_status_abnormal ('CL', cle$bad_variable_access_mode, name, status);
        RETURN;
      IFEND;

      descriptor := variable_access_info^.descriptor;
      clp$convert_type_spec_to_desc (^descriptor^.type_specification, work_area, declarer_type_description,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$evaluate_type_conformance (type_description, ^declarer_type_description, clc$identical_types,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      descriptor_header := descriptor^.header;
      class := clc$xrefed_variable;
    ELSE
      descriptor_header.access_count := 0;
      descriptor_header.evaluation_method := evaluation_method;
      descriptor_header.value := NIL;
      descriptor_header.library := NIL;

      initialize_variable_value (name, initial_value, type_description, work_area, descriptor_header, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF scope = clc$xdcl_scope THEN
        class := clc$xdcled_variable;
      ELSE
        class := clc$proc_variable;
      IFEND;
    IFEND;

    IF return_variable_value.converted THEN
      clp$convert_int_to_var_value (descriptor_header.value, return_variable_value.max_string_size,
            return_variable_value.converted_value, status);
      IF NOT status.normal THEN
        IF (scope <> clc$xref_scope) AND (descriptor_header.value <> NIL) THEN
          clv$total_variable_allocation := clv$total_variable_allocation - #SIZE (descriptor_header.value^);
          FREE descriptor_header.value IN osv$task_shared_heap^;
        IFEND;
        RETURN;
      IFEND;
    IFEND;

    clp$add_variable_to_tree (hashed_name, hash, class, block^.variables, variable_access);

{ A variable already exists by the same name in the block.

    IF variable_access = NIL THEN
      osp$set_status_abnormal ('CL', cle$var_already_created, name, status);
      IF (scope <> clc$xref_scope) AND (descriptor_header.value <> NIL) THEN
        clv$total_variable_allocation := clv$total_variable_allocation - #SIZE (descriptor_header.value^);
        FREE descriptor_header.value IN osv$task_shared_heap^;
      IFEND;
      RETURN;
    IFEND;

    IF descriptor = NIL THEN
      ALLOCATE descriptor: [[REP #SIZE (type_specification^) OF cell]] IN osv$task_shared_heap^;
      descriptor^.header := descriptor_header;
      descriptor^.type_specification := type_specification^;
    IFEND;
    complete_variable_access (access_mode, class, descriptor, NIL, variable_access);

  PROCEND internal_create_procedure_var;
?? TITLE := 'variable_abort_handler', EJECT ??

  PROCEDURE variable_abort_handler
    (    condition: pmt$condition;
         ignore_condition_information: ^pmt$condition_information;
         ignore_save_area: ^ost$stack_frame_save_area;
     VAR handler_status: ost$status);


    osp$clear_job_signature_lock (clv$variable_access_lock);

  PROCEND variable_abort_handler;
*IFEND

MODEND clm$variable_storage_manager;
