From:	SMTP%"rlboyd@rock.concert.net"  9-FEB-1994 15:54:39.75
To:	EVERHART
CC:	
Subj:	SLMOD part 3/5

From: Bob Boyd <rlboyd@rock.concert.net>
X-Disclaimer-1: rock.concert.net is a CONCERT-CONNECT public access host.
X-Disclaimer-2:     Opinions expressed are not necessarily
X-Disclaimer-3:     those of MCNC or the CONCERT Network.
Message-Id: <9402092051.AA24120@rock.concert.net>
Subject: SLMOD part 3/5
To: ADAMSE@LETT.KUN.NL (Hans Adamse), 8004slb@vmsf.csd.mu.edu (Sandy Berger),
        Everhart@arisia.gce.com (Glenn Everhart),
        bolson@u.washington.edu (Ed Bolson),
        jkraft@mccoy.fhcrc.org (John Kraft)
Date: Wed, 9 Feb 94 15:51:05 EST
X-Mailer: ELM [version 2.3 PL11]

-+-+-+-+-+-+-+-+ START OF PART 3 -+-+-+-+-+-+-+-+
Xd`09`09type *,'cmd_len:',cmd_len,
Xd`091`09`09', sym_ptr:',sym_ptr,',sym_ctr:',sym_ctr
X`09`09if( sym_ctr.lt.3 ) then
X`09`09  status = str$copy_r(symbol_buffer(sym_ptr:sym_ptr+cmd_len-1),
X`091`09`09cmd_len, %val(lnm_list(sym_ctr).buffer_address))
X`09`09  sym_ptr = 1+cmd_len
X`09`09else
X`09`09  symbol_buffer(sym_ptr:sym_ptr) = ','
X`09`09  sym_ptr = 1+sym_ptr
X`09`09  status = str$copy_r(symbol_buffer(sym_ptr:sym_ptr+cmd_len-1),
X`091`09`09cmd_len,%val(lnm_list(sym_ctr).buffer_address))
X`09`09  sym_ptr = sym_ptr+cmd_len
X`09`09endif
X`09`09tran_attrib =
X`091`09`09dereference(%val(lnm_list(sym_ctr-1).buffer_address))
Xd`09`09type 990,'Tran_attrib: ',tran_attrib
X990`09`09format(1X,A,Z8)
X`09`09if( tran_attrib.ne.0) then
X`09`09  tran_string = '/TRANSLATION=('
X`09`09  tran_len = 14
X`09`09  if( (tran_attrib.and.lnm$m_concealed).ne.0 ) then
X`09`09`09tran_string(tran_len+1:tran_len+9) = 'CONCEALED'
X`09`09`09tran_len = tran_len+9
X`09`09`09if( (tran_attrib.and. lnm$m_terminal).ne.0 ) then
X`09`09`09   tran_string(tran_len+1:tran_len+9) = ',TERMINAL'
X`09`09  `09   tran_len = tran_len+9
X`09`09`09endif
X`09`09  else
X`09`09`09if( (tran_attrib.and. lnm$m_terminal).ne.0 ) then
X`09`09`09   tran_string(tran_len+1:tran_len+8) = 'TERMINAL'
X`09`09  `09   tran_len = tran_len+8
X`09`09`09endif
X`09`09  endif
X`09`09  tran_string(1+tran_len:1+tran_len) = ')'
X`09`09  tran_len = 1+tran_len
X`09`09  symbol_buffer(sym_ptr:sym_ptr+tran_len) =
X`091`09`09tran_string(1:tran_len)
X`09`09  sym_ptr = sym_ptr+tran_len
X`09`09endif
X`09`09sym_ctr = 1+sym_ctr
Xd`09      type *,'sym_ptr:',sym_ptr
Xd`09      type *,'symbol_buffer:'//symbol_buffer(:sym_ptr-1)
X`09    enddo
Xc
Xc Add NAME_ATTRIBUTES on the end of the whole string
Xc
X`09    if( name_attributes.ne.0) then`09! there are attributes
X`09`09  tran_string = '/NAME=('
X`09`09  tran_len = 7
X`09`09  if( (name_attributes.and.lnm$m_CONFINE).ne.0 ) then
X`09`09`09tran_string(tran_len+1:tran_len+7) = 'CONFINE'
X`09`09`09tran_len = tran_len+7
X`09`09`09if( (name_attributes.and. lnm$m_no_alias).ne.0 ) then
X`09`09`09   tran_string(tran_len+1:tran_len+9) = ',NO_ALIAS'
X`09`09  `09   tran_len = tran_len+9
X`09`09`09endif
X`09`09  else`09! Confine not specified
X`09`09`09if( (name_attributes.and. lnm$m_no_alias).ne.0 ) then
X`09`09`09   tran_string(tran_len+1:tran_len+8) = 'NO_ALIAS'
X`09`09  `09   tran_len = tran_len+8
X`09`09`09endif
X`09`09  endif`09! confine specified
X`09`09  tran_string(1+tran_len:1+tran_len) = ')'
X`09`09  tran_len = 1+tran_len
X`09`09  symbol_buffer(sym_ptr:sym_ptr+tran_len) =
X`091`09`09tran_string(1:tran_len)
X`09`09  sym_ptr = sym_ptr+tran_len
X`09  endif`09! Name_Attributes supplied
Xc
Xc Handle output access mode
Xc
X`09  if( output_access_mode.le.psl$c_user ) then
X`09`09if( output_access_mode.eq.psl$c_user ) then
X`09`09  tran_len = 10
X`09`09  tran_string(1:tran_len) = '/USER_MODE'
X`09`09else if( output_access_mode.eq.psl$c_super ) then
X`09`09  tran_len = 16
X`09`09  tran_string(:tran_len) = '/SUPERVISOR_MODE'
X`09`09else if( output_access_mode.eq.psl$c_exec ) then
X`09`09  tran_len = 15
X`09`09  tran_string(:tran_len) = '/EXECUTIVE_MODE'
X`09`09else
X`09`09  tran_len = 12
X`09`09  tran_string(:tran_len) = '/KERNEL_MODE'
X`09  `09endif
X`09`09symbol_buffer(sym_ptr:sym_ptr+tran_len) =
X`091`09`09tran_string(1:tran_len)
X`09`09sym_ptr = sym_ptr+tran_len
X`09  endif
Xc
Xc  Set the DCL symbol to the appropriate value
Xc
X`09    if( sym_ptr.gt.1024 ) sym_ptr = 1024
Xd`09    type *,'sym_ptr:',sym_ptr
Xd`09    type *,'symbol_buffer:'//symbol_buffer(:sym_ptr-1)
X`09    status = lib$set_symbol(symbol_name(:sym_len),
X`091`09`09 symbol_buffer(:sym_ptr-1))
X`09  endif
X`09 endif ! status normal test
Xc
Xc Code to DELETE the search list logical name
Xc
X`09else ! the name is to be deleted if ok
X`09  if(ok_to_delete) then
Xd`09type *,'Deleting '//logical_name(:lnm_len)//' with '
Xd`091`09//'with access mode:',output_access_mode
Xc
Xc Check access mode -- Use lib$delete_logical for supervisor mode
Xc
X`09    if( output_access_mode.eq.psl$c_super ) then
X`09`09status = lib$delete_logical(logical_name(:lnm_len),
X`091`09`09output_table(:output_tlen))
X`09`09exit_status = status
X`09    else if( output_access_mode.le.psl$c_user ) then
X`09      status = sys$dellnm(output_table(:output_tlen),
X`091`09logical_name(:lnm_len),output_access_mode)
X`09      exit_status = status
X`09    else ! no access mode specified
X`09      status = sys$dellnm(output_table(:output_tlen),
X`091`09logical_name(:lnm_len),)
X`09      exit_status = status
X`09    endif ! access mode is specified
X`09    if( ((exit_status.and.1).ne.0 ) .and. log_flag) then
X`09      p2_status = lib$put_output(
X`091       'SLMOD-I-DELETED, logical name '//logical_name(:lnm_len))
X`09    endif
X`09  else
X`09    if( log_flag) then
X`09      p2_status = lib$put_output(
X`091     'SLMOD-I-DELIGNORED, logical name '//logical_name(:lnm_len)//
X`092     '-- /NOEMPTY_DELETE specified')
X`09    endif
X`09  endif ! ok_to_delete
X`09  if( cli_present('SYMBOL').ne.cli$_absent) then
X`09      status = cli_get_value('SYMBOL',symbol_name,sym_len)
X`09      status = lib$delete_symbol(symbol_name(:sym_len))
X`09  endif
X`09endif ! name to be deleted
Xc
Xc If Log is specified then note the update
Xc To do this properly, call lib$put_output
Xc
Xc
Xc If the current process has sufficient privileges or the image has
Xc sufficient privileges to do this, then release the locks on the
Xc logical name search list before translating it.
Xc
X`09if( input_tlen.gt.0 ) then
X`09  if( input_table(:input_tlen).ne.'LNM$PROCESS' )
X`091     call unlock_it( 1,input_table(:input_tlen),
X`092`09`09`09logical_name(:lnm_len) )
X`09endif
X`09if( output_table(:output_tlen).ne.input_table(:input_tlen)) then
X`09  if( output_table(:output_tlen).ne.'LNM$PROCESS' )
X`091     call unlock_it( 2,output_table(:output_tlen),
X`092`09`09`09logical_name(:lnm_len) )
X`09endif
Xc
Xc Leave the image
Xc
X`09call exit(exit_status)
X`09end ! Program SLMOD
$ CALL UNPACK SLMOD.FOR;88 1315335315
$ create 'f'
XC Last Modified:   4-FEB-1994 09:36:28.71, By: RLB14162`20
XC Last Modified:  , By: RBN 1 16:55:34.27
X
X`09Subroutine Build_Item_List(Input_List, Out_Item_list, Num_Items)
X`09implicit none
Xc
X`09include '($lnmdef)'
X`09include 'slmod_structures.inc'
Xc
Xc  Parameters
Xc
X`09integer*2 Num_items
X`09record /item_list/ Out_Item_List(*)
X`09record /equivalence_strings/ Input_List(*)
Xc
Xc  Local Variables
Xc
X`09integer`09itm_indx, cur_input_index, cur_output_index
X
Xc
Xc For each equivalence name generate 2 entries in the item list.
Xc The 1st entry is for the translation attributes.  The 2nd entry
Xc is for the string.
Xc
X`09do itm_indx = 0, Num_Items-1
X
X`09  cur_input_index = itm_indx+1
X`09  cur_output_index = 2*itm_indx+1
X`09  Out_Item_List(cur_output_index).item_code = lnm$_attributes
X`09  Out_Item_List(cur_output_index).buffer_length = 4
Xc
Xc Force equivalence name attributes to be limited to only those that
Xc apply directly to equivalence names.  Currently these are only the
Xc 2 translation attributes.
Xc
Xd`09type 980,'Attributes(',cur_input_index,') =',
Xd`091`09input_list(cur_input_index).attributes
X980`09format(1X,A,I3,A,Z8) `20
X`09  Input_List(cur_input_index).attributes =`20
X`091`09Input_List(cur_input_index).attributes .and.
X`092`09(lnm$m_concealed.or.lnm$m_terminal)
X`09  Out_Item_List(cur_output_index).buffer_address =`20
X`091`09%loc(input_list(cur_input_index).attributes)`20
X`09  Out_Item_List(cur_output_index).return_length_address = 0
Xc
Xc Put in the entry for the equivalence name string
Xc
X`09  cur_output_index = 1+cur_output_index
X`09  Out_Item_List(cur_output_index).item_code = lnm$_string
X`09  Out_Item_List(cur_output_index).buffer_length =`20
X`091`09input_list(cur_input_index).name_length
X`09  Out_Item_List(cur_output_index).buffer_address =`20
X`091`09%loc(input_list(cur_input_index).name_string)
X`09  Out_Item_List(cur_output_index).return_length_address = 0
X
X`09end do
X
Xc
Xc Terminate the item list
Xc
X`09Out_Item_List(2*Num_Items+1).end_list = 0
X
X`09end
X
X`09Subroutine Lock_It( Lock_Number, Lnm_Table, Lnm )
X`09Implicit None
X`09Character*(*)`09Lnm_Table, Lnm`20
X`09Integer`09`09Lock_Number
X
Xc `20
Xc Determine if the logical name table is a process or shared table.`20
Xc If it is a shared table:
Xc  1. Take out a NULL lock on the system logical name space by using
Xc`09LNM_<nodename> as the root lock.
Xc  2. Acquire a concurrent write lock on the table name of interest`20
Xc`09as a child of the root lock acquired in step 1.
Xc  3. Then acquire an exclusive lock on the logical name of`20
Xc`09interest as a child of the table lock.
Xc
X`09include`09'($lckdef)'
X`09include`09'($lnmdef)'
X`09include`09'($syidef)'
X`09include`09'($ssdef)'
X`09include '($prvdef)'
X
X`09include 'slmod_structures.inc'
X
X`09Integer*4`09sys$trnlnm, sys$enqw, sys$getsyi, str$trim
X`09Integer*4`09sys$deq
X
X`09character*31`09lnm_parent_name, table_tran_name
X`09integer*4`09table_len, lnm_len, status, parent_len,
X`091`09`09table_tran_index, table_tran_len
X
X`09record`09/item_list/ lnm_list(5)
X`09
X`09if( node_len.eq. 0 ) then
X`09  syi_list(1).buffer_length = 31
X`09  syi_list(1).item_code = syi$_nodename
X`09  syi_list(1).buffer_address = %loc(node_name)
X`09  syi_list(1).return_length_address = %loc(node_len)
X
X`09  syi_list(2).end_list = 0
X`09
X`09  status = sys$getsyi(,,,syi_list,,,)
X
X`09  status = str$trim(node_name(:node_len),node_name,node_len)
X`09endif
X
Xd`09type *,'Node_Name: '//node_name(:node_len)
X`09status = str$trim(lnm_table,lnm_table,table_len)
X`09status = str$trim(lnm,lnm,lnm_len)
Xc
Xc If the user or the image has the privilege to grab system wide
Xc locks, use it to inhibit simultaneous access/overwrite messes
Xc from occurring between different job contexts`20
Xc
X`09if( ((current_privileges.or.image_privileges).and.prv$m_syslck)
X`091`09.ne.0 ) then
X`09`09lock_flags = lck$m_system
X`09endif
X
X`09shared_flag = 1
X
X`09status = sys$enqw(,%val(lck$k_NLmode), node_lksb(lock_number),
X`091`09%val(lock_flags), 'LNM_'//node_name(:node_len),
X`092`09,,,,,)
Xd`09type *,'Lock LNM_'//node_name(:node_len)//' status:',status
X
X`09status = sys$enqw(,%val(lck$k_CWmode), table_lksb(lock_number),
X`091`09%val(lock_flags), lnm_table(:table_len),
X`092`09%val(node_lksb(lock_number).lock_id),,,,,)
Xd`09type *,'Lock '//lnm_table(:table_len)//' status:',status
X
X`09status = sys$enqw(,%val(lck$K_EXmode), lnm_lksb(lock_number),
X`091`09%val(lock_flags), lnm(:lnm_len),
X`092`09%val(table_lksb(lock_number).lock_id),,,,,)
Xd`09type *,'Lock '//lnm(:lnm_len)//' status:',status
X
X`09return
X
X`09Entry UNLock_It(Lock_Number, Lnm_Table, Lnm)
X
Xc
Xc  See if locks were used, otherwise return
Xc
X`09if( shared_flag.eq.1 ) then
X
X`09  status = sys$deq( lnm_lksb(lock_number),,,%val(lock_flags))
X
X`09  status = sys$deq( table_lksb(lock_number),,,%val(lock_flags))
X
X`09  status = sys$deq( node_lksb(lock_number),,,%val(lock_flags))
X
X`09endif
X
X`09return
X`09end
X
X`09integer function dereference( argument )
X`09implicit none
X`09integer argument
Xc
Xc This routine makes it easy to dereference a pointer in FORTRAN
Xc by invoking:
Xc`09x = dereference(%val(y))
Xc`20
Xc This causes the value of the thing pointed to by y to be stored in x.
Xc
X`09dereference = argument
X`09return
X`09end
X
X`09integer function lnm_table_find(lnm_table, lnm_table_len,
X`091`09`09`09  lnm_table_parent, lnm_table_parent_len,
X`092`09`09`09  lnm,input_table_name,table_flags,
X`093`09`09`09  lnm_access_mode)
X`09implicit none
X`09logical*4`09table_flags
X`09byte`09`09lnm_access_mode
X`09character*(*)`09lnm_table, input_table_name, lnm, lnm_table_parent
X
X`09include '($ssdef)'
X`09include`09'($lnmdef)'
X`09include`09'($psldef)'
X`09
X`09include 'slmod_structures.inc'
X
X`09integer*4`09sys$trnlnm, sys$dellnm, sys$crelnm, str$trim
X
X`09integer*4`09lnm_table_len, lnm_len, lnm_table_parent_len,
X`091`09`09input_table_name_len, work_len,
X`092`09`09tran_max_index, tran_index/0/,
X`093`09`09status, lnm_index, return_status/ss$_normal/
X
X`09record /item_list/ lnm_list(7)
X`09character*31`09work_name
Xc
Xc This routine takes a logical name and a logical name table string and
Xc determines what the name of the logical name table is that contains(or
Xc will contain if created) the logical name of interest.  It also returns
Xc the name of the parent table of the logical name table containing the
Xc logical name of interest.
Xc
Xc  If logical name A is in logical name table X which is a child of`20
Xc  LNM$PROCESS_DIRECTORY then LNM_TABLE will receive the value 'X', and
Xc  LNM_TABLE_PARENT will receive the value 'LNM$PROCESS_DIRECTORY'.
Xc
Xc This routine is needed because of the possibility that the table
Xc specified may actually be a logical name pointing to a table name or a
Xc search list of logical name tables.
Xc
Xc The flags argument is used to tell this routine whether the name is
Xc expected to already exist or if the name will be created.
Xc
Xc If the logical name already exists, then it is a simple matter to`20
Xc use the $TRNLNM system service to lookup what the name of the table
Xc is that contains the logical.
Xc
Xc When the table being evaluated is for output, there are 3 cases to`20
Xc consider:
Xc 1.  The name is the actual name of the target table;
Xc 2.  The name is a logical name that translates to a table name;
Xc 3.  The name is a logical name that points to a search list of table
Xc     names.
Xc Cases 1 and 2 are relatively straightforward to deal with.  The result
Xc is determinate through a simple forward algorithm.  Translate until
Xc reaching the end of the translations. Then you have the name of a table.
Xc
Xc Case 3 is a little more awkward.  Logical Name Tables are handled
Xc essentially the same way that VMS/RMS directories are handled when
Xc creating a logical name.  VMS attempts to create the logical name in the
Xc first leaf table name in the search list translation.
Xc
Xc The method implemented here translates the first element in the search
Xc list until coming to the first leaf.  Then the parent of the table
Xc pointed to by that leaf is the one taken.
Xc
Xc This seems like a bit heavy on overhead, but it is entirely possible that
Xc 2 processes might be updating the same logical name via different search
Xc lists that happen to translate to the same table for each process.
Xc This way the interlock on the search list logical name will`20
Xc be secure and processes will be inhibited from stomping over each other.
Xc
X`09status = str$trim(lnm,lnm,lnm_len)
X`09status = str$trim(input_table_name,input_table_name,
X`091`09`09  input_table_name_len)
X
Xc
Xc First, determine what kind of table name/access we're dealing with.
Xc
Xc If the operation is LNT$M_READ then ask directly for the table name
Xc of the logical.  Then ask for the parent of that table name.
Xc
X`09if( (lnt$m_read .and. table_flags) .ne. 0 ) then`09! read operation
X`09`09lnm_list(1).item_code = lnm$_table
X`09`09lnm_list(1).buffer_length = len(lnm_table)
X`09`09lnm_list(1).buffer_address = %loc(lnm_table)
X`09`09lnm_list(1).return_length_address = %loc(lnm_table_len)
X
X`09`09lnm_list(2).end_list = 0
X
X`09`09lnm_list(3).item_code = lnm$_parent
X`09`09lnm_list(3).buffer_length = len(lnm_table_parent)
X`09`09lnm_list(3).buffer_address = %loc(lnm_table_parent)
X`09`09lnm_list(3).return_length_address = %loc(lnm_table_parent_len)
X
X`09`09lnm_list(4).end_list = 0
X
X`09`09if (lnm_access_mode.le.psl$c_user) then
X`09`09  status = sys$trnlnm(,input_table_name(:input_table_name_len),
X`091`09`09lnm(:lnm_len),lnm_access_mode,lnm_list)
X`09`09  if(status.eq.ss$_normal) then
X`09`09    status = sys$trnlnm(,'LNM$DIRECTORIES',
X`091`09`09lnm_table(:lnm_table_len),lnm_access_mode,lnm_list(3))
X`09`09  else ! translate not successful
X`09`09    return_status = status
X`09`09  endif
X`09`09else ! no access mode specified
X`09`09  status = sys$trnlnm(,input_table_name(:input_table_name_len),
X`091`09`09lnm(:lnm_len),,lnm_list)
X`09`09  if(status.eq.ss$_normal) then
X`09`09    status = sys$trnlnm(,'LNM$DIRECTORIES',
X`091`09`09lnm_table(:lnm_table_len),,lnm_list(3))
X`09`09  else ! translate not successful
X`09`09    return_status = status
X`09`09  endif
X`09`09endif
X`09`09return_status = ss$_normal
X`09else`09! it is a  write operation
Xc
Xc Translate the table name until reaching the bottom of the list
Xc getting the parent table at each step -- when done, it will be done too.
Xc
Xc i.e. There is no further translation ... max_index < 0
Xc
X`09lnm_list(1).item_code = lnm$_max_index
X`09lnm_list(1).buffer_length = 4
X`09lnm_list(1).buffer_address = %loc(tran_max_index)
X`09lnm_list(1).return_length_address = 0
X
X`09lnm_list(2).item_code = lnm$_parent
X`09lnm_list(2).buffer_length = len(lnm_table_parent)
X`09lnm_list(2).buffer_address = %loc(lnm_table_parent)
X`09lnm_list(2).return_length_address = %loc(lnm_table_parent_len)
X
X`09lnm_list(3).end_list = 0
X
X`09lnm_list(4).item_code = lnm$_index
X`09lnm_list(4).buffer_length = 4
X`09lnm_list(4).buffer_address = %loc(lnm_index)
X`09lnm_list(4).return_length_address = 0
X
X`09lnm_list(5).item_code = lnm$_string
X`09lnm_list(5).buffer_length = len(work_name)
X`09lnm_list(5).buffer_address = %loc(work_name)
X`09lnm_list(5).return_length_address = %loc(work_len)
X
X`09lnm_list(6).end_list = 0
X
X`09lnm_index = 0
X
X`09lnm_table = input_table_name(:input_table_name_len)
X`09lnm_table_len = input_table_name_len
X
X`09if( lnm_access_mode.le.psl$c_user) then`09! access mode specified
X`09  status = sys$trnlnm(,'LNM$DIRECTORIES',
X`091`09`09lnm_table(:lnm_table_len),
X`092`09`09lnm_access_mode,lnm_list(1))
X`09else`09! no access mode specified
X`09  status = sys$trnlnm(,'LNM$DIRECTORIES',
X`091`09`09lnm_table(:lnm_table_len),,lnm_list(1))
X`09endif`09! access mode specified
X
Xd`09type *,'Translation Status:',status
Xd`09type *,'Table Name: '//lnm_table(:lnm_table_len)
Xd`09type *,'Parent: '//lnm_table_parent(:lnm_table_parent_len)
Xd`09type *,'Tran_Max_Index:',tran_max_index
X
X`09if(status.ne.ss$_normal) then`09! translate of input table name failed
X`09  return_status = status
X`09else`09!`09translate of input table succeeded`20
X
Xc
Xc Unwind the logical name to the top table,`20
Xc via the 1st item in the list at each level
Xc
X`09do while( tran_max_index .ge. 0 )`09! unwind the table logical name
X
X`09  if( lnm_access_mode.le.psl$c_user) then`09! access mode specified
X`09`09status = sys$trnlnm(,'LNM$DIRECTORIES',
X`091`09`09lnm_table(:lnm_table_len),
X`092`09`09lnm_access_mode,lnm_list(4))
X`09  else`09! no access mode specified
X`09`09status = sys$trnlnm(,'LNM$DIRECTORIES',
X`091`09`09lnm_table(:lnm_table_len),,lnm_list(4))
X`09  endif`09! access mode specified
X`09  if(status.ne.ss$_normal) then`09! translate of parent name failed
X`09`09return_status = status
X`09`09goto 800
X`09  endif`09! translate of parent name failed
X
Xc
Xc Now ask for the name of the table that the parent is located in
Xc
X`09  lnm_table = work_name(:work_len)
X`09  lnm_table_len = work_len
X`09  if( lnm_access_mode.le.psl$c_user) then`09! access mode specified
X`09`09status = sys$trnlnm(,'LNM$DIRECTORIES',
X`091`09`09lnm_table(:lnm_table_len),
X`092`09`09lnm_access_mode,lnm_list(1))
X`09  else`09! no access mode specified
X`09`09status = sys$trnlnm(,'LNM$DIRECTORIES',
X`091`09`09lnm_table(:lnm_table_len),,lnm_list(1))
X`09  endif`09! access mode specified
X
Xd`09type *,'Table Name: '//lnm_table(:lnm_table_len)
Xd`09type *,'Parent: '//lnm_table_parent(:lnm_table_parent_len)
Xd`09type *,'Tran_Max_Index:',tran_max_index
X
X`09  if(status.ne.ss$_normal) then`09! translate of parent table failed
X`09`09return_status = status
X`09`09goto 800
X`09  endif`09! translate of parent table failed
X
X`09end do`09! unwind table name
X`09endif ! which type of access
Xc
Xc Because of the way the list has been unwound, the name of the parent
Xc will be in the correct place.
Xc
Xd`09type *,'Table Name: '//lnm_table(:lnm_table_len)
Xd`09type *,'Parent: '//lnm_table_parent(:lnm_table_parent_len)
X`09  return_status = ss$_normal
X`09endif`09! read / write operation`20
X800`09continue
X`09lnm_table_find = return_status
X`09end
$ CALL UNPACK SLMOD_UTILS.FOR;35 491989052
$ create 'f'
Xc
X`09parameter`09gnum = 3
X`09parameter`09maximum_items = 128
X`09parameter`09maximum_list = (1+gnum)*maximum_items
Xc
Xc
Xc Table_Find flags
Xc
X`09parameter`09lnt$m_write = 1
X`09parameter`09lnt$m_read = 2
Xc
X`09structure /equivalence_strings/
X`09`09integer*2`09name_length,filler
X`09`09integer*4`09attributes
X`09`09character*255`09name_string
X`09end structure
Xc
X`09structure /item_list/
X`09  union
X`09    map
X`09`09integer*2`09buffer_length
X`09`09integer*2`09item_code
X`09`09integer*4`09Buffer_address
X`09`09integer*4`09return_length_address
X`09    end map
X`09    map
X`09`09integer*4`09end_list
X`09    end map
X`09  end union
X`09end structure
Xc`09
X`09structure /descriptor/
X`09`09integer*2`09length
X`09`09byte`09`09type
X`09`09byte`09`09class
X`09`09integer*4`09pointer
X`09end structure`09`09
Xc
X`09structure /lock_status_block/
X`09`09integer*2`09status
X`09`09integer*2`09null
X`09`09integer*4`09lock_id
X`09`09integer*4`09info(4)
X`09end structure
X
X`09record`09/lock_status_block/ node_lksb(2), table_lksb(2), lnm_lksb(2)
X
X`09record  /item_list/ syi_list(3)
X
X`09character*31`09node_name
X
X`09Integer*4`09image_privileges/0/, current_privileges/0/,
X`092`09`09authorized_privileges/0/, process_privileges/0/
X
X`09Integer*4`09lock_flags/0/, Node_Len/0/, shared_flag /0/
X
X`09Common /lnmlocks/`20
X`091`09lock_flags, image_privileges, current_privileges,
X`092`09authorized_privileges, process_privileges,
X`093`09node_len, syi_list,
X`094`09node_lksb, table_lksb, lnm_lksb, node_name
$ CALL UNPACK SLMOD_STRUCTURES.INC;9 1042509204
$ create 'f'
X$! Build the SLMOD executable
X$!
X$! p1 -- logical flag, TRUE forces DEBUG compilation/link
X$! p2 -- logical flag, TRUE forces a link
X$!
X$ rdt = "RDT"
X$ null = ""
X$ comma = ","
X$ semi = ";"
X$ if p1`20
X$ then`20
X$`09link_debug_flag = "/MAP/DEBUG" ! change to /DEBUG if you want`20
X$`09fort_debug_flag = "/DEBUG/D_LINES/list/nooptimize"
X$`09delete slmod.obj;*
X$ endif
X$ fortran_flags = "/OPTIMIZE/LIST/extend"
X$ link_flag = 0 ! .or.p2
X$ say= "write sys$output"
X$ object_module = "SLMOD.OBJ"  ! primary object module
X$ executable_image = "SLMOD.EXE"
X$!
X$ modules = "slmod.for,slmod_structures.inc,slmod.cld,climsgdef.inc"
X$ modules = modules+",cli_front_end.for,slmod_linkable.cld,slmod_utils.for"
X$!
X$ who_am_i = f$element(0,";",f$environment("procedure")) ! latest version
X$ who_am_i_exactly = f$environment("procedure") ! this very procedure
X$ where_am_i = f$parse("a.b;0",who_am_i,,,"syntax_only")-"A.B;0"
X$!
X$ modules = modules+","+who_am_i
X$ define slmod_exe 'where_am_i'/process
X$!
X$! look at files
X$!
X$ if f$search(f$parse(executable_image,semi)).nes.null`20
X$ then
X$`09image_time = f$cvtime(f$file_attribute(executable_image,RDT))
X$ else
X$`09image_time = f$cvtime("1-jan-1990")
X$ endif
X$ if f$search(f$parse(object_module,semi)).nes.null
X$ then
X$`09object_time = f$cvtime(f$file_attribute(object_module,RDT))
X$ else
X$`09object_time = f$cvtime("2-jan-1990")
X$ endif
X$ modi = 0
X$module_loop:
X$ nxt_module = f$element(modi,comma,modules)
X$ if nxt_module.nes.comma
X$ then
X$`09modi = 1+modi
X$`09if nxt_module.nes.null`20
X$`09then
X$`09`09mod_time = f$cvtime( f$file_attribute(nxt_module,RDT))
X$`09`09if mod_time.lts.object_time then $ goto module_loop
X$`09`09module_type = f$parse(nxt_module,,,"type")-"."
X$`09`09if module_type.eqs."FOR"
X$`09`09then
X$`09`09   fortran'fortran_flags' 'nxt_module''fort_debug_flag'
X$`09`09   link_flag = 1
X$`09`09else if module_type.eqs."CLD"
X$`09`09then
X$`09`09   if f$parse(nxt_module,,,"name").eqs."SLMOD_LINKABLE" then -
X$`09`09      set command 'nxt_module'/object
X$`09`09   link_flag = 1
X$`09`09endif
X$`09`09endif
X$`09        goto module_loop
X$`09else
X$`09`09goto  module_loop
X$`09endif
X$ else
X$`09goto SKIP_COMPILE
X$ endif
X$ if f$search(f$parse(object_module,semi)).nes.null
X$ then
X$`09object_time = f$cvtime(f$file_attribute(object_module,RDT))
X$ else
X$`09object_time = f$cvtime("2-jan-1990")
X$ endif
X$SKIP_COMPILE:
X$ if link_flag .or. (object_time.gts.image_time)
X$ then`20
X$   link`09slmod/executable=slmod.exe'link_debug_flag'-
X+slmod_utils+slmod_linkable+cli_front_end
X$ endif
X$!Last Modified:   2-FEB-1994 15:05:52.85, By: RLB14162`20
$ CALL UNPACK SLMOD_BUILD.COM;16 1195984416
$ create 'f'
X$! Kit.com -- build transmittable kit(s) of SLMOD code
X$! Uses BACKUP, LZCOMP and MFTU to build 4 different kits
X$! SLMOD.SAV is a backup save set
X$! SLMOD.SAV_Z is an LZW compressed copy of the save set
X$! SLMOD.MFTU_PACKED is just what the name says.
X$! Build the distribution kits for SLMOD.
X$! Include the object but not the executable.  The build procedure
X$! will link from the current object.
X$! SLMOD_SHARE parts are built from the sources only -- no object.
X$!
X$! SLMOD.MFTU_ENCODED is an MFTU ENCODEd copy of the MFTU PACKED kit.
X$!`09It is suitable for transmission via MAIL or other text only`20
X$!`09transport mechanisms.
X$!
X$ update = p1
X$ send = p2
X$ null = ""
X$ comma = ","
X$
X$ save_dir = f$environment("default")
X$`20
X$ who_am_i = f$element(0,";",f$environment("procedure")) ! latest version
X$ who_am_i_exactly = f$environment("procedure") ! this very procedure
X$ where_am_i = f$parse("a.b;0",who_am_i,,,"syntax_only")-"A.B;0"
X$!
X$ set default 'where_am_i'
X$ define slmod_dx `5B.distribution`5D/nolog
X$!
X$ kit_elements = "AAA*.1st;,SLMOD.HLP;,SLMOD.SPEC;"+-
X`09",SLMOD*.FOR;,SLMOD*.INC;,SLMOD*.COM;"+-
X`09",CLI*.FOR,CLI*.INC;,SLMOD*.CLD;,MAKEFILE.;"
X$
X$ object_elements = ",SLMOD*.OBJ;,CLI*.OBJ;"
X$ executable_elements = ",SLMOD.EXE;"
X$ all_elements = kit_elements+object_elements+executable_elements
X$!
X$ kit_file = "SLMOD_DX:SLMOD.MFTU_ENCODED"
X$ if f$search(kit_file).eqs.null then $ update = 1
X$ if .not.update`20
X$ then
X$ kit_time = f$cvtime(f$file_attributes(kit_file,"RDT"))
X$ filei = 0
X$FILE_LOOP:
X$ nxt_file = f$element(filei,comma,all_elements)
X$ if nxt_file.eqs.comma then goto BUILD_DONE
X$ filei = 1+filei
X$ nxt_file = f$edit(nxt_file,"trim")
X$ ctx = 3353
X$FILE_NAME_LOOP:
X$ file_name = f$search(nxt_file,ctx)
X$ if file_name .nes. null`20
X$ then`09! there is a real file name
X$ file_time = f$cvtime(f$file_attribute(file_name,"RDT"))
X$ if file_time.les.kit_time`20
X$   then`09! this file is older than the current kit
X$`09if f$Loc("*",nxt_file).lt.f$Len(nxt_file) .or.-
X`09   f$Loc("%",nxt_file).lt.f$Len(nxt_file)
X$`09then $ goto FILE_NAME_LOOP
X$`09else $ goto FILE_LOOP
X$`09endif
X$   endif
X$ update = 1
X$ else ! not a name left
X$`09goto FILE_LOOP
X$ endif`09! non null file name
X$endif
X$ if .not.update
X$ then
X$ backup 'all_elements'/exclude=slmod_kit.com -
X`09slmod_dx:slmod.sav/save_set/comment="SLMOD source kit"
X$ else
X$ send = 1
X$ backup 'all_elements' -
X`09slmod_dx:slmod.sav/save_set/block=8192-
X`09/comment="SLMOD source kit"
X$ setup compress*
X$`20
X$ @utl:vms_share 'kit_elements' slmod_dx:slmod_share
X$ pack 'all_elements'/output=slmod_dx:SLMOD.MFTU_PACKED
X$ encode slmod_dx:SLMOD.MFTU_PACKED/output=slmod_dx:SLMOD.MFTU_ENCODED
X$!
X$ set default slmod_dx:
X$ purge SLMOD.SAV*,SLMOD.MFTU*,slmod_share.*/NOLOG
X$ if f$search("SLMOD.SAV_Z;").nes.null then $ delete slmod.sav_z;*/nolog
X$! backup SLMOD.SAV SLMOD.SAV_B/nolog
X$ lzcomp SLMOD.SAV slmod.sav_z
X$ purge SLMOD.SAV*,SLMOD.MFTU*,slmod_share.*/NOLOG
X$endif
X$!
X$BUILD_DONE:
X$ if send .and. (f$type(FTP).nes.null)
X$then
X$ if f$search("SLMOD.SAV;").eqs."" then $ set default slmod_dx:
X$
X$ define sys$input sys$command:/user
X$ ftp gatekeeper
Xrlboyd@rock.concert.net
Xmkdir slmod
Xcd slmod
Xlcd `5B.distribution`5D
Xnointer
Xbinary
Xput SLMOD.SAV_Z
Xput SLMOD.SAV
X#put SLMOD.MFTU_PACKED
Xascii
Xput `5B-`5Dfix_sav.com
Xput `5B-`5Dfix_sav_z.com
Xput SLMOD.MFTU_ENCODED
Xmput slmod_share.*
Xquit
X$endif
X$!
X$EXIT:
X$ set default 'save_dir'
X$ exit
X$!Last Modified:   4-FEB-1994 19:28:17.97, By: RLB14162`20
$ CALL UNPACK SLMOD_KIT.COM;18 1125057173
$ create 'f'
X$! define logical(s) and symbol(s) /Command Verb(s) to use SLMOD
X$ set noon
X$ who_am_i = f$element(0,";",f$environment("procedure")) ! latest version
X$ who_am_i_exactly = f$environment("procedure") ! this very procedure
X$ where_am_i = f$parse("a.b;0",who_am_i,,,"syntax_only")-"A.B;0"
X$ define slmod_exe 'where_am_i'/process
X$ set command slmod_exe:slmod
X$!Last Modified:  12-APR-1991 13:34:12.14, By: RBN`20
X
$ CALL UNPACK SLMOD_SETUP.COM;2 997861542
$ create 'f'
X$! Test.com`20
X$!  Abstract:`09Test SLMOD, Search List MODify Utility
X$! `20
X$!  Author:`09Robert L. Boyd
+-+-+-+-+-+-+-+-  END  OF PART 3 +-+-+-+-+-+-+-+-