c
c This library manages all things around cld tables
c the layout of a cld table is explained below
c
c   General
c    TRO (Table Relative Offset) is an offset from the start of the cliTable
c    BRO (Block Relative Offset) is an offset from the start of the current block
c
c
c  clitable
c   header
c   verb_tro  --------------------+               
c   cmnd_tro  -->Header           +---->header
c                Tro -->Command         verb   (max 4 letters)
c                Tro -->Command         verb
c                ... Length in header   ...    (length is in header)
c   Length of table
c
c  Command_block (pointed to by the tro in the cmnd_tro in the clitable
c   Header
c   param_tro -->entity-->entity-->entity  (via .next_tro in entity)
c   quals_tro -->entity-->entity-->entity
c   paramcnt (min/max parameters)
c   name(_bro)
c   image(_bro)
c
c  Entity_block
c   Header
c   next_tro                      Pointer to the next in this chain
c   syntax_tro-->Command_block    Change of syntax
c   user_type_tro-->type_block    User defined types
c   value_type                    Type of value (if user_type_tro=0)
c   name(_bro)
c   label(_bro)
c   prompt(_bro)
c   default_value(_bro)
c
c  Type_block
c   Header
c   keyword_tro --> entity-->entity-->entity
c   name(_bro)
c   
c
	function table_init(ptr_table_info,verbone)
	implicit none
c
c Allocate and Init table control block
c  return a pointer to this block
c
	include 'table.inc'
	integer*4 ptr_table_info	!:o: pointer to table block
	logical*4 verbone		!:i: verbone setting
	integer*4 table_init		!:f: function result
c#
	integer*4 istat
	record /table_info/ table_info
	pointer (p_table_info,table_info)
c
	integer*4 table__set_dcl
	integer*4 lib$get_vm
c
c Set the initial verbone state, this can be changed
c with the ^V/f9 key
c
c verbone 
c  some images do have cld tables but only to parse qualifiers.
c  they will do a lib$get_foreign to get the command line and
c  then a dcl_parse with a programmed verb. This verb is
c  not visible to the outside world.
c  f.e. suppose we have a program test that defines "fixed" verb "vrb"
c  test:=$test
c  test /qual1/qual2....
c  The source woiuld be
c  call lib$get_foreign(line,,nkar)
c  call cli$dcl_parse('vrb '//line(1:nkar)...)
c
c So the verb is test, but on the outside (users using the symbol test)
c  this "vrb" is not needed (and indeed not wanted).
c 
c If you have "verbone" set, and AUTO discovers an image with only 1 verb
c ("vrb" in the previous example) AUTO will not prompt for the verb
c nor will it insert it in the command line
c If verbone is clear, AUTO will ask for and insert the verb
c   (the program does a CLI$DCL_PARSE(LINE(1:NKAR)...) with the fixed "VRB"
c
c
	istat = lib$get_vm(sizeof(table_info),p_table_info)
	if(istat) then
	  table_info.verbone = verbone
c
	  istat = table__set_dcl(table_info)
	endif
	ptr_table_info = p_table_info
	table_init = istat
	return
	end
	function table__set_dcl(table_info)
	implicit none
c
c Init table control block to the standard DCL table
c  it will take the CLI$AG_CLITABLE (so we need to link
c  with /SYSEXE)
c
	include 'table.inc'
	record /table_info/ table_info	!:io: table block
	integer*4 table__set_dcl	!:f: function result
c#
	integer*4 istat,nverbs
c
	integer*4 pointer
	pointer (p_pointer,pointer)
c
	integer*4 get_dcl_table
	integer*4 table__check_table
c
c Look for the symbol table
c
	p_pointer = get_dcl_table()
c
	istat = table__check_table(pointer,table_info,nverbs)
	table__set_dcl = istat
	return
	end
	function table__check_table(pointer,table_info,nverbs)
	implicit none
c
c Check if pointer points to a valid vector block
c
	include 'table.inc'
	integer*4 pointer		!:i: pointer
	record /table_info/ table_info	!:o: table block
	integer*4 nverbs		!:o: #verbs defined
	integer*4 table__check_table	!:f: function result
c
	integer*4 istat
c
	record /vector_block/ table
	pointer (p_table , table)
c
	record /verbs/ verb_table
	pointer (p_verb_table,verb_table)
c
	integer*4 table__tro
c
c Look for the symbol table
c
	p_table   = pointer
c
c Check if this is a correct table
c
        if(table.header.length .ne. sizeof(table) .or.
     1     table.header.type   .ne. block_type_vector .or.
     1     table.header.subtype.ne. vector_block_subtype_dcl ) then
c
c Invalid ??
c
	  istat = 0
        else
c
c Fill the block
c
	  table_info.table_pointer = p_table
	  table_info.ptr_verbs = table__tro(table_info,table.verbs_tro)
	  table_info.ptr_cmnds = table__tro(table_info,table.commands_tro)
c
c Get #verbs
c
	  p_verb_table = table_info.ptr_verbs
	  nverbs = (verb_table.header.length - sizeof(verb_table.header))/ 
     1               sizeof(verb_table.verbsa(1))
	  table_info.n_verbs = nverbs
	  istat = 1
	endif
	table__check_table = istat
	return
	end
c
	function table_valid_verb(ptr_table_info,verb)
	implicit none
c
c See if verb is a verb in the (current) cli tables
c
	include 'table.inc'
	integer*4 ptr_table_info	!:i: pointer to table info block
	character*(*) verb		!:i: the verb to check
	integer*4 table_valid_verb	!:f: result (1=oke,0=not)
c#
	record /table_info/ table_info	!:i: table info block
	pointer (p_table_info,table_info)
	integer*4 nk_verb
	character*(max_name) line
	logical exact
c
	integer*4 idx,ptr,n_fnd
c
	integer*4 table_match_verb
c
c Loop around all verbs and see for a match
c
	p_table_info = ptr_table_info
c
	idx = 1
	do while(table_match_verb(ptr_table_info,verb,line,
     1           nk_verb,idx,ptr,exact))
c
c If we have a full match, all oke
c
	  if(exact) goto 10
c
c Add one more match
c
	  n_fnd = n_fnd + 1
	end do
c
c if n_fnd =1, we have exactly one match
c
	exact = n_fnd .eq. 1
c
c Return status
c
10	if(exact) then
	  table_valid_verb = 1
	else
	  table_valid_verb = 0
	endif
	return
	end
	function table__tro(table_info,offset)
	implicit none
c
c Return pointer with a TRO (table relative offset)
c
	include 'table.inc'
	record /table_info/ table_info		!:i: the table info block	
	integer*4 offset        		!:i: the offset
	integer*4 table__tro			!:f: the pointer (or 0)
c#
	if(offset .eq. 0) then
	  table__tro  = 0
	else
	  table__tro = table_info.table_pointer + offset
	end if
	return
	end
	function table_match_verb(ptr_table_info,what,verb,nk_verb,idx,
     1                            ptr_command,exact)
	implicit none
c
c See if "WHAT" matches one of the verbs
c  and update the .index field
c
	include 'table.inc'
	integer*4 ptr_table_info	!:i: pointer to control block
	character*(*) what		!:i: the verb to look for
	character*(*) verb		!:o: the verb found
	integer*4 nk_verb		!:o: lenght of verb
	integer*4 idx			!:io: index for match (init to 1)
	integer*4 ptr_command		!:o: the pointer to the selected command block
	logical exact			!:o: true if exact match
	integer*4 table_match_verb	!:f: function result (0/1)
c#
	record /table_info/ table_info	!:io: table info
	pointer (p_table_info,table_info)
	record /verbs/ verb_table
	pointer (p_verb_table,verb_table)
c
	record /commands/ command_table
	pointer (p_command_table,command_table)
c
	record /command_block/ command
	pointer (p_command,command)
c
	integer*4 k,nk,l,bpos,nb
	logical*4 got_match
	integer*4 str$case_blind_compare
	integer*4 table__tro
c
	character*(max_name) name
	integer*4 nk_name	
c 
c Verbs are found through the verb table
c this is a list of 4 byte strings, allowing for a quick
c search. It the first 4 (or less) characters match,
c there is a second list with tro's to the command blocoks
c that contain the full name
c
c Set pointer to the verb table
c  this is a tabel of longwords with the first 4 characters of the verb
c
	p_table_info = ptr_table_info
	p_verb_table = table_info.ptr_verbs
c
	exact = .false.
	table_match_verb = 0	!assume no match
c
c CHeck for the bound
c
10	if(idx .gt. table_info.n_verbs) goto 90
c
c Get and update the index
c
	k = idx
	idx = idx + 1
c
c Get the length of the verb in the table,
c this is 4 (or less if zero terminated)
c
	nk = index(verb_table.verbsa(k),char(0)) - 1
	if(nk .lt. 0) nk = len(verb_table.verbsa(k))
c
	nk = min(len(what),nk)
c
c See if this one matches
c
	if(str$case_blind_compare(verb_table.verbsa(k)(1:nk),
     1                            what(1:nk)) .ne. 0) goto 10
c
c We have a short match, see if the long name is also correct
c name_bro points to a list of names
c preceeded by a byte for the total length
c we are interested in the first name only
c
	p_command_table = table_info.ptr_cmnds
c
c Since more than one entry can point to the same command entry
c we check to see if the offset has already been processed
c
	do l=1,k-1
	  if(command_table.command_tro(l) .eq. 
     1       command_table.command_tro(k)) goto 10
	end do
c
	p_command = table__tro(table_info,command_table.command_tro(k))
c
c Get the full name
c Name_bro contains a list of values (the synonyms)
c the total structure is
c  nbyte_total
c  bytecounted string1
c  bytecounted string2
c  bytecounted string3
c  ...etc
c  Example : for the verb SHOW there are 2 names 
c  1: SHOW
c  2: SH
c
	bpos = %loc(command) + command.name_bro
c
c Get the total nbyte
c
	nb = 0
	call lib$movc3(1,%val(bpos),nb)
	bpos = command.name_bro+1
	got_match = .false.
	exact = .false.
	do while(nb .gt. 0)
	  call table__name_copy(command,bpos,name,nk_name)
	  nb = nb - nk_name - 1
	  bpos = bpos + nk_name + 1
c
c Now we have the full name
c
	  if(len(what) .le. nk_name) then
	    nk = min(len(what),nk_name)
	    if(str$case_blind_compare(name(1:nk),
     1                    what(1:nk)) .eq. 0) then
	      got_match = .true.
	      if(nk_name .eq. len(what)) exact = .true.
	    endif
	  endif
	end do
c
c If match not set, no match found
c
	if(.not. got_match) goto 10
c
c Match
c Get #parameters
c	
	ptr_command = p_command
c
c And return the first full name
c
	bpos = command.name_bro+1
	call table__name_copy(command,bpos,verb,nk_verb)
c
	table_match_verb = 1
c
90	return
	end
c
	function table_set_command_param(ptr_table_info,ptr_terminal_info,
     1                        ptr_command,
     1                        par_idx,ptr_entity,par_addr)
	implicit none
c
c return pointer to entity block for parameter 'par_idx' for the current command
c
	include 'table.inc'	
	integer*4 ptr_table_info		!:i: pointer to table block
	integer*4 ptr_terminal_info		!:i: pointer to terminal block
	integer*4 ptr_command			!:i: pointer to command block
	integer*4 par_idx			!:i: the requested parameter
	integer*4 ptr_entity			!:o: pointer to ent entity block
	integer*4 par_addr			!:i: address of parameter list
	integer*4 table_set_command_param	!:f: function result
c#
	record /table_info/ table_info		!:i: table info block
	pointer (p_table_info,table_info)
c
	record /command_block/ command
	pointer (p_command,command)
c
	record /entity_block/ entity
	pointer (p_entity,entity)	
c
	integer*4 istat,idx
c
	integer*4 table__tro
	external auto_msg_interr
	external auto_msg_expparam
c
	istat = 1
	p_table_info = ptr_table_info
	p_command = ptr_command
c
c Set the pointer to the first parameter
c
c	p_entity = table__tro(table_info,command.param_tro)
	p_entity = par_addr
c
	idx = 0
c
	do while(p_entity .ne. 0) 
c
c They should be type parameter, but you never know
c
	  if(entity.header.subtype .eq. entity_block_subtype_parameter) then
	    idx = idx + 1
	    if(idx .eq. par_idx) then
c
c  Got it, so return the pointer
c
	      ptr_entity = p_entity
	      goto 90
	    endif	  
	  else
	    call auto_msg(ptr_terminal_info,auto_msg_expparam)
	  endif
c
c  Try the next 
c  
	  p_entity = table__tro(table_info,entity.next_tro)
	end do
c
c This should not happen
c
	istat = %loc(auto_msg_interr)
c
90	table_set_command_param  = istat
	return
	end
	subroutine table__name_copy(block,bro,name,nk_name)
	implicit none
c
c Copy an ascic string to a fixed one
c
	byte block(*)		!:i: data block
	integer*2 bro		!:i: offset
	character*(*) name	!:o: the  name
	integer*4 nk_name	!:o: length of name
c#
c Compute the length
c
	nk_name = min(zext(block(bro+1)),len(name))
c
c Move the text
c
	call lib$movc3(nk_name,block(bro+2),%ref(name))
c
c Blank extra bytes
c
	if(nk_name .lt. len(name)) name(nk_name+1:) = ' '
	return
	end		

	function table_list_command_qual(ptr_table_info,ptr_terminal_info,
     1                                   ptr_command,
     1                                   line,qual,nk_qual,
     1                                   ptr_entity,negated,
     1                                   qual_addr)
	implicit none
c
c List the next qualifier matching "line" for the current command
c ptr_entity must be inited to 0, and is then updated by this routine
c
	include 'table.inc'
	integer*4 ptr_table_info	!:i: table info block
	integer*4 ptr_terminal_info	!:i: terminal info block
	integer*4 ptr_command		!:i: the pointer to the command block
	character*(*) line		!:i: the pattern to match
	character*(*) qual		!:O: the qualifier found
	integer*4 nk_qual		!:o: length of qual
	logical*4 negated    		!:o: was the match found with the NOxx
	integer*4 ptr_entity		!:io: the pointer to the entity block
	integer*4 qual_addr		!:i: the qualifier list address 
	integer*4 table_list_command_qual !:f: function result
c
	record /table_info/ table_info
	pointer (p_table_info,table_info)
c
	record /command_block/ command
	pointer (p_command,command)
c
	record /entity_block/ entity
	pointer (p_entity,entity)	
c
	integer*4 istat
c
	external auto_msg_expqual
	integer*4 auto_msg
c
	logical*4 table__compare
	integer*4 table__tro
c
	p_table_info = ptr_table_info
c
	istat = 1		!assume found
c
c Get the pointer to the command_block
c
	p_command      = ptr_command
c
c Now set the pointer
c
	if(ptr_entity .eq. 0) then
c
c Take the first
c
c	  p_entity  = table__tro(table_info,command.qualifier_tro)
	  p_entity  = qual_addr
	else
c
c Take the previous one, and then it's next
c
	  p_entity  = ptr_entity
	  p_entity = table__tro(table_info,entity.next_tro)
	endif
c
c See if this one matches the wanted string
c
	do while(p_entity .ne. 0) 
c
c Should all be qualifiers, but you never know
c
	  if(entity.header.subtype .eq. entity_block_subtype_qualifier) then
c
c See if it matches
c
	    if(table__compare(line,entity,qual,nk_qual,negated)) then
	      goto 90
	    endif
	  else
c
c Ingore status from auto_msg
c
	    call auto_msg(ptr_terminal_info,auto_msg_expqual)
	  endif
c
c Try the next one
c
	  p_entity = table__tro(table_info,entity.next_tro)
	end do
	istat = 0
	goto 99
c
c Remember the pointer
c
90	ptr_entity = p_entity
c
c Return the status (0=no more, 1=oke)
c
99	table_list_command_qual = istat
	return
	end
	subroutine table_get_default(ptr_entity,def_des)
	implicit none
c
c Return a descriptor to the default string
c
	include 'table.inc'
c
	integer*4 ptr_entity		!:i: ptr to entirty block
	integer*4 def_des(2)		!:o: descriptor for default value
c#
c
	integer*4 ipos
c
c The entity block
c 
	record /entity_block/ entity
	pointer (p_entity,entity)	
c
	p_entity = ptr_entity
c
c Return the default value
c
c defval_bro contains a list of values 
c the total structure is
c  nbyte_total
c  bytecounted string1
c  bytecounted string2
c  bytecounted string3
c  ...etc
c
c We return the first value
c
	ipos = entity.defval_bro
c
	if(ipos .ne. 0) then
	  ipos = ipos + %loc(entity) - %loc(entity.rest) + 2
c
c Now ipos points to the first string
c
	  def_des(1) = zext(entity.rest(ipos))
	  def_des(2) = %loc(entity.rest(ipos+1))	
	else
	  def_des(1) = 0
	  def_des(2) = %loc(entity.rest)	
	endif
c
	return
	end
	function table_list_user(ptr_table_info,user_entity,
     1          line,value,nk_value,ptr_entity,negated)
	implicit none
c
c try to match the line to the name of the next user defined type
c after (no) match update the pointer to the next
c
	include 'table.inc'
	integer*4 ptr_table_info
c
	integer*4 user_entity	!:io: pointer to user block
	character*(*) line	!:i: match string
	character*(*) value	!:o: returned match value
	integer*4 nk_value	!:o: length of value
	integer*4 ptr_entity	!:o: return value for entity
	logical*4 negated	!:o: true is matchwas a negated one
	logical table_list_user	!:f: function result
c#
	record /table_info/ table_info
	pointer (p_table_info,table_info)
c
	record /entity_block/ entity
	pointer (p_entity,entity)	
c
	integer*4 istat
c
	integer*4 table__tro
	logical*4 table__compare
c
	character*(max_name) name_work
	integer*4 nk_work
c
	p_table_info = ptr_table_info
c
	istat = 1		!assume match found
c
c  Keep going until pointer=0
c
	do while(user_entity .ne. 0)
	  p_entity = user_entity
	  user_entity = table__tro(table_info,entity.next_tro)
c
c Now see if type matches
c
	  if(table__compare(line,entity,name_work,nk_work,negated)) then
	    ptr_entity = p_entity
	    value = name_work(1:nk_work)
	    nk_value = nk_work
	    goto 90
	  endif
	enddo
c
c So sorry, no match
c
	istat  = 0
c
90	table_list_user = istat
	return
	end		  
	function table__compare(item,entity,name,nk_name,negated)
	implicit none
c
c See if item matches the name of the entity
c
	include 'table.inc'
	record /entity_block/ entity 	!:i: the entity
	character*(*) item		!:i: the name to match
	character*(*) name		!:o: found match name
	integer*4 nk_name		!:o: length of name
	logical negated			!:o: trur is match negated
	logical*4 table__compare	!:f: true if match
c#
	integer*4 nk,nk_temp_name
	logical*4 neg
	character*(max_name) temp_name
c
	integer*4 str$case_blind_compare
c
	table__compare = .true.	!assume match is oke
c
c Extract the name
c
	call table__name_copy(entity,entity.name_bro,temp_name,nk_temp_name)
c
c len(item) must be <= nk_temp_name
c
	nk = len(item)
	neg = .false.
c
	if(nk .le. nk_temp_name) then
	  if(str$case_blind_compare(item(1:nk),
     1                              temp_name(1:nk)) .eq. 0) goto 90
	endif
c
c Check if negatable allowed
c
        if(btest(entity.header.flags,entity_block_flag_neg)) then
c
c Now see if item matches NOname
c
c
	  neg = .true.
	  temp_name = 'NO'//temp_name
	  nk_temp_name = nk_temp_name + 2
	  if(nk .ge. 2 .and. nk .le. nk_temp_name) then
	    if(str$case_blind_compare(item(1:nk),
     1                          'NO'//temp_name(1:nk)) .eq. 0) goto 90
	  endif
	endif
c
c  No match, so return 0
c
	table__compare = .false.
	goto 99
90	negated = neg
	name    = temp_name(1:nk_temp_name)
	nk_name = nk_temp_name
c
99	return
	end
c
c
	subroutine table_get_command_data(ptr_table_info,
     1          ptr_command,command_info)
	implicit none
c
c Get the min_,max_params, n_qualifiers fields of the command
c but only if the _par,m bit is set, else leave them unchanged
c 
	include 'table.inc'
	integer*4 ptr_table_info	!:i: table info
	integer*4 ptr_command		!:i: pointer to command block	
	record /command_info/ command_info !:o: data
c
	record /command_block/ command
	pointer (p_command,command)
c
	integer*4 npar
c
	integer*4 table__tro
c
	record /table_info/ table_info	!:i: table info
	pointer (p_table_info,table_info)
c
	record /entity_block/ entity
	pointer (p_entity,entity)	
c
c Now set pointer to command block
c
	p_table_info = ptr_table_info
	p_command = ptr_command
c
c Now set min/max parameters
c But only if the _parms bit is set in the flags
c
c .npar is a byte of two nibbles
c  the low  4 bits contain the .min_param
c  the high 4 bits contain the .max_param
c  
	if(btest(command.header.flags,command_block_flag_parms)) then
	  npar = zext(command.param_count)
	  command_info.npar_min = iand(npar,15)
	  npar = npar/16 
	  command_info.npar_max = iand(npar,15)
	  command_info.par_addr = table__tro(table_info,command.param_tro)
	endif
c
c If this entry has quals, update the pointers
c
	if(btest(command.header.flags,command_block_flag_quals)) then
c
	  command_info.ptr_disallow  = table__tro(table_info,
     1                                            command.disallow_tro)
	  command_info.qual_addr = table__tro(table_info,
     1                                        command.qualifier_tro)
	  command_info.ptr_command = ptr_command
	endif
c
c Now take the current command 
c  and get the #qualifiers
c
	p_entity      = command_info.qual_addr
	command_info.n_qual = 0
	do while (p_entity .ne. 0)
	  command_info.n_qual = command_info.n_qual + 1
	  p_entity = table__tro(table_info,entity.next_tro)
	end do		  
	return
	end
	subroutine table_entity_name(ptr_entity,name,nk_name)
	implicit none
c
c return the name of the entity
c
	include 'table.inc'
	integer*4 ptr_entity		!:i: entity block
	character*(*) name		!:o: the name (filled with spaces)
	integer*4 nk_name		!:o: length of name(without fill)
c#
	record /entity_block/ entity
	pointer (p_entity,entity)	
c
	if(ptr_entity .eq. 0) then
	  nk_name = 0
	  call sys$fao('%%ZERO',nk_name,name)
	else
	  p_entity = ptr_entity
c
c It there was a label field, use that one
c
	  if(entity.label_bro .ne. 0) then
	    call table__name_copy(entity,entity.label_bro,name,nk_name)
	  else
c
c Else use the entity name
c
	    call table__name_copy(entity,entity.name_bro,name,nk_name)
	  endif
	endif
	return
	end
	function table_is_rest_of_line(ptr_entity,override)
	implicit none
c
c Return true is the real (or override) type is restofline
c
	include 'table.inc'
	integer*4 ptr_entity		!:i: pointer to entity block
	integer*4 override		!:i: override for value type
	logical table_is_rest_of_Line
c#
	record /entity_block/ entity
	pointer (p_entity,entity)	
c
	integer*4 test_val
c
	if(ptr_entity .eq. 0) then
c
c No entity has no type
c
	  table_is_rest_of_line = .false.
	else
c
c Take either the override or the original value
c
	  if(override .ge. 0) then
	    test_val = override
	  else
	    p_entity = ptr_entity
	    test_val = entity.valtyp 
	  endif
c
c Return true if value = restofline
c
	  table_is_rest_of_line = test_val .eq. entity_block_valtyp_restofline
	endif
	return
	end
	subroutine table_command_name(ptr_command,name,nk_name)
	implicit none
c
c Return the name of the command(verb)
c
	include 'table.inc'
	integer*4 ptr_command         	!:i: command block
	character*(max_name) name	!:o: name (filled with spaces)
	integer*4 nk_name		!:o: length (without fill)
c#
	record /command_block/ command
	pointer (p_command,command)	
c
c
	if(ptr_command .eq. 0) then
	  nk_name = 0
	  call sys$fao('%%ZERO',nk_name,name)
	else
	  p_command = ptr_command
c
c for a verb
c  Name_bro contains a list of values (the synonyms) 
c   the total structure is
c    nbyte_total
c    bytecounted string1
c    bytecounted string2
c    bytecounted string3
c    ...etc
c   We only want the first string
c FOr a syntax change
c  name_bro is just one name
c
	  if(command.header.subtype .eq. command_block_subtype_verb) then
	    call table__name_copy(command,command.name_bro+1,name,nk_name)
	  else
	    call table__name_copy(command,command.name_bro,name,nk_name)
	  endif
	endif
	return
	end
	function table_set_command_proc(ptr_table_info,symbol_info,
     1          ptr_terminal_info,verb)
	implicit none
c
c The user entered a verb that appears to be a symbols
c  and that symbol contains a @proc command
c This procedure builds a cld table that contains
c all info for an @ command.
c that means a /out=file qualifier
c         and  8 parameters p1..p8
c all parameter have type string and list
c but if the user defines antoher symbol verb_parameters,
c  the value of that symbol can be used to define p1..p8
c The contents of the symbol must be in the following layout
c  "type1,type2.."
c Upto 8 types can be defined. If you specify less, AUTO
c  will not allow you to use more than the define parameters
c the value of type1 = type or type*
c  type must be one of the defined types
c  if you append a *, pn will be of type list
c  The first type with a #, is the first not required parameter
c
	include 'table.inc'
	integer*4 ptr_table_info
	integer*4 table_set_command_proc 
	integer*4 symbol_info
	integer*4 ptr_terminal_info
	character*(*) verb
c
	record /table_info/ table_info
	pointer (p_table_info,table_info)
c
	common /table_data/ data   
	record /table_data/ data
c
c to make sure it exists after leaving this subroutine, make it common
c
	integer*4 bpos,istat
c
	integer*4 table__check_table
	integer*4 table__insert_parameters
c
c Now init
c
	bpos = 1
	p_table_info = ptr_table_info
c
	data.vector_block.header.length = sizeof(data.vector_block)
	data.vector_block.header.type   = block_type_vector
	data.vector_block.header.subtype= vector_block_subtype_dcl
	data.vector_block.header.flags  = 0
	data.vector_block.header.tro_count = 0
	data.vector_block.verbs_tro     = %loc(data.verb_header) - %loc(data)
	data.vector_block.commands_tro  = %loc(data.cmnd_header) - %loc(data)
c
c Fill the tables
c
	data.verb_header.length    = sizeof(data.verb_header) + 
     1                               sizeof(data.verbs)
	data.verb_header.type      = block_type_vector
	data.verb_header.subtype   = vector_block_subtype_verb
	data.verb_header.flags     = 0
	data.verb_header.tro_count = 0
c
	data.verbs(1)    = '@'//char(0)//char(0)//char(0)
c
	data.cmnd_header.length    = sizeof(data.verb_header) + 
     1                               sizeof(data.commands)
	data.cmnd_header.type      = block_type_vector
	data.cmnd_header.subtype   = vector_block_subtype_command
	data.cmnd_header.flags     = 0
	data.cmnd_header.tro_count = 0
c
	data.commands(1) = %loc(data.command) - %loc(data)
c
c Now fill the command block
c
	data.command.header.length = sizeof(data.command)
	data.command.header.type   = block_type_command
	data.command.header.subtype= command_block_subtype_verb
	data.command.header.flags  = 
     1              ibset(0,command_block_flag_parms) .or. 
     1              ibset(0,command_block_flag_quals)
	data.command.header.tro_count = 0
c
	data.command.param_tro     = %loc(data.par_entity(1)) - %loc(data)
	data.command.qualifier_tro = %loc(data.qual_entity)   - %loc(data)
	data.command.disallow_tro  = 0			!no disallows
	data.command.handler       = 0
	data.command.verb_type     = 0
	data.command.pad           = 0
	data.command.name_bro      = %loc(data.names(bpos))-%loc(data.command)
c
	data.names(bpos) = 3		!total length
	bpos = bpos + 1
	call table__insert_name(data.names,bpos,'@')
	data.command.image_bro     = 0
	data.command.outputs_bro   = 0
	data.command.prefix_bro    = 0
c
c Now fill the parameters (default 8*string with list)
c  and no parameter required
c
 	istat = table__insert_parameters(data,
     1           '#STRING*,STRING*,STRING*,STRING*,'//
     1           'STRING*,STRING*,STRING*,STRING*',
     1               symbol_info,ptr_terminal_info,verb,bpos)
	if(.not. istat) goto 90
c
c And now the qualifier OUTPUT
c
	data.qual_entity.header.length = sizeof(data.par_entity(1))
	data.qual_entity.header.type   = block_type_entity
	data.qual_entity.header.subtype= entity_block_subtype_qualifier
	data.qual_entity.header.flags  = 
     1           ibset(0,entity_block_flag_list) .or. 
     1           ibset(0,entity_block_flag_val) .or. 
     1           ibset(0,entity_block_flag_parm)
	data.command.header.tro_count  = 0
	data.qual_entity.next_tro      = 0
	data.qual_entity.syntax_tro    = 0
	data.qual_entity.user_type_tro = 0
	data.qual_entity.number        = 0	
	data.qual_entity.valtyp        = entity_block_valtyp_outfile		!output file
	data.qual_entity.name_bro      = %loc(data.names(bpos))-
     1                                   %loc(data.qual_entity)
	call table__insert_name(data.names,bpos,'OUTPUT')
	data.qual_entity.label_bro     = 0
	data.qual_entity.prompt_bro    = 0
	data.qual_entity.defval_bro    = 0
c
c Always return .TRUE. (since check_verb should not have a problem)
c
	istat = table__check_table(%loc(data),table_info,bpos)
c
90	table_set_command_proc = istat
	return
	end              
	subroutine table__insert_name(names,bpos,txt)
	implicit none
c
c Insert a name in the BRO section
c
	byte names(*)		!:o: the name field (the BRO area)
	integer*4 bpos          !:io: the pointer in the names field
	character*(*) txt	!:i: the name to insert
c
	names(bpos) = len(txt)
	call lib$movc3(len(txt),%ref(txt),names(bpos+1))
	bpos = bpos + 1 + len(txt)
	return
	end
	function table_close_image(ptr_table_info)
	implicit none
c
c Close the current image, and set tables back to DCL
c
	include 'table.inc'
	integer*4 ptr_table_info	!:o: table block
	integer*4 table_close_image
c
	integer*4 istat
c
	integer*4 table_info_close
	integer*4 table__set_dcl
c
	record /table_info/ table_info	!:o: table block
	pointer (p_table_info,table_info)
c
c Close the image
c
	p_table_info = ptr_table_info
	istat = table_info_close(ptr_table_info)
	if(.not. istat) goto 90
c
c And revert to DCL tables
c
	istat = table__set_dcl(table_info)
c
90	table_close_image = istat
	return
	end

	function table_set_image(ptr_table_info,fnam,ptr_terminal_info,
     1                           special,verb,
     1                           symbol_info,verb_input)
	implicit none
c
c This routine processes settings of images
c  It will map the image and try to locate the
c  cld tables in the image.
c  if this is sucessful, set the table_info th the found table
c  if not, assume one parameter $restofline (unless the user 
c   defines a symbol 'verb'_parameters with the expected parameters
c
	include 'table.inc'
	integer*4 ptr_table_info	!:o: table block
	character*(*) fnam		!:i: the file to map
	integer*4 ptr_terminal_info
	logical*4 special		!:o: special action for images with only one verb
	character*(*) verb		!:o: returns the first (nad maybe the only) verb
	integer*4 symbol_info		!:i: the  symbol structur
	character*(*) verb_input	!:i: The verb input
	integer*4 table_set_image	!:f: function result
c
	integer*4 lun_i,istat,inadr(2),nword,flags,ptr_table
	integer*4 nk_what,ptr_command,exact,nk_verb,idx
	character*1 what
	integer*4 nverbs
c
	record /table_info/ table_info
	pointer (p_table_info,table_info)
c
	record /table_data/ data
	common /data/ data
c
c to make sure it exists after leaving this subroutine, make it common
c
	include '($secdef)'
c
        integer*2 channel
	integer*4 nblocks
        common /channel_message/ nblocks,channel
c
	external table__user_open_vb
	integer*4 table__user_open_vb
	integer*4 table__check_table
	integer*4 table__search_item
	integer*4 table__set_restofline
	integer sys$crmpsc
	external auto_msg_tabnotf
c
c  Try to ope the file
c    this will check on accessibility
c  and is needed for the crmpsc
c
	p_table_info = ptr_table_info
	call lib$get_lun(lun_i)
	open(lun_i,file=fnam,status='old',readonly,
     1             defaultfile='sys$system:.exe',
     1             useropen=table__user_open_vb,err=80)
c
c Now we have the channel and the #blocks 
c try to map into vm
c
	flags = sec$m_expreg
	inadr(1) = 512
	inadr(1) = 512
c
	table_info.chan_imag = channel
        istat = sys$crmpsc(inadr,table_info.retadr,
     1          %val(0),%val(flags),,,
     1          ,%val(channel),%val(nblocks),%val(1),,)
	if(.not. istat) goto 80
c
c  Now look in memory for a datastructure like a cld table
c  this is not completely fool-proof, but good enough (I hope)
c
	nword = (table_info.retadr(2)-table_info.retadr(1))/2
	istat = table__search_item(nword,%val(table_info.retadr(1)),ptr_table)
c
	if(istat) then
c
c We have a structure (in the image) that looks like a cld table
c
	  istat = table__check_table(ptr_table,table_info,nverbs)
	  if(.not. istat) goto 70
	  special = (nverbs .eq. 1) .and. .not. table_info.verbone
	  if(special) then
c
c Return the first verb
c
	    idx = 1
	    nk_what = 0
	    call table_match_verb(ptr_table_info,what(1:nk_what),
     1                            verb,nk_verb,idx,
     1                            ptr_command,exact)
	  endif
	  goto 90
	else
c
c Now revert to a simple command line
c  $restofline
c
	  istat = table__set_restofline(data,verb_input,
     1              symbol_info,ptr_terminal_info)
	  if(.not. istat) goto 90
c
c set_restofline filled the data structure
c  since it is in common, the contents will not be lost when
c  we leave this routine
c
	  ptr_table = %loc(data)
	  istat = table__check_table(ptr_table,table_info,nverbs)
	  ptr_command = %loc(data.command)
	  special = .true.		!no verb
	  verb = data.verbs(1)
	endif
c
c Could not find the table, so return the memory
c
70	call table_info_close(ptr_table_info)
	goto 90
c
c OPen went wrong, get the reason
c
80	call errsns(,istat)
c
90	table_set_image = istat
	return
	end
 	function table__set_restofline(data,verb,ptr_symbol_info,
     1                                 ptr_terminal_info)	  
	implicit none
c
c Create a command table for one parameter (type $restofline)
c  Unless the user define a symbol 'verb'_parameters
c
	include 'table.inc'
	record /table_data/ data		!:o: filled
	character*(*) verb 			!:i: the verb
	integer*4 ptr_symbol_info  			!:i: symbol table info
	integer*4 ptr_terminal_info			!:i: terminal info
	integer*4 table__set_restofline		!:f: function result
c#
	integer*4 bpos,istat
c
	integer*4 table__insert_parameters
c
	bpos = 1
c
c  Normally we would assume $restofline
c  for images withou CLD tables.
c  but if the user defines a symbol 
c
	data.vector_block.header.length = sizeof(data.vector_block)
	data.vector_block.header.type   = block_type_vector
	data.vector_block.header.subtype= vector_block_subtype_dcl
	data.vector_block.header.flags  = 0
	data.vector_block.header.tro_count = 0
	data.vector_block.verbs_tro     = %loc(data.verb_header) - 
     1                                    %loc(data)
	data.vector_block.commands_tro  = %loc(data.cmnd_header) - 
     1                                    %loc(data)
c
c Fill the tables
c
	data.verb_header.length    = sizeof(data.verb_header) + 
     1                               sizeof(data.verbs)
	data.verb_header.type      = block_type_vector
	data.verb_header.subtype   = vector_block_subtype_verb
	data.verb_header.flags     = 0
	data.verb_header.tro_count = 0
c
	data.verbs(1)    = 'DUMM'
c
	data.cmnd_header.length    = sizeof(data.verb_header) + 
     1                               sizeof(data.commands)
	data.cmnd_header.type      = block_type_vector
	data.cmnd_header.subtype   = vector_block_subtype_command
	data.cmnd_header.flags     = 0
	data.cmnd_header.tro_count = 0
c
	data.commands(1) = %loc(data.command) - %loc(data)
c
c Now fill the command block
c
	data.command.header.length = sizeof(data.command)
	data.command.header.type   = block_type_command
	data.command.header.subtype= command_block_subtype_verb
	data.command.header.flags  = ibset(0,command_block_flag_parms)
	data.command.header.tro_count = 0
c
	data.command.param_tro     = %loc(data.par_entity(1)) - %loc(data)
	data.command.qualifier_tro = 0			!no qualifier
	data.command.disallow_tro  = 0			!no disallows
	data.command.handler       = 0
	data.command.verb_type     = 0
	data.command.pad           = 0
	data.command.name_bro      = %loc(data.names(bpos))-%loc(data.command)
c
	data.names(bpos) = 6		!total length
	bpos = bpos + 1
	call table__insert_name(data.names,bpos,'DUMM')
	data.command.image_bro     = 0
	data.command.outputs_bro   = 0
	data.command.prefix_bro    = 0
c
c Now insert all parameters
c
	istat = table__insert_parameters(data,'#RESTOFLINE',
     1               ptr_symbol_info,ptr_terminal_info,verb,bpos)
90	table__set_restofline = istat
	return
	end
	function table__insert_parameters(data,paramstring,
     1           ptr_symbol_info,ptr_terminal_info,verb,bpos)
	implicit none
c
c Insert the parameter definitions for 
c  either a @ command (default 8 strings)
c  or an image with no CLD , default 1 parameter restofline
c
c  The user can overrule the types with a symbol 'verb'_parameter
c
	include 'table.inc'
	record /table_data/ data		!:o: filled
	character*(*) paramstring		!:i: default parameter string
	integer*4 ptr_symbol_info			!:i: symbol block
	integer*4 ptr_terminal_info			!:i: terminal block
	character*(*) verb			!:i: verb name
	integer*4 bpos				!:io: position for names in BRO area
	integer*4 table__insert_parameters	!:f: function result
c
	integer*4 n_arg,n_minarg,ielement,nkres,ipos,imatch,ityp,nk_result
	integer*4 istat,nk,k
	logical*4 seen_max,list,exact
	character*255 res,typenam,result
c
	integer*4 str$element
	logical symbols_match
	integer*4 auto_msg
	external auto_msg_settyp
	external auto_msg_invtyp
	external auto_msg_ambtyp
c
c See if the user defined a symbol 'verb'_parameter
c
        call symbols_rewind(ptr_symbol_info,ptr_terminal_info)
        if(symbols_match(ptr_symbol_info,verb//'_PARAMETERS',
     1                   result,nk_result,exact,0,
     1                   ptr_terminal_info,.false.)) then
c
          call symbols_get_value(ptr_symbol_info,result,nk_result)
c
c Make it uppercase
c
          call str$upcase(result(1:nk_result),result(1:nk_result))
c
	  istat = auto_msg(ptr_terminal_info,auto_msg_settyp,
     1                   result(1:nk_result))
	  if(.not. istat) goto 90
        else
c
c Take the default value (one restofline)
c
	  nk_result = len(paramstring)
	  call str$upcase(result,paramstring)
        endif
c
c
	seen_max = .false.
	ielement  = 0
	n_arg     = 0
	n_minarg  = 0
c
	do while(str$element(res,ielement,',',result(1:nk_result)))
c
c See if we found a #, if so, this is the first optional
c  parameter.
c
	  ipos = index(res,'#')
	  if(ipos .ne. 0) then
	    seen_max = .true.
	    res = res(1:ipos-1)//res(ipos+1:)
	  endif
	  ielement = ielement + 1
	  n_arg = ielement
	  if(.not. seen_max) n_minarg = n_minarg + 1
c
c Now res has a symbol type, see if we can find it
c
	  ipos = index(res,'*')
	  if(ipos .ne. 0) then
c
c We found an *, this means list
c
	    list = .true.
	    res = res(1:ipos-1)//res(ipos+1:)
	  else
	    list = .false.
	  endif
c
c get the length
c
	  nkres = index(res,' ')-1
c
c Set match to -1 (undefined)
c
	  imatch = -1
	  do ityp=0,entity_block_valtyp_last_entry
	    call table_get_type_name(ityp,typenam,nk)
	    call str$upcase(typenam,typenam)
	    if(typenam(1:nkres) .eq. res(1:nkres)) then
	      if(imatch .ge. 0) goto 41	!ambiguous
c
c Set the type
c
	      imatch = ityp
	    endif
	  end do
	  if(imatch .ge. 0) goto 44
c
c No match found
c
	  istat = auto_msg(ptr_terminal_info,auto_msg_invtyp,res(1:nkres),
     1                  verb//'_PARAMETER')
	  if(.not. istat) goto 90
	  goto 42
c
c Ambig type
c
41	  istat = auto_msg(ptr_terminal_info,auto_msg_ambtyp,res(1:nkres),
     1                  verb//'_PARAMETER')
	  if(.not. istat) goto 90
c
c Take the default
c
42	  imatch = entity_block_valtyp_string
	  list = .true.	  
c
44	  data.par_entity(n_arg).header.length = sizeof(data.par_entity(1))
	  data.par_entity(n_arg).header.type   = block_type_entity
	  data.par_entity(n_arg).header.subtype= entity_block_subtype_parameter
c
c Set the flags
c
	  data.par_entity(n_arg).header.flags  = 
     1            ibset(0,entity_block_flag_val) .or. 
     1            ibset(0,entity_block_flag_parm)
c
c If list insert the list bit
c
	  if(list) data.par_entity(n_arg).header.flags  = 
     1             data.par_entity(n_arg).header.flags  .or.
     1            ibset(0,entity_block_flag_list)  
c
	  data.command.header.tro_count = 0
c
c See if there is another element
c
	  if(str$element(res,ielement,',',result(1:nk_result))) then
c
c There is another one, so link to the next
c
	    data.par_entity(n_arg).next_tro = 
     1                %loc(data.par_entity(n_arg+1))-%loc(data)
	  else
c
c No more, set link to 0
c
	    data.par_entity(n_arg).next_tro = 0
	  endif
	  data.par_entity(n_arg).syntax_tro    = 0
	  data.par_entity(n_arg).user_type_tro = 0
	  data.par_entity(n_arg).number        = 0	
c
c Insert the type
c
	  data.par_entity(n_arg).valtyp        = imatch		!what the user wanted
	  data.par_entity(n_arg).name_bro      = %loc(data.names(bpos))-
     1                                       %loc(data.command)
	  call table__insert_name(data.names,bpos,'P'//char(n_arg+ichar('0')))
	  data.par_entity(n_arg).label_bro     = 0
	  data.par_entity(n_arg).prompt_bro    = 0
	  data.par_entity(n_arg).defval_bro    = 0
	end do
c
c Now set the #arguments
c Fortan uses signed bytes, and tyhe following integer
c  may not fit in a (signed) byte, so we use the
c  lib$movc3 to move the byte
c
	k = n_arg*16+n_minarg	
	call lib$movc3(1,k,data.command.param_count)
c
	istat = 1
90	table__insert_parameters = istat
	return
	end
	function table_exit(ptr_table_info)
	implicit none
c
c Exit on exit of auto
c
	include 'table.inc'
	integer*4 ptr_table_info
	integer*4 table_exit
c
	integer*4 istat
c
	integer*4 table_info_close
	integer*4 lib$free_vm
c
	record /table_info/ table_info	!:io: table block
	pointer (p_table_info,table_info)
c
c Clear possible open image
c
	p_table_info = ptr_table_info
c
	istat = table_info_close(ptr_table_info)
	if(.not. istat) goto 90
c
	istat = lib$free_vm(sizeof(table_info),table_info)
	if(.not. istat) goto 90
	ptr_table_info = 0
c
90	table_exit = istat
	return
	end

	function table_info_close(ptr_table_info)
	implicit none
c
c Close open image (if opened)
c
	include 'table.inc'
	integer*4 ptr_table_info
	integer*4 table_info_close
c
	record /table_info/ table_info
	pointer (p_table_info,table_info)
c
	integer sys$deltva
	integer sys$dassgn
c
	integer*4 inadr(2),istat
c
c See if there is something mapped
c
	istat = 1
	p_table_info = ptr_table_info
c
	if(table_info.retadr(1) .ne.0) then
	  istat = sys$deltva(table_info.retadr,inadr,%val(0))
	  if(.not. istat) goto 90	  
	  table_info.retadr(1) = 0
	endif
c
c See if still channel open
c
	if(table_info.chan_imag .ne. 0) then
	  istat = sys$dassgn(%val(table_info.chan_imag))
	  if(.not. istat) goto 90	  
	  table_info.chan_imag = 0
	end if
c
c
90	table_info_close = istat
	return
	end
        function table__user_open_vb(fab)		!,rab,lun)
        implicit none
        include '($fabdef)'
c
c Useropen for crmpsc, we need to set the UFO bit
c
c
        record /fabdef/ fab
        integer*4 table__user_open_vb
c
        integer*4 istat,sys$open
        integer*2 channel
	integer*4 nblocks
        common /channel_message/ nblocks,channel
c
c Set the UFO bit
c
        fab.fab$l_fop = fab.fab$l_fop .or. fab$m_ufo
        fab.fab$b_rtv = -1
c
c open the file, connect is not needed
c
        istat = sys$open(fab,,)
c
c Return channel and #blocks through common
c
        channel = fab.fab$l_stv
	nblocks = fab.fab$l_alq
        table__user_open_vb = istat
        return
        end
	options /exten
	function table__search_item(nword,data,location)
	implicit none
c
c Search verb control blocks in  memory
c  the file is mapped starting at address data (nword words long)
c
	integer nword		!:i: lengh of data in words(integer*2
	integer*2 data(*)	!:i: tghe memory data
	integer*4 location	!:o: the spot where the table was found
	logical table__search_item	!:f: the result
c
	integer k,istat
c
	include 'table.inc'
	record /vector_block/ vector_block
	record /verbs/ verbs
	pointer (p_vector_block,vector_block)
	pointer (p_verbs,verbs)
c
c We are looking for a strture
c  vector_block  integer*2 size     : should be 20 (sizeof vectro_block)
c                byte type          : should be 1
c                byte subtype       : should be 1
c                integer*2 flags    : any value
c                integer*2 tro_count: should be 2
c                integer*4 verbs_tro: should point to just beyond vector_block
c                                     (and thus should contain 20)
c                integer*4 commands_tro : any value
c                integer*4 size     : any value
c  verbs_block   integer*2 size     : any value
c                byte type          : should be 1
c                byte subtype       : shgould be 3
c                integer*2 flags    : should be 0
c                integer*2 tro_count: should be 0
c
	istat = 0
c
	do k=1,nword
	  if(data(k) .eq. sizeof(vector_block)) then
	    p_vector_block = %loc(data(k))
	    p_verbs = %loc(data(k)) + sizeof(vector_block)
c
	    if(vector_block.header.type    .eq. block_type_vector .and.
     1         vector_block.header.subtype .eq. vector_block_subtype_dcl) then
	      if(vector_block.header.tro_count .eq. 2) then
	        if(vector_block.verbs_tro .eq. sizeof(vector_block)) then
	          if(verbs.header.type    .eq. block_type_vector .and.
     1               verbs.header.subtype .eq. vector_block_subtype_verb) then
	            if(verbs.header.flags .eq. 0 .and.
     1                 verbs.header.tro_count .eq. 0) then
	               location = %loc(data(k))
	               istat = 1
	               goto 90
	            endif
	          endif
	        endif
	      endif
	    endif
	  endif
	end do
90	table__search_item = istat
	return
	end
	function table_check_disallow(ptr_terminal_info,ptr_table_info,
     1                                ptr_token_info,
     1                                ptr_disallow,ptr_entity,
     1                                ptr_command)
	implicit none
c
c Check if the new token is disallowed with the current state
c
	include 'table.inc'
c
	integer*4 ptr_terminal_info
	integer*4 ptr_table_info	!:i: table info block
	integer*4 ptr_token_info  		!:i: poinbter to token info block
	integer*4 ptr_disallow		!:i: pointer to disallow structure
	integer*4 ptr_entity		!:i: pointer to entity
	integer*4 ptr_command		!:i: parent command block
	logical table_check_disallow	!:f: false is disallowed
c
	record /table_info/ table_info	!:i: table info bkock
	pointer (p_table_info,table_info)
c
	integer*4 nk_name,nk
	character*(max_name) name
	character*80 line
	integer*4 istat
c
	logical table__dis
c
	p_table_info = ptr_table_info
c
	call table_entity_name(ptr_entity,name,nk_name)
	call sys$fao('Checking disallow ptr = !8XL for !AS',nk,line,
     1                %val(ptr_disallow),name(1:nk_name))
c
	call terminal_debug(ptr_terminal_info,line(1:nk),0,dbg_flag_dis)
	if(ptr_disallow .ne. 0) then
c
c Go do the test
c
	  istat = .not. table__dis(table_info,ptr_terminal_info,ptr_token_info,
     1               %val(ptr_disallow),name(1:nk_name),
     1                0,0,ptr_command)
	else
	  istat = 1
	end if
	table_check_disallow = istat
	return
	end	
	options /recursive
	function table__dis(table_info,ptr_terminal_info,
     1                      ptr_token_info,
     1                      expression,new_name,operator,level,
     1                      ptr_command)
	implicit none
c
c  Return true if match found
c
	include 'table.inc'		
c
	record /table_info/ table_info	!:i: table info block
	integer*4 ptr_terminal_info	!:i: terminal info block
	integer*4 ptr_token_info	!:i: token
	record /expression_block/ expression    !:i: expression block
	character*(*) new_name		!:i: new name
	integer*4 operator              !:i: operator
	integer*4 level                 !:i: level of depth
	integer*4 ptr_command		!:i: pointer to command block
	logical*4 table__dis		!:f: true if match found (so a disallow found)
c
	integer*4 p_entity
c
	integer*4 result,res,k,cnt,oper
	logical negated
	record /expression_block/ expres
	pointer(p_expres,expres)
	character*(max_name) name
	integer*4 nk_name
	character*6 oper_name
	character*6 resa
	character*10 leva
	integer*2 nk_leva
c
	integer*4 token_lookup
	integer*4 table__tro
c
	call sys$fao('L!UL ',nk_leva,leva,%val(level))
	if(expression.header.subtype .eq. expression_block_subtype_path) then
c
c operator can be
c    not,any2,and,or,xor,neg
c
	  cnt = 0
	  call table__get_opername(operator,oper_name)
	  call terminal_debug(ptr_terminal_info,
     1              leva(1:nk_leva)//
     1              'Check names for oper '//oper_name,level+1,
     1               dbg_flag_dis)
	  do k=1,expression.header.tro_count
	    p_entity = table__tro(table_info,expression.tro(k))
	    call table_entity_name(p_entity,name,nk_name)
	    res = token_lookup(ptr_token_info,name(1:nk_name),
     1                         negated,ptr_command)
	    if(.not. res) then
	      if(name(1:nk_name) .eq. new_name) then
	        res = .true.
	        negated = .false.
	        resa = 'Presnt'
	      elseif(name(1:nk_name) .eq. 'NO'//new_name) then
	        res = .true.
	        negated = .true.
	        resa = 'P(N)'
	      else
	        resa = 'Absent'
	      endif
	    else
	      resa = 'Presnt'
	    endif
	    if(k .eq. 1) result = res
	    call terminal_debug(ptr_terminal_info,
     1              leva(1:nk_leva)//
     1           'Par '//name(1:nk_name)//' res '//resa,level+3,
     1               dbg_flag_dis)
c
	    if(operator .eq. expression_block_subtype_not) then
	      result = .not. res
	    elseif(operator .eq. expression_block_subtype_any2) then
	      if(res) cnt = cnt + 1
	      if(cnt .gt. 1) goto 50
	    elseif(operator .eq. expression_block_subtype_and) then
	      result = result .and. res
	      if(.not. result) goto 50
	    elseif(operator .eq. expression_block_subtype_or) then
	      result = result .or. res
	      if(result) goto 50
	    elseif(operator .eq. expression_block_subtype_xor) then
	      if(k .gt. 1) result = result .xor. res
	    elseif(operator .eq. expression_block_subtype_neg) then
	      result = res .and. negated		!should not happen
	    endif	    
	  end do
50	  if(operator .eq. expression_block_subtype_any2) then
	    result = cnt .gt. 1
	  endif
	  resa = 'False'
	  if(result) resa = 'True'
	  call terminal_debug(ptr_terminal_info,
     1              leva(1:nk_leva)//
     1              'Final name '//oper_name//' res '//resa,level+2,
     1               dbg_flag_dis)
	  table__dis = result
	else
	  oper = expression.header.subtype
	  call table__get_opername(oper,oper_name)
	  call terminal_debug(ptr_terminal_info,
     1              leva(1:nk_leva)//
     1              'Check operand '//oper_name,level+1,
     1               dbg_flag_dis)
	  do k=1,expression.header.tro_count
	    p_expres = table__tro(table_info,expression.tro(k))
	    res = table__dis(table_info,ptr_terminal_info,ptr_token_info,
     1                      expres,new_name,oper,level+1,ptr_Command)
c
	    resa = 'False'
	    if(res) resa = 'True'
	    call terminal_debug(ptr_terminal_info,
     1              leva(1:nk_leva)//
     1           'Partial result res '//resa,level+3,
     1               dbg_flag_dis)
	    cnt = 0
	    if(k .eq. 1) result = res
	    if(oper .eq. expression_block_subtype_not) then
	      result = res
	    elseif(oper .eq. expression_block_subtype_any2) then
	      if(res) cnt = cnt + 1
	      if(cnt .gt. 1) goto 70	     
	    elseif(oper .eq. expression_block_subtype_and) then
	      result = result .and. res
	      if(.not. result) goto 70
	    elseif(oper .eq. expression_block_subtype_or) then
	      result = result .or. res
	      if(result) goto 70
	    elseif(oper .eq. expression_block_subtype_xor) then
	      if(k .gt. 1) result = result .xor. res
c	    elseif(oper .eq. expression_block_subtype_neg) then
c	      result = res .and. negated
	    endif	    
	  end do
c
70	  if(oper .eq. expression_block_subtype_any2) then
	    result = cnt .gt. 1
	  endif
	  resa = 'False'
	  if(result) resa = 'True'
	  call terminal_debug(ptr_terminal_info,
     1            leva(1:nk_leva)//
     1           'Final result '//oper_name//' res '//resa,level+2,
     1               dbg_flag_dis)
	end if
	table__dis = result
	return
	end
	subroutine table__get_opername(oper,name)
	implicit none
c
c Return the operatorname for the operator
c
	include 'table.inc'
	integer*4 oper
	character*(*) name
c
	if(oper .eq. expression_block_subtype_not) then
	  name = 'NOT'
	elseif(oper .eq. expression_block_subtype_any2) then
	  name = 'ANY2'
	elseif(oper .eq. expression_block_subtype_and) then
	  name = 'AND'
	elseif(oper .eq. expression_block_subtype_or) then
	  name = 'OR'
	elseif(oper .eq. expression_block_subtype_xor) then
	  name = 'XOR'
	elseif(oper .eq. expression_block_subtype_neg) then
	  name = 'NEG'
	endif	    
	return
	end
	function table_check_cqual_init(ptr_table_info,ptr_terminal_info,
     1                                  ptr_command,qual_addr)
	implicit none
c
c Return true if all qualifiers for the cqual-routines are present
c
	include 'table.inc'
	integer*4 ptr_table_info
	integer*4 ptr_terminal_info
	integer*4 ptr_command
	integer*4 qual_addr
	logical table_check_cqual_init	
c
	record /table_info/ table_info
	pointer (p_table_info, table_info)
c
	character*(max_name) qual
	integer*4 nk_qual,flag,ptr_entity,nk
	logical*4 negated
	character*1 kar
c
	integer*4 table_list_command_qual
c
	p_table_info = ptr_table_info
	flag = 0
	ptr_entity = 0
	nk = 0
	do while(table_list_command_qual(ptr_table_info,ptr_terminal_info,
     1                                   ptr_command,
     1                                   kar(1:nk),qual,nk_qual,
     1                                   ptr_entity,negated,qual_addr))
	  if(qual(1:nk_qual) .eq. 'BEFORE')  flag = flag + 1
	  if(qual(1:nk_qual) .eq. 'SINCE')   flag = flag + 1
	  if(qual(1:nk_qual) .eq. 'CREATED') flag = flag + 1
	  if(qual(1:nk_qual) .eq. 'MODIFIED')flag = flag + 1
	  if(qual(1:nk_qual) .eq. 'EXPIRED') flag = flag + 1
	  if(qual(1:nk_qual) .eq. 'BACKUP')  flag = flag + 1
	end do
	if(flag .eq. 6) then
	  kar = 'Y'
	  table_check_cqual_init = 1
	else
	  kar = 'N'
	  table_check_cqual_init = 0
	endif
	call terminal_debug(ptr_terminal_info,'Check for cqual_init = '//kar,
     1           0,dbg_flag_tok)
	return
	end
	function table_check_cqual(ptr_table_info,ptr_token_info,ptr_command)
	implicit none
c
c Check if all qualifiers present
c
	include 'table.inc'
	integer*4 ptr_table_info
	integer*4 ptr_token_info
	integer*4 ptr_command
	logical table_check_cqual
c
c If any of the expired or created or modified or backup
c  has been specified, there also must be at least
c  a /before or /since present
c
	record /table_info/ table_info
	pointer (p_table_info,table_info)
c
	integer*4 istat
	logical*4 negated
	integer*4 token_lookup
c
	external auto_msg_nobefsin
	external auto_msg_befandsin
c
	p_table_info = ptr_table_info
c
	istat = token_lookup(ptr_token_info,'CREATED',negated,ptr_command)
	if(istat .and. .not. negated) goto 50
c
	istat = token_lookup(ptr_token_info,'MODIFIED',negated,ptr_command)
	if(istat .and. .not. negated) goto 50
c
	istat = token_lookup(ptr_token_info,'BACKUP',negated,ptr_command)
	if(istat .and. .not. negated) goto 50
c
	istat = token_lookup(ptr_token_info,'EXPIRED',negated,ptr_command)
	if(istat .and. .not. negated) goto 50
c
c No specials specified, check is ok
c
	goto 90
c
c One of the specials was there, now the must be at least
c a /since or a /before
c
50	istat = token_lookup(ptr_token_info,'SINCE',negated,ptr_command)
	if(istat .and. .not. negated) goto 70
c
c No /since, check for the /before
c
	istat = token_lookup(ptr_token_info,'BEFORE',negated,ptr_command)
	if(istat .and. .not. negated) goto 90	!oke now
c
c No /sinc and no /before, error
c
	istat = %loc(auto_msg_nobefsin)
	goto 99
c
c /sinc is present, /before must not also be present
c		
70	istat = token_lookup(ptr_token_info,'BEFORE',negated,ptr_command)
	if(.not. istat .or. .not. negated) goto 90	!all oke now
c 
c Both present, error
c
	istat = %loc(auto_msg_befandsin)
	goto 99
c
c Oke exit
c
90	istat = 1
c
99	table_check_cqual = istat
	return
	end
	subroutine table_override(override)
	implicit none
c
c Get the next override possibility
c
	include 'table.inc'
	integer*4 override              !io: override number
c
c Increase type, and roll around over the top
c
10	override = override + 1
	if(override .gt. entity_block_valtyp_last_entry) override = 0
c
c Skip some special formats, they are not used
c
	if(override .eq. entity_block_valtyp_$test1       ) goto 10
	if(override .eq. entity_block_valtyp_$test2       ) goto 10
	if(override .eq. entity_block_valtyp_$test3       ) goto 10
c
	return
	end
	options /exten
	subroutine table_get_type_name(ent_type,line,nkar)
	implicit none
c
c Return the name of the ent_type
c
	include 'table.inc'
	integer*4 ent_type		!:i: the type
	character*(*) line		!:o: the name of the entry_type
	integer*4 nkar			!:o: length or the name
c
	if(ent_type .eq. entity_block_valtyp_string       ) line = 'string'
	if(ent_type .eq. entity_block_valtyp_infile       ) line = 'infile       '
	if(ent_type .eq. entity_block_valtyp_outfile      ) line = 'outfile      '
	if(ent_type .eq. entity_block_valtyp_number       ) line = 'number       '
	if(ent_type .eq. entity_block_valtyp_privilege    ) line = 'privilege    '
	if(ent_type .eq. entity_block_valtyp_datetime     ) line = 'datetime     '
	if(ent_type .eq. entity_block_valtyp_protection   ) line = 'protection   '
	if(ent_type .eq. entity_block_valtyp_process      ) line = 'process      '
	if(ent_type .eq. entity_block_valtyp_inlog        ) line = 'inlog        '
	if(ent_type .eq. entity_block_valtyp_outlog       ) line = 'outlog       '
	if(ent_type .eq. entity_block_valtyp_insym        ) line = 'insym        '
	if(ent_type .eq. entity_block_valtyp_outsym       ) line = 'outsym       '
	if(ent_type .eq. entity_block_valtyp_node         ) line = 'node         '
	if(ent_type .eq. entity_block_valtyp_device       ) line = 'device       '
	if(ent_type .eq. entity_block_valtyp_directory    ) line = 'directory'
	if(ent_type .eq. entity_block_valtyp_uic          ) line = 'uic          '
	if(ent_type .eq. entity_block_valtyp_restofline   ) line = 'restofline   '
	if(ent_type .eq. entity_block_valtyp_parenvalue   ) line = 'parenvalue   '
	if(ent_type .eq. entity_block_valtyp_deltatime    ) line = 'deltatime'
	if(ent_type .eq. entity_block_valtyp_quotedstr    ) line = 'quotedstr'
	if(ent_type .eq. entity_block_valtyp_file         ) line = 'file         '
	if(ent_type .eq. entity_block_valtyp_expression   ) line = 'expression   '
	if(ent_type .eq. entity_block_valtyp_$test1       ) line = '$test1        '
	if(ent_type .eq. entity_block_valtyp_$test2       ) line = '$test2        '
	if(ent_type .eq. entity_block_valtyp_$test3       ) line = '$test3        '
	if(ent_type .eq. entity_block_valtyp_acl          ) line = 'acl          '
	if(ent_type .eq. entity_block_valtyp_old_file     ) line = 'old_file'
c
	nkar = index(Line,' ')-1
	if(nkar .lt. 0) nkar = len(line)
	return
	end
c
	function table_check_override(all_over,ptr_entity,override)
	implicit none
c
c See if override is possible
c  either
c  1: type=string or restofline
c  2: user specified /override on command line
c
	include 'table.inc'
	logical*4 all_over		!:i: override for all types
	integer*4 ptr_entity  		!:i: ptr to entry block
	integer*4 override		!:o: override flag
	logical*4 table_check_override	!;:f: return true if override allowed
c
c
	record /entity_block/ entity
	pointer (p_entity,entity)	
c
	p_entity = ptr_entity
c
c User defined types (ent_user<>0 canot be overruled
c  string type and restofline can be overruled
c  if user specified /override on command lines, all types (execpt user_def)
c   can be overruled
c
	if(entity.user_type_tro .eq. 0 .and.
     1     ((entity.valtyp .eq. entity_block_valtyp_string) .or.
     1      (entity.valtyp .eq. entity_block_valtyp_restofline) .or.
     1       all_over)) then
c 
c Set override type to 0
c
	  override = 0  !enable override
	else
	  override = -1	!disable override
	endif
	table_check_override = override .ge. 0
	return
	end
 
	function table_toggle_verbone(ptr_table_info)
	implicit none
c
c Toggle state of verbone key, and return the status
c
	include 'table.inc'
	integer*4 ptr_table_info		!:i: table structure
	integer*4 table_toggle_verbone          !:f: return verbone status
c
c
	record /table_info/ table_info		!:i: table structure
	pointer (p_table_info,table_info)
c
	p_table_info = ptr_table_info
c
	table_info.verbone = .not. table_info.verbone
c
	table_toggle_verbone = table_info.verbone
	return
	end
	function table_entity_valreq(ptr_entity,negated)
	implicit none
c
c Return TRUE if entity has value required
c
	include 'table.inc'
	integer*4 ptr_entity
	logical*4 negated
	logical*4 table_entity_valreq
c
	record /entity_block/ entity
	pointer (p_entity,entity)
	logical*4 status
c
c Return the ent_flag
c If the match was negated, clear the value flag
c
	if(negated) then
	  status = .false.
	else
	  p_entity = ptr_entity
	  status = btest(entity.header.flags,entity_block_flag_valreq)
	endif
	table_entity_valreq = status
	return
	end
	function table_entity_value(ptr_entity,negated)
	implicit none
c
c Return TRUE if entity has value 
c
	include 'table.inc'
	integer*4 ptr_entity
	logical*4 negated
	logical*4 table_entity_value
c
	record /entity_block/ entity
	pointer (p_entity,entity)
c
	logical*4 status
c
c Return the ent_flag
c If the match was negated, clear the value flag
c
	if(negated) then
	  status = .false.
	else
	  p_entity = ptr_entity
	  status = btest(entity.header.flags,entity_block_flag_val)
	endif
	table_entity_value = status
	return
	end
	function table_entity_list(ptr_entity,negated)
	implicit none
c
c Return TRUE if entity has list 
c
	include 'table.inc'
	integer*4 ptr_entity
	logical*4 negated
	logical*4 table_entity_list
c
	record /entity_block/ entity
	pointer (p_entity,entity)
c
	logical*4 status
c
c Return the ent_flag
c If the match was negated, clear the value flag
c
	if(negated) then
	  status = .false.
	else
	  p_entity = ptr_entity
	  status = btest(entity.header.flags,entity_block_flag_list)
	endif
	table_entity_list = status
	return
	end
	function table_entity_type(ptr_entity)
	implicit none
c
c Return the entity type
c
	include 'table.inc'
	integer*4 ptr_entity
	logical*4 table_entity_type
c
	record /entity_block/ entity
	pointer (p_entity,entity)
c
c Return the ent_type
c
	p_entity = ptr_entity
	table_entity_type = entity.valtyp
	return
	end
	function table_entity_user_type(ptr_table_info,ptr_entity)
	implicit none
c
c Return the pointer to the user type
c
	include 'table.inc'
	integer*4 ptr_table_info		!:i: pointer to info block
	integer*4 ptr_entity			!:i: pointer to entity
	logical*4 table_entity_user_type	!:f: pointer to usertype or 0
c
	record /table_info/ table_info
	pointer (p_table_info,table_info)
c
	record /entity_block/ entity
	pointer (p_entity,entity)
c
	record /type_block/ type_block
	pointer (p_type_block,type_block)
c
	integer*4 ent_user,p_type_block
c
	integer*4 table__tro
c
c Return the ent_type
c
	p_table_info = ptr_table_info
	p_entity = ptr_entity
c
	p_type_block = table__tro(table_info,entity.user_type_tro)
c
	if(p_type_block .eq. 0) then
	  ent_user = 0
	else
	  ent_user = table__tro(table_info,type_block.keyword_tro)
	endif
	table_entity_user_type = ent_user
	return
	end
	function table_entity_syntax(ptr_table_info,ptr_entity)
	implicit none
c
c Return the pointer to the (possible) syntax change
c
	include 'table.inc'
	integer*4 ptr_table_info		!:i: pointer to table block
	integer*4 ptr_entity			!:i: pointer to entity block
	logical*4 table_entity_syntax		!:f: pointer to syntax change
c
	record /table_info/ table_info
	pointer (p_table_info,table_info)
c
	record /entity_block/ entity
	pointer (p_entity,entity)
c
	integer*4 table__tro
c
c Return the ent_type
c
	p_table_info = ptr_table_info
	p_entity = ptr_entity
c
	table_entity_syntax = table__tro(table_info,entity.syntax_tro)
	return
	end