?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Environment Object Manager' ??
MODULE clm$environment_object_manager;

{
{ PURPOSE:
{   This module contains the tables that describe SCL "environment objects,"
{   CLV$ENVIRONMENT_OBJECT_DESCS and CLV$ENVIRONMENT_OBJECT_NAMES, and the
{   procedures that manage those environment objects.
{
{ NOTE:
{   The procedures in this module are common to all environment objects and
{   contain no "special case" code for any object.
{

*IF NOT $true(osv$unix)
{
{ WHAT IS AN ENVIRONMENT OBJECT?
{
{   An "environment object" is a named data item or structure that forms
{   part of a job's command environment.  Typical environment objects are the
{   working catalog, the preferred natural language for messages and the
{   command list.  What distinguishes an environment object from an "ordinary"
{   data item or structure is its ability to be "pushed" and "popped," i.e.
{   to have a "local copy" made of itself within a particular context, make
{   changes to that copy, and have the original state of the object restored
{   either by explicit request or when the context is exited.
{
{   An environment object typically has associated with it a command to change
{   its value, a command to display its value, and a function to return its
{   value.  Also, typically program interfaces are provided to interrogate and
{   change the object.
{
{   In addition to these "standard" environment objects, all SCL variables with
{   a scope of ENVIRONMENT (or any of its derivitives, e.g. JOB) can be treated
{   as environment objects, in the sense that they can be explicitly "pushed"
{   and "popped."
{

{
{ HOW TO IMPLEMENT AN ENVIRONMENT OBJECT:
{
{   Externally an environment object is known by a name.  Normally there is
{   only one name for an environment object; but occasionally an object is
{   redefined to an extent that its original name no longer acurately describes
{   it.  When this occurs, a new name is given to the object but its original
{   name is retained as an alias.  The names of the environment objects are
{   declared as constants in deck CLT$ENVIRONMENT_OBJECT.
{
{   Internally an implemented environment object is known by an ordinal
{   constant of type CLT$ENVIRONMENT_OBJECT_ORDINAL.  The correspondence
{   between the names (and aliases) of the objects and their ordinals is
{   defined in the variable CLV$ENVIRONMENT_OBJECT_NAMES, declared later in
{   this module.  This table defines the NAMEs of each the objects, whether
{   an object is IMPLEMENTED and, if it is, what its ORDINAL is.
{
{   Implemented environment objects are described to SCL in the variable
{   CLV$ENVIRONMENT_OBJECT_DESCS, also declared later in this module.  Each
{   entry in this table contains the index of the "nominal" name (NAME_INDEX)
{   of the object in the CLV$ENVIRONMENT_OBJECT_NAMES variable and pointers to
{   the procedures provided by the implementor of the object and called by the
{   environment object management routines under appropriate circumstances.
{
{   The SCL Interpreter provides a common protocol for handling the "pushing"
{   and "popping" for environment objects.  The implementor of an environment
{   object MUST call the CLP$FIND_ENVIRONMENT_OBJECT interface whenever it
{   needs to manipulate that object outside the context of the procedures
{   pointed to from the CLV$ENVIRONMENT_OBJECT_DESCS table.
{
{   An enironment object is always accessed via a pointer to cell, therefore
{   the implementor of a particular environment object must map this generic
{   pointer to a pointer of the appropriate type for the object.
{
{
{   The procedures provided by the implementor of an environment object that
{   are used by the environment object management routines are described below.
{   A SIZE_OF_OBJECT function and an INITIALIZE_OBJECT procedure must be
{   provided for an object.  All of the other procedures are optional, i.e.
{   their pointers may be NIL.
{
{
{   The SIZE_OF_OBJECT function returns the size (in CELLs) of the environment
{ object.  It is called once during job initialization; therefore the size of
{ an object, as known to the environment object management routines, cannot
{ change.
{
{       SIZE_OF_OBJECT: SIZE
{
{ This function has no parameters.
{
{
{   The INITIALIZE_OBJECT procedure is used to supply an initial value in a
{ job for an environment object.  The implementor of each environment object
{ must provide an INITIALIZE_OBJECT procedure which will be called during job
{ initialization.
{
{   This procedure should not do anything that depends on any other environment
{ object either directly or indirectly.  The initialization performed by this
{ procedure should be analogous to what could be done statically, at compile
{ time.
{
{       INITIALIZE_OBJECT (OBJECT)
{
{ OBJECT (input) :  This parameter points to the object to be initialized.
{
{
{   The PUSH_OBJECT procedure is used to perform the object-specific portion
{ of a "push" operation.  This procedure is passed a pointer to the new
{ instance of the object (which is a copy of the pushed instance), and is
{ responsible for performing any additional actions needed to copy a "complex"
{ object or otherwise complete the "push."
{
{   If this procedure is not provided for an object, all that happens for a "push"
{ operation is that the object is copied.
{
{       PUSH_OBJECT (PUSH_REASON, NEW_OBJECT, NEW_OBJECT_IN_CURRENT_TASK,
{             PUSHED_OBJECT_IN_CURRENT_TASK, PUSHED_OBJECT, STATUS)
{
{ PUSH_REASON (input) :  This parameter specifies the reason for the "push"
{       operation.
{
{       CLC$EO_PUSH_REQUESTED:  This indicates that the push resulted from
{             an explicit request.
{
{       CLC$EO_PUSH_FOR_TASK:  This indicates that the push is being done
{             automatically on behalf of a new asynchronous task by its parent
{             task.
{
{ NEW_OBJECT (input) :  This parameter points to the new instance of the
{       object.
{
{ NEW_OBJECT_IN_CURRENT_TASK (input) :  This parameter indicates whether the
{       new instance of the object resides in a block owned by the current
{       task.  (It is always FALSE when PUSH_REASON is CLC$EO_PUSH_FOR_TASK.)
{
{ PUSHED_OBJECT_IN_CURRENT_TASK (input) :  This parameter indicates whether the
{       pushed instance of the object resides in a block owned by the current
{       task.  (It is always FALSE when PUSH_REASON is CLC$EO_PUSH_FOR_TASK.)
{
{ PUSHED_OBJECT (input) :  This parameter points to the pushed instance of the
{       object.
{
{ STATUS (output) :  This parameter specifies the request status.
{
{
{   The POP_OBJECT procedure is used to perform the object-specific part of a
{ "pop" operation.  This procedure is passed a pointer to the instance of the
{ object being popped, as well as a pointer to the pushed instance.  It is
{ responsible for performing any additional actions needed to delete a "complex"
{ object and/or do any needed synchronizing activities.
{
{   If this procedure is not provided for an object, all that happens for a "pop"
{ operation is that the object is deleted.
{
{       POP_OBJECT (POP_REASON, OBJECT, OBJECT_IN_CURRENT_TASK,
{             PUSHED_OBJECT_IN_CURRENT_TASK, PUSHED_OBJECT, STATUS)
{
{ POP_REASON (input) :  This parameter specifies the reason for the "pop"
{       operation.
{
{       CLC$EO_POP_REQUESTED:  This indicates that the pop resulted from an
{             explicit request.
{
{       CLC$EO_POP_FOR_BLOCK:  This indicates that the pop is being done
{             automatically because the block containing its definition is
{             being popped.
{
{       CLC$EO_POP_FOR_TASK:  This indicates that the pop is being done
{             automatically because the block containing its definition belongs
{             to a task that has terminated and is being done by the parent of
{             of that task.
{
{       CLC$EO_POP_FOR_CLEANUP:  This indicates that the pop is being done
{             automatically as part of cleaning up an unsuccessful attempt to
{             create a new (asynchronous task) block by that task's parent.
{
{ OBJECT (input) :  This parameter points to the instance of the object being
{       popped.
{
{ OBJECT_IN_CURRENT_TASK (input) :  This parameter indicates whether the
{       instance of the object being popped resides in a block owned by the
{       current task.  (It is always FALSE when POP_REASON is
{       CLC$EO_POP_FOR_CLEANUP.)
{
{ PUSHED_OBJECT_IN_CURRENT_TASK (input) :  This parameter indicates whether the
{       pushed instance of the object resides in a block owned by the current
{       task.  (It is always FALSE when POP_REASON is CLC$EO_POP_FOR_CLEANUP or
{       when OBJECT is in an asynchronous task block.)
{
{ PUSHED_OBJECT (input) :  This parameter points to the instance of the object
{       that was pushed and will become the current instance as a result of the
{       "pop".  (It is always NIL when POP_REASON is CLC$EO_POP_FOR_CLEANUP or
{       when OBJECT is in an asynchronous task block.)
{
{ STATUS (output) :  This parameter specifies the request status.
{
{
{   The UPDATE_AFTER_TASK_TERMINATION procedure is used to to any needed
{ synchronizing activities for an environment object after a task has
{ terminated.
{
{   If this procedure is not provided for an object, no action is taken for the
{ object when a task terminates.
{
{       UPDATE_AFTER_TASK_TERMINATION (SYNCHRONOUS_WITH_PARENT,
{             SYNCHRONOUS_WITH_JOB, CURRENT_OBJECT,
{             CURRENT_OBJECT_IN_CURRENT_TASK, STATUS)
{
{ SYNCHRONOUS_WITH_PARENT (input) :  This parameter indicates whether the task
{       that terminated was running synchronously with respect to its parent
{       task.
{
{ SYNCHRONOUS_WITH_JOB (input) :  This parameter indicates whether the task
{       that terminated was running synchronously with respect to the job.
{
{ CURRENT_OBJECT (input) :  This parameter points to the current instance of
{       the object.
{
{ CURRENT_OBJECT_IN_CURRENT_TASK (input) :  This parameter indicates whether
{       the current instance of the object resides in a block owned by the
{       current task (the parent of the task that terminated).
{
{ STATUS (output) :  This parameter specifies the request status.
{
*IFEND

?? NEWTITLE := 'Global Declarations', EJECT ??
*copyc clt$environment_object
*copyc clt$environment_object_contents
*copyc clt$environment_object_location
*copyc clt$environment_object_ordinal
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_control_statement
*copyc cle$not_yet_implemented
*copyc cle$unknown_variable
*IF NOT $true(osv$unix)
*copyc cle$var_already_created
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc oss$task_shared
*ELSE
*copyc ost$status_message_level
*copyc clp$eo_init_command_list
*copyc clp$eo_size_command_list
*copyc osv$task_shared_heap
*copyc clt$environment_object_size
*copyc clp$find_current_block
*copyc clt$block
?? TITLE := 'osp$eo_size_message_level', EJECT ??

  FUNCTION [XDCL] osp$eo_size_message_level: clt$environment_object_size;


    osp$eo_size_message_level := #SIZE (ost$status_message_level);

  FUNCEND osp$eo_size_message_level;
?? TITLE := 'osp$eo_init_message_level', EJECT ??

  PROCEDURE [XDCL] osp$eo_init_message_level
    (    object: ^clt$environment_object_contents);

    VAR
      status_message_level: ^ost$status_message_level;


    status_message_level := object;
    status_message_level^ := osc$full_message_level;

  PROCEND osp$eo_init_message_level;
*IFEND
*copyc ost$status
?? SKIP := 3 ??

{
{ PURPOSE:
{   The following procedure exists solely to provide a "shelter" for the
{   declarations contained in certain decks that are *COPYC'd into this
{   deck.  For example, this module defines an XDCL'd variable that is
{   referenced by an INLINE procedure.  In order to make the deck containing
{   the INLINE procedure "self-contained" it *COPYCs the deck containing the
{   XREF declaration of the variable.  Since the INLINE procedure is needed
{   in this module, both the XDCL and XREF declaration will appear in this
{   module.  The following "dummy" procedure is used to hide the XREF
{   declaration of the variable from the rest of the module.
{

  PROCEDURE [INLINE] dummy;

*copyc clp$find_env_object_first_time
*copyc clv$environment_object_location

  PROCEND dummy;
?? SKIP := 3 ??
*IF NOT $true(osv$unix)
*copyc clp$eo_init_command_list
*copyc clp$eo_init_file_connections
*copyc clp$eo_init_scl_options
*copyc clp$eo_init_unseen_mail_action
*copyc clp$eo_init_working_catalog
*copyc clp$eo_pop_command_list
*copyc clp$eo_pop_file_connections
*copyc clp$eo_pop_unseen_mail_action
*copyc clp$eo_pop_working_catalog
*copyc clp$eo_push_command_list
*copyc clp$eo_push_file_connections
*copyc clp$eo_push_working_catalog
*copyc clp$eo_size_command_list
*copyc clp$eo_size_file_connections
*copyc clp$eo_size_scl_options
*copyc clp$eo_size_unseen_mail_action
*copyc clp$eo_size_working_catalog
*copyc clp$eo_updt_command_list
*copyc clp$eo_updt_unseen_mail_action
*copyc osp$eo_init_interaction_info
*copyc osp$eo_init_message_level
*copyc osp$eo_init_natural_language
*copyc osp$eo_size_interaction_info
*copyc osp$eo_size_message_level
*copyc osp$eo_size_natural_language
*copyc pmp$eo_init_program_attributes
*copyc pmp$eo_pop_program_attributes
*copyc pmp$eo_push_program_attributes
*copyc pmp$eo_size_program_attributes
?? POP ??
*copyc clp$create_var_from_type_spec
*copyc clp$find_current_block
*copyc clp$find_environment_object
*copyc clp$get_work_area
*copyc clp$internal_delete_variable
*copyc clp$validate_name
*copyc i#move
*copyc i#fill
*copyc osp$set_status_abnormal
*copyc osv$task_shared_heap
*ELSE
*copyc osp$eo_init_interaction_info
*copyc osp$eo_size_interaction_info
*IFEND
?? OLDTITLE ??
?? NEWTITLE := 'Local Declarations', EJECT ??

{
{ CLC$EO_IMPLEMENTED represents the number of implemented environemnt objects.
{
{ NOTE: If the CLT$ENVIRONMENT_OBJECT_ORDINAL type is changed such that there
{ is a new "uppervalue," the definition of CLC$EO_IMPLEMENTED must be updated.
{

  CONST
*IF NOT $true(osv$unix)
    clc$eo_implemented = $INTEGER (clc$eo_working_catalog) + 1;
*ELSE
    clc$eo_implemented = $INTEGER (clc$eo_message_level) + 1;
*IFEND

{
{ CLC$EO_NOT_IMPLEMENTED represents the number of unimplemented environemnt
{ objects.
{

  CONST
*IF NOT $true(osv$unix)
    clc$eo_not_implemented = 4;
*ELSE
    clc$eo_not_implemented = 0;
*IFEND

{
{ CLC$EO_ALIASES represents the number of alias names for environemnt objects.
{ Such aliases arise when an environment object is renamed (for whatever
{ reason) and the old name is retained as an alias for the new.
{

  CONST
*IF NOT $true(osv$unix)
    clc$eo_aliases = 1;
*ELSE
    clc$eo_aliases = 0;
*IFEND

*IF NOT $true(osv$unix)
{
{ The following constant defines the alias for the INTERACTION_INFORMATION
{ environment object.
{

  CONST
    clc$old_interaction_style = 'INTERACTION_STYLE              ';

*IFEND
{
{ CLC$EO_DEFINED_NAMES represents the number of defined names for environemnt
{ objects.
{

  CONST
    clc$eo_defined_names = clc$eo_implemented + clc$eo_not_implemented + clc$eo_aliases;

{
{ The following type is used for indices (offsets) into the CLT$ENVIRONMENT_OBJECT_INFO.CONTENTS array and
{ for the total size of that array.
{

  TYPE
    clt$environment_object_index = 0 .. 0ffff(16);

?? OLDTITLE ??
?? NEWTITLE := 'clv$environment_object_names', EJECT ??

{
{ The CLV$ENVIRONMENT_OBJECT_NAMES table contains an entry for each defined
{ environment object.  Each entry contains the object's NAME (or an alias),
{ a boolean indicating whether the object is IMPLEMENTED and, if it is, its
{ ORDINAL.
{
{ This table must be maintained in alphabetical order by name.
{

?? FMT (FORMAT := OFF) ??

  VAR
*IF NOT $true(osv$unix)
    clv$environment_object_names: [STATIC, READ, oss$job_paged_literal]
*ELSE
    clv$environment_object_names: [STATIC, READ]
*IFEND
          array [1 .. clc$eo_defined_names] of record
            name: clt$environment_object,
            case implemented: boolean of
            = FALSE =
              ,
            = TRUE =
              ordinal: clt$environment_object_ordinal,
            casend,
          recend := [

*IF NOT $true(osv$unix)
          [clc$attach_file_defaults,        FALSE],
          [clc$command_list,                TRUE, clc$eo_command_list],
          [clc$file_attribute_defaults,     FALSE],
          [clc$file_connections,            TRUE, clc$eo_file_connections],
          [clc$interaction_information,     TRUE, clc$eo_interaction_information],
          [clc$old_interaction_style,       TRUE, clc$eo_interaction_information],
          [clc$link_attributes,             FALSE],
          [clc$message_level,               TRUE, clc$eo_message_level],
          [clc$message_receipt_action,      FALSE],
          [clc$natural_language,            TRUE, clc$eo_natural_language],
          [clc$program_attributes,          TRUE, clc$eo_program_attributes],
          [clc$scl_options,                 TRUE, clc$eo_scl_options],
          [clc$unseen_mail_action,          TRUE, clc$eo_unseen_mail_action],
          [clc$working_catalog,             TRUE, clc$eo_working_catalog]];
*ELSE
          [clc$command_list,                TRUE, clc$eo_command_list],
          [clc$interaction_information,     TRUE, clc$eo_interaction_information],
          [clc$message_level,               TRUE, clc$eo_message_level]];
*IFEND

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
?? NEWTITLE := 'clv$environment_object_descs', EJECT ??

{
{ The CLV$ENVIRONMNT_OBJECT_DESCS table describes the specifics for all of the
{ implemented environment objects.  Each entry contains the NAME_INDEX into the
{ CLV$ENVIRONMENT_OBJECT_NAMES table (in order to be able to determine an
{ object's name given its ordinal) and pointers to the procedures (described in
{ the commentary at the beginning of this module) for the particular objects.
{

?? FMT (FORMAT := OFF) ??

  VAR
*IF NOT $true(osv$unix)
    clv$environment_object_descs: [STATIC, READ, oss$job_paged_literal]
*ELSE
    clv$environment_object_descs: [STATIC, READ]
*IFEND
          array [clt$environment_object_ordinal] of record
            name_index: 1 .. clc$eo_defined_names,
            size_of_object: ^function: clt$environment_object_size,
            initialize_object: ^procedure
                  (    object: ^clt$environment_object_contents),
*IF NOT $true(osv$unix)
            push_object: ^procedure
                  (    push_reason: clt$env_object_push_reason;
                       new_object: ^clt$environment_object_contents;
                       new_object_in_current_task: boolean;
                       pushed_object_in_current_task: boolean;
                       pushed_object: ^clt$environment_object_contents;
                   VAR status: ost$status),
            pop_object: ^procedure
                  (    pop_reason: clt$env_object_pop_reason;
                       object: ^clt$environment_object_contents;
                       object_in_current_task: boolean;
                       pushed_object_in_current_task: boolean;
                       pushed_object: ^clt$environment_object_contents;
                   VAR status: ost$status),
            update_after_task_termination: ^procedure
                  (    synchronous_with_parent: boolean;
                       synchronous_with_job: boolean;
                       current_object: ^clt$environment_object_contents;
                       current_object_in_current_task: boolean;
                   VAR status: ost$status),
*IFEND
          recend := [

*IF NOT $true(osv$unix)
          { attach_file_defaults            } { 1, *** NOT IMPLEMENTED }
          { command_list                    } [ 2,
                                              ^clp$eo_size_command_list,
                                              ^clp$eo_init_command_list,
                                              ^clp$eo_push_command_list,
                                              ^clp$eo_pop_command_list,
                                              ^clp$eo_updt_command_list],
          { file_attribute_defaults         } { 3, *** NOT IMPLEMENTED }
          { file_connections                } [ 4,
                                              ^clp$eo_size_file_connections,
                                              ^clp$eo_init_file_connections,
                                              ^clp$eo_push_file_connections,
                                              ^clp$eo_pop_file_connections,
                                              NIL],
          { interaction_information         } [ 5,
                                              ^osp$eo_size_interaction_info,
                                              ^osp$eo_init_interaction_info,
                                              NIL,
                                              NIL,
                                              NIL],
          { link_attributes                 } { 7, *** NOT IMPLEMENTED }
          { message_level                   } [ 8,
                                              ^osp$eo_size_message_level,
                                              ^osp$eo_init_message_level,
                                              NIL,
                                              NIL,
                                              NIL],
          { message_receipt_action          } { 9, *** NOT IMPLEMENTED }
          { natural_language                } [10,
                                              ^osp$eo_size_natural_language,
                                              ^osp$eo_init_natural_language,
                                              NIL,
                                              NIL,
                                              NIL],
          { program_attributes              } [11,
                                              ^pmp$eo_size_program_attributes,
                                              ^pmp$eo_init_program_attributes,
                                              ^pmp$eo_push_program_attributes,
                                              ^pmp$eo_pop_program_attributes,
                                              NIL],
          { scl_options                     } [12,
                                              ^clp$eo_size_scl_options,
                                              ^clp$eo_init_scl_options,
                                              NIL,
                                              NIL,
                                              NIL],
          { unseen_mail_action              } [13,
                                              ^clp$eo_size_unseen_mail_action,
                                              ^clp$eo_init_unseen_mail_action,
                                              NIL,
                                              ^clp$eo_pop_unseen_mail_action,
                                              ^clp$eo_updt_unseen_mail_action],
          { working_catalog                 } [14,
                                              ^clp$eo_size_working_catalog,
                                              ^clp$eo_init_working_catalog,
                                              ^clp$eo_push_working_catalog,
                                              ^clp$eo_pop_working_catalog,
                                              NIL]];
*ELSE
          { command_list                    } [ 1,
                                              ^clp$eo_size_command_list,
                                              ^clp$eo_init_command_list],
          { interaction_information         } [ 5,
                                              ^osp$eo_size_interaction_info,
                                              ^osp$eo_init_interaction_info],
          { message_level                   } [ 2,
                                              ^osp$eo_size_message_level,
                                              ^osp$eo_init_message_level]];
*IFEND

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
?? NEWTITLE := 'clv$environment_object_location', EJECT ??

{
{ The CLV$ENVIRONMENT_OBJECT_LOCATION table is used to optimize access to the
{ environment objects within a task.  Each task has its own copy of this table.
{ The OBJECT field points to the current instance of the object and the
{ OBJECT_IN_CURRENT_TASK field indicates whether the current instance of the
{ object is in a block owned by the task which owns the table.  If the OBJECT
{ field is NIL, the current instance of the object must be located by searching
{ the block stack for it.
{

  VAR
*IF NOT $true(osv$unix)
    clv$environment_object_location: [XDCL, #GATE, oss$task_private] clt$environment_object_location :=
*ELSE
    clv$environment_object_location: [XDCL, #GATE] clt$environment_object_location :=
*IFEND
          [REP clc$eo_implemented of [NIL, * ]];

?? OLDTITLE ??
?? NEWTITLE := 'clv$environment_object_slices', EJECT ??

{
{ The CLV$ENVIRONMENT_OBJECT_SLICES table is used to hold the indices and cell
{ count of the data for the environment objects within the CONTENTS field of a
{ CLT$ENVIRONMENT_OBJECTS_INFO record.  These are determined during job
{ initialization via calls to the SIZE_OF_OBJECTS functions defined for each
{ environment object.
{

  VAR
*IF NOT $true(osv$unix)
    clv$environment_object_slices: [STATIC, oss$task_shared] array [clt$environment_object_ordinal] of record
*ELSE
    clv$environment_object_slices: [STATIC] array [clt$environment_object_ordinal] of record
*IFEND
      index: clt$environment_object_index,
      size: clt$environment_object_size,
    recend;

?? OLDTITLE ??
?? NEWTITLE := 'clv$environment_objects_size', EJECT ??

{
{ The CLV$ENVIRONMENT_OBJECTS_SIZE variable is used to hold the total number of
{ cells needed for the CONTENTS field of a CLT$ENVIRONMENT_OBJECTS_INFO
{ record.  This value is determined during job initialization via calls to the
{ SIZE_OF_OBJECTS functions defined for each environment object.
{

  VAR
*IF NOT $true(osv$unix)
    clv$environment_objects_size: [STATIC, oss$task_shared] clt$environment_object_index;
*ELSE
    clv$environment_objects_size: [STATIC] clt$environment_object_index;
*IFEND

?? OLDTITLE ??
?? NEWTITLE := 'clp$environment_object_in_block', EJECT ??

{
{ PURPOSE:
{   This function is used to locate an environment object in a particular
{   block.
{

  FUNCTION [XDCL] clp$environment_object_in_block
    (    object_ordinal: clt$environment_object_ordinal;
         block: ^clt$block): ^clt$environment_object_contents;


    IF (block^.environment_object_info = NIL) OR (NOT block^.environment_object_info^.
          defined [object_ordinal]) THEN
      clp$environment_object_in_block := NIL;
    ELSE
      clp$environment_object_in_block := ^block^.environment_object_info^.
            contents [clv$environment_object_slices [object_ordinal].index];
    IFEND;

  FUNCEND clp$environment_object_in_block;
?? OLDTITLE ??
?? NEWTITLE := 'clp$environment_object_name', EJECT ??

{
{ PURPOSE:
{   This function is used to get the name of an environment object given its
{   ordinal.
{

  FUNCTION [XDCL, #GATE] clp$environment_object_name
    (    object_ordinal: clt$environment_object_ordinal): ^clt$environment_object;


    clp$environment_object_name := ^clv$environment_object_names
          [clv$environment_object_descs [object_ordinal].name_index].name;

  FUNCEND clp$environment_object_name;
?? OLDTITLE ??
?? NEWTITLE := 'clp$find_env_object_first_time', EJECT ??

{
{ PURPOSE:
{   This procedure is used by CLP$FIND_ENVIRONMENT_OBJECT to search for
{   an object in the block stack when its entry in the requesting tasks'
{   CLV$ENVIRONMENT_OBJECT_LOCATION table is NIL.  It stores the location
{   information in that table as well as returning it to its caller.
{

  PROCEDURE [XDCL, #GATE] clp$find_env_object_first_time
    (    object_ordinal: clt$environment_object_ordinal;
     VAR object_in_current_task: boolean;
     VAR object: ^clt$environment_object_contents);

    VAR
      block: ^clt$block;


    find_block_containing_object (object_ordinal, block, clv$environment_object_location [object_ordinal].
          object_in_current_task);

    clv$environment_object_location [object_ordinal].object := ^block^.environment_object_info^.
          contents [clv$environment_object_slices [object_ordinal].index];

    object := clv$environment_object_location [object_ordinal].object;
    object_in_current_task := clv$environment_object_location [object_ordinal].object_in_current_task;

  PROCEND clp$find_env_object_first_time;
?? OLDTITLE ??
?? NEWTITLE := 'clp$init_all_environment', EJECT ??

{
{ PURPOSE:
{   This procedure is called during job initialization to get the initial
{   "values" for all of the environment objects.
{
{ DESIGN:
{   The SIZE_OF_OBJECT function for each object is called to initialize the
{   CLV$ENVIRONMENT_OBJECT_SLICES and CLV$ENVIRONMENT_OBJECTS_SIZE variables
{   for the job.  Then space is allocated space for the job block's
{   ENVIRONMENT_OBJECT_INFO.  Finally the INITIALIZE_OBJECT procedure is
{   called for each object.
{
{ NOTE:
{   Subrange checking is forced on for this procedure in order to more easily
{   detect a bad size returned for a particular environment object.
{

?? PUSH (CHKRNG := ON) ??

  PROCEDURE [XDCL] clp$init_all_environment
    (VAR environment_object_info: ^clt$environment_object_info);

    VAR
      i: clt$environment_object_ordinal,
      object: ^clt$environment_object_contents;


    clv$environment_objects_size := 0;

    FOR i := LOWERVALUE (clt$environment_object_ordinal) TO UPPERVALUE (clt$environment_object_ordinal) DO
      clv$environment_object_slices [i].index := clv$environment_objects_size;
      clv$environment_object_slices [i].size := clv$environment_object_descs [i].size_of_object^ ();
      clv$environment_objects_size := clv$environment_objects_size + clv$environment_object_slices [i].size;
    FOREND;

    ALLOCATE environment_object_info: [0 .. clv$environment_objects_size - 1] IN osv$task_shared_heap^;

    FOR i := LOWERVALUE (clt$environment_object_ordinal) TO UPPERVALUE (clt$environment_object_ordinal) DO
      environment_object_info^.defined [i] := TRUE;
      object := ^environment_object_info^.contents [clv$environment_object_slices [i].index];
      clv$environment_object_descs [i].initialize_object^ (object);
      clv$environment_object_location [i].object := object;
      clv$environment_object_location [i].object_in_current_task := TRUE;
    FOREND;

  PROCEND clp$init_all_environment;
?? POP ??
?? OLDTITLE ??
*IF NOT $true(osv$unix)
?? NEWTITLE := 'clp$pop_all_environment', EJECT ??

{
{ PURPOSE:
{   This procedure is called to pop all environment objects in a block
{   and release the space they occupied.  It can be called when a block
{   is being popped within a task or when a task has terminated and all
{   of its blocks are being popped by its parent.
{

  PROCEDURE [XDCL, #GATE] clp$pop_all_environment
    (    pop_reason: clc$eo_pop_for_block .. clc$eo_pop_for_task;
         block: ^clt$block);

    VAR
      i: clt$environment_object_ordinal,
      ignore_status: ost$status,
      popped_object: ^clt$environment_object_contents,
      popped_object_in_current_task: boolean,
      pushed_object: ^clt$environment_object_contents,
      pushed_object_in_current_task: boolean;


    IF block^.environment_object_info = NIL THEN
      RETURN;
    IFEND;

    popped_object_in_current_task := pop_reason = clc$eo_pop_for_block;

    FOR i := LOWERVALUE (clt$environment_object_ordinal) TO UPPERVALUE (clt$environment_object_ordinal) DO
      IF block^.environment_object_info^.defined [i] THEN
        popped_object := ^block^.environment_object_info^.contents [clv$environment_object_slices [i].index];
        block^.environment_object_info^.defined [i] := FALSE;

        find_pushed_object (i, block, popped_object_in_current_task, pushed_object,
              pushed_object_in_current_task);

        IF popped_object_in_current_task THEN
          clv$environment_object_location [i].object := pushed_object;
          clv$environment_object_location [i].object_in_current_task := pushed_object_in_current_task;
        IFEND;

        IF clv$environment_object_descs [i].pop_object <> NIL THEN
          clv$environment_object_descs [i].pop_object^ (pop_reason, popped_object,
                popped_object_in_current_task, pushed_object_in_current_task, pushed_object, ignore_status);
        IFEND;
      IFEND;
    FOREND;

    FREE block^.environment_object_info IN osv$task_shared_heap^;

  PROCEND clp$pop_all_environment;
?? OLDTITLE ??
?? NEWTITLE := 'clp$pop_environment', EJECT ??
*copyc clh$pop_environment

  PROCEDURE [XDCL, #GATE] clp$pop_environment
    (    object: clt$environment_object;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      name_is_valid: boolean,
      object_implemented: boolean,
      object_name: ost$name,
      object_name_found: boolean,
      object_ordinal: clt$environment_object_ordinal,
      popped_object: ^clt$environment_object_contents,
      popped_object_in_current_task: boolean,
      pushed_object: ^clt$environment_object_contents,
      pushed_object_in_current_task: boolean;


    status.normal := TRUE;

    clp$validate_name (object, object_name, name_is_valid);
    IF NOT name_is_valid THEN
      osp$set_status_abnormal ('CL', cle$improper_env_object_name, object, status);
      RETURN;
    IFEND;

    search_environment_object_names (object_name, object_ordinal, object_implemented, object_name_found);

    IF NOT object_name_found THEN
      clp$internal_delete_variable (object_name, $clt$internal_variable_classes [clc$pushed_variable],
            status);
      IF (NOT status.normal) AND (status.condition = cle$unknown_variable) THEN
        osp$set_status_abnormal ('CL', cle$no_object_to_pop, object, status);
      IFEND;
      RETURN;

    ELSEIF NOT object_implemented THEN
      osp$set_status_abnormal ('CL', cle$not_yet_implemented, object, status);
      RETURN;
    IFEND;

    find_block_containing_object (object_ordinal, block, popped_object_in_current_task);
    IF (block^.kind = clc$task_block) AND (NOT block^.synchronous_with_parent) THEN
      osp$set_status_abnormal ('CL', cle$no_object_to_pop, object, status);
      RETURN;
    IFEND;

    popped_object := ^block^.environment_object_info^.contents
          [clv$environment_object_slices [object_ordinal].index];
    block^.environment_object_info^.defined [object_ordinal] := FALSE;

    find_pushed_object (object_ordinal, block, popped_object_in_current_task, pushed_object,
          pushed_object_in_current_task);

    clv$environment_object_location [object_ordinal].object := pushed_object;
    clv$environment_object_location [object_ordinal].object_in_current_task := pushed_object_in_current_task;

    IF clv$environment_object_descs [object_ordinal].pop_object <> NIL THEN
      clv$environment_object_descs [object_ordinal].pop_object^
            (clc$eo_pop_requested, popped_object, popped_object_in_current_task,
            pushed_object_in_current_task, pushed_object, status);
    IFEND;

  PROCEND clp$pop_environment;
?? OLDTITLE ??
?? NEWTITLE := 'clp$push_all_environment', EJECT ??

{
{ PURPOSE:
{   This procedure is used to make a copy of all environment objects for a new
{   asynchronous task by that task's parent.
{

  PROCEDURE [XDCL, #GATE] clp$push_all_environment
    (    child_task_block: ^clt$block;
     VAR status: ost$status);

    VAR
      i: clt$environment_object_ordinal,
      ignore_object_in_current_task: boolean,
      ignore_status: ^ost$status,
      new_object: ^clt$environment_object_contents,
      pushed_object: ^clt$environment_object_contents;


    status.normal := TRUE;

    ALLOCATE child_task_block^.environment_object_info: [0 .. clv$environment_objects_size - 1] IN
          osv$task_shared_heap^;

  /push_objects/
    FOR i := LOWERVALUE (clt$environment_object_ordinal) TO UPPERVALUE (clt$environment_object_ordinal) DO
      clp$find_environment_object (i, pushed_object, ignore_object_in_current_task);

      child_task_block^.environment_object_info^.defined [i] := TRUE;
      new_object := ^child_task_block^.environment_object_info^.
            contents [clv$environment_object_slices [i].index];

      IF clv$environment_object_descs [i].push_object = NIL THEN
        i#move (pushed_object, new_object, clv$environment_object_slices [i].size);
      ELSE
        clv$environment_object_descs [i].push_object^ (clc$eo_push_for_task, new_object, FALSE, FALSE,
              pushed_object, status);
        IF NOT status.normal THEN
          child_task_block^.environment_object_info^.defined [i] := FALSE;
          EXIT /push_objects/;
        IFEND;
      IFEND;
    FOREND /push_objects/;

    IF status.normal THEN
      RETURN;
    IFEND;

    PUSH ignore_status;
    FOR i := LOWERVALUE (clt$environment_object_ordinal) TO i DO
      IF child_task_block^.environment_object_info^.defined [i] AND
            (clv$environment_object_descs [i].pop_object <> NIL) THEN
        clv$environment_object_descs [i].pop_object^ (clc$eo_pop_for_cleanup, new_object, FALSE, FALSE, NIL,
              ignore_status^);
      IFEND;
    FOREND;

  PROCEND clp$push_all_environment;
?? OLDTITLE ??
?? NEWTITLE := 'clp$push_environment', EJECT ??
*copyc clh$push_environment

  PROCEDURE [XDCL, #GATE] clp$push_environment
    (    object: clt$environment_object;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      i: clt$environment_object_ordinal,
      name_is_valid: boolean,
      new_object: ^clt$environment_object_contents,
      new_object_in_current_task: boolean,
      object_implemented: boolean,
      object_name: ost$name,
      object_name_found: boolean,
      object_ordinal: clt$environment_object_ordinal,
      original_work_area: ^clt$work_area,
      pushed_object: ^clt$environment_object_contents,
      pushed_object_in_current_task: boolean,
      work_area_ptr: ^^clt$work_area;


    status.normal := TRUE;

    clp$validate_name (object, object_name, name_is_valid);
    IF NOT name_is_valid THEN
      osp$set_status_abnormal ('CL', cle$improper_env_object_name, object, status);
      RETURN;
    IFEND;

    search_environment_object_names (object_name, object_ordinal, object_implemented, object_name_found);

    IF NOT object_name_found THEN
*IF NOT $true(osv$unix)
      clp$get_work_area (#RING (^work_area_ptr), work_area_ptr, status);
*ELSE
      clp$get_work_area (osc$user_ring, work_area_ptr, status);
*IFEND
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      original_work_area := work_area_ptr^;
      clp$create_var_from_type_spec (object_name, clc$push_scope, clc$read_write, clc$immediate_evaluation,
            NIL, NIL, TRUE, work_area_ptr^, status);
      IF NOT status.normal THEN
        IF status.condition = cle$var_already_created THEN
          osp$set_status_abnormal ('CL', cle$object_already_pushed, object, status);
        ELSEIF status.condition = cle$unknown_variable THEN
          osp$set_status_abnormal ('CL', cle$not_an_environment_object, object, status);
        IFEND;
      IFEND;
      work_area_ptr^ := original_work_area;
      RETURN;

    ELSEIF NOT object_implemented THEN
      osp$set_status_abnormal ('CL', cle$not_yet_implemented, object, status);
      RETURN;
    IFEND;

    find_environment_block (block, new_object_in_current_task);

    IF block^.environment_object_info = NIL THEN
      ALLOCATE block^.environment_object_info: [0 .. clv$environment_objects_size - 1] IN
            osv$task_shared_heap^;
      i#fill ($CHAR (0), ^block^.environment_object_info^.defined,
            #SIZE (block^.environment_object_info^.defined));
*if false
{Note: init the packed array once and move it would be again 10 times faster than the i#fill!

      FOR i := LOWERVALUE (clt$environment_object_ordinal) TO UPPERVALUE (clt$environment_object_ordinal) DO
        block^.environment_object_info^.defined [i] := FALSE;
      FOREND;
*ifend

    ELSEIF block^.environment_object_info^.defined [object_ordinal] THEN
      osp$set_status_abnormal ('CL', cle$object_already_pushed, object, status);
      RETURN;
    IFEND;

    clp$find_environment_object (object_ordinal, pushed_object, pushed_object_in_current_task);

    block^.environment_object_info^.defined [object_ordinal] := TRUE;
    new_object := ^block^.environment_object_info^.contents
          [clv$environment_object_slices [object_ordinal].index];

    clv$environment_object_location [object_ordinal].object := new_object;
    clv$environment_object_location [object_ordinal].object_in_current_task := new_object_in_current_task;

    IF clv$environment_object_descs [object_ordinal].push_object = NIL THEN
      i#move (pushed_object, new_object, clv$environment_object_slices [object_ordinal].size);
    ELSE
      clv$environment_object_descs [object_ordinal].push_object^
            (clc$eo_push_requested, new_object, new_object_in_current_task, pushed_object_in_current_task,
            pushed_object, status);
      IF NOT status.normal THEN
        block^.environment_object_info^.defined [object_ordinal] := FALSE;
        clv$environment_object_location [object_ordinal].object := pushed_object;
        clv$environment_object_location [object_ordinal].object_in_current_task :=
              pushed_object_in_current_task;
        RETURN;
      IFEND;
    IFEND;

  PROCEND clp$push_environment;
?? OLDTITLE ??
?? NEWTITLE := 'clp$update_all_environment', EJECT ??

{
{ PURPOSE:
{   This procedure is called by the parent task of a child task that has just
{   terminated to allow for any needed updating  or processing of state
{   information for the objects in the parent task.
{

  PROCEDURE [XDCL] clp$update_all_environment
    (    synchronous_with_parent: boolean;
         synchronous_with_job: boolean;
     VAR status: ost$status);

    VAR
      i: clt$environment_object_ordinal,
      local_status: ost$status,
      object: ^clt$environment_object_contents,
      object_in_current_task: boolean;


    status.normal := TRUE;

    FOR i := LOWERVALUE (clt$environment_object_ordinal) TO UPPERVALUE (clt$environment_object_ordinal) DO
      IF synchronous_with_parent THEN
        clv$environment_object_location [i].object := NIL;
      IFEND;

      IF clv$environment_object_descs [i].update_after_task_termination <> NIL THEN
        clp$find_environment_object (i, object, object_in_current_task);
        clv$environment_object_descs [i].update_after_task_termination^
              (synchronous_with_parent, synchronous_with_job, object, object_in_current_task, local_status);
        IF (NOT local_status.normal) AND status.normal THEN
          status := local_status;
        IFEND;
      IFEND;
    FOREND;

  PROCEND clp$update_all_environment;
?? OLDTITLE ??
*IFEND
?? NEWTITLE := 'find_block_containing_object', EJECT ??

{
{ PURPOSE:
{   This procedure searches the block stack to find a block containing the
{   definition of a specified environment object.
{

  PROCEDURE [INLINE] find_block_containing_object
    (    object_ordinal: clt$environment_object_ordinal;
     VAR block: ^clt$block;
     VAR block_in_current_task: boolean);


    clp$find_current_block (block);
    block_in_current_task := TRUE;

    WHILE (block <> NIL) AND ((block^.environment_object_info = NIL) OR
          (NOT block^.environment_object_info^.defined [object_ordinal])) DO
      IF block^.kind = clc$task_block THEN
        block_in_current_task := FALSE;
        IF NOT block^.synchronous_with_parent THEN
          block := NIL;
          RETURN;
        IFEND;
      IFEND;
      block := block^.previous_block;
    WHILEND;

  PROCEND find_block_containing_object;
?? OLDTITLE ??
*IF NOT $true(osv$unix)
?? NEWTITLE := 'find_environment_block', EJECT ??

{
{ PURPOSE:
{   This procedure searches the block stack for a block that can hold
{   environment objects.
{

  PROCEDURE [INLINE] find_environment_block
    (VAR block: ^clt$block;
     VAR block_found_in_current_task: boolean);


    clp$find_current_block (block);
    block_found_in_current_task := TRUE;

    WHILE TRUE DO
      CASE block^.kind OF
      = clc$command_proc_block, clc$function_proc_block, clc$utility_block, clc$when_block =
        RETURN;
      = clc$command_block =
        CASE block^.command_kind OF
        = clc$command_is_include_file, clc$command_is_include_line =
          ;
        ELSE
          RETURN;
        CASEND;
      = clc$task_block =
        IF (block^.task_kind <> clc$other_task) OR (NOT block^.synchronous_with_parent) THEN
          RETURN;
        IFEND;
        block_found_in_current_task := FALSE;
      ELSE
        ;
      CASEND;
      block := block^.previous_block;
    WHILEND;

  PROCEND find_environment_block;
?? OLDTITLE ??
?? NEWTITLE := 'find_pushed_object', EJECT ??

{
{ PURPOSE:
{   This procedure is called when an object is being popped in order to find
{   the previous (pushed) instance of that object.
{

  PROCEDURE [INLINE] find_pushed_object
    (    object_ordinal: clt$environment_object_ordinal;
         popped_object_block: ^clt$block;
         popped_object_in_current_task: boolean;
     VAR pushed_object: ^clt$environment_object_contents;
     VAR pushed_object_in_current_task: boolean);

    VAR
      block: ^clt$block;


    pushed_object := NIL;
    pushed_object_in_current_task := popped_object_in_current_task;
    block := popped_object_block;

    WHILE TRUE DO
      IF block^.kind = clc$task_block THEN
        pushed_object_in_current_task := FALSE;
        IF NOT block^.synchronous_with_parent THEN
          RETURN;
        IFEND;
      IFEND;
      block := block^.previous_block;
      IF (block^.environment_object_info <> NIL) AND block^.environment_object_info^.
            defined [object_ordinal] THEN
        pushed_object := ^block^.environment_object_info^.contents
              [clv$environment_object_slices [object_ordinal].index];
        RETURN;
      IFEND;
    WHILEND;

  PROCEND find_pushed_object;
?? OLDTITLE ??
?? NEWTITLE := 'search_environment_object_names', EJECT ??

{
{ PURPOSE:
{   This procedure is called to find the ordinal of an environment object given
{   its name.  It performs a binary search on the CLV$ENVIRONMENT_OBJECT_NAMES
{   table, therefore that table must be maintained in alphabetical order.
{

  PROCEDURE [INLINE] search_environment_object_names
    (    object_name: ost$name;
     VAR object_ordinal: clt$environment_object_ordinal;
     VAR object_implemented: boolean;
     VAR object_name_found: boolean);

    VAR
      lower: 1 .. clc$eo_defined_names + 1,
      upper: 0 .. clc$eo_defined_names,
      temp: integer,
      index: 1 .. clc$eo_defined_names;


    lower := 1;
    upper := clc$eo_defined_names;

    WHILE (lower <= upper) DO
      temp := lower + upper;
      index := temp DIV 2;
      IF object_name = clv$environment_object_names [index].name THEN

        object_name_found := TRUE;
        object_implemented := clv$environment_object_names [index].implemented;
        IF object_implemented THEN
          object_ordinal := clv$environment_object_names [index].ordinal;
        IFEND;
        RETURN;

      ELSEIF object_name > clv$environment_object_names [index].name THEN
        lower := index + 1;
      ELSE
        upper := index - 1;
      IFEND;
    WHILEND;

    object_name_found := FALSE;

  PROCEND search_environment_object_names;
?? OLDTITLE ??
*IFEND

MODEND clm$environment_object_manager;
